]> git.uio.no Git - u/mrichter/AliRoot.git/blame - PYTHIA6/pythia6.4.25/pythia-6.4.25.f
git://git.uio.no / u / mrichter / AliRoot.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
PHOS - Fixing circular dependecies + initial DA files
[u/mrichter/AliRoot.git] / PYTHIA6 / pythia6.4.25 / pythia-6.4.25.f
CommitLineData
92e27c01 1C*********************************************************************
2C*********************************************************************
3C* **
4C* Mar 2011 **
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* CERN/PH, CH-1211 Geneva, Switzerland **
28C* phone +41 - 22 - 767 2447 **
29C* E-mail peter.skands@cern.ch **
30C* **
31C* Several parts are written by Hans-Uno Bengtsson **
32C* PYSHOW is written together with Mats Bengtsson **
33C* PYMAEL is written by Emanuel Norrbin **
34C* advanced popcorn baryon production written by Patrik Eden **
35C* code for virtual photons mainly written by Christer Friberg **
36C* code for low-mass strings mainly written by Emanuel Norrbin **
37C* Bose-Einstein code mainly written by Leif Lonnblad **
38C* CTEQ parton distributions are by the CTEQ collaboration **
39C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
40C* SaS photon parton distributions together with Gerhard Schuler **
41C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
42C* MSSM Higgs mass calculation code by M. Carena, **
43C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
44C* UED implementation by M. Elkacimi, D. Goujdami, H. Przysiezniak **
45C* PYGAUS adapted from CERN library (K.S. Kolbig) **
46C* NRQCD/colour octet production of onium by S. Wolf **
47C* **
48C* The latest program version and documentation is found on WWW **
49C* http://www.thep.lu.se/~torbjorn/Pythia.html **
50C* **
51C* Copyright Torbjorn Sjostrand, Lund 2010 **
52C* **
53C*********************************************************************
54C*********************************************************************
55C *
56C List of subprograms in order of appearance, with main purpose *
57C (S = subroutine, F = function, B = block data) *
58C *
59C B PYDATA to contain all default values *
60C S PYCKBD to check that BLOCK DATA has been correctly loaded *
61C S PYTEST to test the proper functioning of the package *
62C S PYHEPC to convert between /PYJETS/ and /HEPEVT/ records *
63C *
64C S PYINIT to administer the initialization procedure *
65C S PYEVNT to administer the generation of an event *
66C S PYEVNW ditto, for new multiple interactions scenario *
67C S PYSTAT to print cross-section and other information *
68C S PYUPEV to administer the generation of an LHA hard process *
69C S PYUPIN to provide initialization needed for LHA input *
70C S PYLHEF to produce a Les Houches Event File from run *
71C S PYINRE to initialize treatment of resonances *
72C S PYINBM to read in beam, target and frame choices *
73C S PYINKI to initialize kinematics of incoming particles *
74C S PYINPR to set up the selection of included processes *
75C S PYXTOT to give total, elastic and diffractive cross-sect. *
76C S PYMAXI to find differential cross-section maxima *
77C S PYPILE to select multiplicity of pileup events *
78C S PYSAVE to save alternatives for gamma-p and gamma-gamma *
79C S PYGAGA to handle lepton -> lepton + gamma branchings *
80C S PYRAND to select subprocess and kinematics for event *
81C S PYSCAT to set up kinematics and colour flow of event *
82C S PYEVOL handler for pT-ordered ISR and multiple interactions *
83C S PYSSPA to simulate initial state spacelike showers *
84C S PYPTIS to do pT-ordered initial state spacelike showers *
85C S PYMEMX auxiliary to PYSSPA/PYPTIS for ME correction maximum *
86C S PYMEWT auxiliary to PYSSPA/.. for matrix element correction *
87C S PYPTMI to do pT-ordered multiple interactions *
88C F PYFCMP to give companion quark x*f distribution *
89C F PYPCMP to calculate momentum integral for companion quarks *
90C S PYUPRE to rearranges contents of the HEPEUP commonblock *
91C S PYADSH to administrate sequential final-state showers *
92C S PYVETO to allow the generation of an event to be aborted *
93C S PYRESD to perform resonance decays *
94C S PYMULT to generate multiple interactions - old scheme *
95C S PYREMN to add on target remnants - old scheme *
96C S PYMIGN to generate multiple interactions - new scheme *
97C S PYMIHK to connect colours in mult. int. - new scheme *
98C S PYCTTR to translate PYTHIA colour information to LHA1 tags *
99C S PYMIHG to collapse two pairs of LHA1 colour tags. *
100C S PYMIRM to add on target remnants in mult. int.- new scheme *
101C S PYFSCR to perform final state colour reconnections - -"- *
102C S PYDIFF to set up kinematics for diffractive events *
103C S PYDISG to set up kinematics, remnant and showers for DIS *
104C S PYDOCU to compute cross-sections and handle documentation *
105C S PYFRAM to perform boosts between different frames *
106C S PYWIDT to calculate full and partial widths of resonances *
107C S PYOFSH to calculate partial width into off-shell channels *
108C S PYRECO to handle colour reconnection in W+W- events *
109C S PYKLIM to calculate borders of allowed kinematical region *
110C S PYKMAP to construct value of kinematical variable *
111C S PYSIGH to calculate differential cross-sections *
112C S PYSGQC auxiliary to PYSIGH for QCD processes *
113C S PYSGHF auxiliary to PYSIGH for heavy flavour processes *
114C S PYSGWZ auxiliary to PYSIGH for W and Z processes *
115C S PYSGHG auxiliary to PYSIGH for Higgs processes *
116C S PYSGSU auxiliary to PYSIGH for supersymmetry processes *
117C S PYSGTC auxiliary to PYSIGH for technicolor processes *
118C S PYSGEX auxiliary to PYSIGH for various exotic processes *
119C S PYPDFU to evaluate parton distributions *
120C S PYPDFL to evaluate parton distributions at low x and Q^2 *
121C S PYPDEL to evaluate electron parton distributions *
122C S PYPDGA to evaluate photon parton distributions (generic) *
123C S PYGGAM to evaluate photon parton distributions (SaS sets) *
124C S PYGVMD to evaluate VMD part of photon parton distributions *
125C S PYGANO to evaluate anomalous part of photon PDFs *
126C S PYGBEH to evaluate Bethe-Heitler part of photon PDFs *
127C S PYGDIR to evaluate direct contribution to photon PDFs *
128C S PYPDPI to evaluate pion parton distributions *
129C S PYPDPR to evaluate proton parton distributions *
130C F PYCTEQ to evaluate the CTEQ 3 proton parton distributions *
131C S PYGRVL to evaluate the GRV 94L proton parton distributions *
132C S PYGRVM to evaluate the GRV 94M proton parton distributions *
133C S PYGRVD to evaluate the GRV 94D proton parton distributions *
134C F PYGRVV auxiliary to the PYGRV* routines *
135C F PYGRVW auxiliary to the PYGRV* routines *
136C F PYGRVS auxiliary to the PYGRV* routines *
137C F PYCT5L to evaluate the CTEQ 5L proton parton distributions *
138C F PYCT5M to evaluate the CTEQ 5M1 proton parton distributions *
139C S PYPDPO to evaluate old proton parton distributions *
140C F PYHFTH to evaluate threshold factor for heavy flavour *
141C S PYSPLI to find flavours left in hadron when one removed *
142C F PYGAMM to evaluate ordinary Gamma function Gamma(x) *
143C S PYWAUX to evaluate auxiliary functions W1(s) and W2(s) *
144C S PYI3AU to evaluate auxiliary function I3(s,t,u,v) *
145C F PYSPEN to evaluate Spence (dilogarithm) function Sp(x) *
146C S PYQQBH to evaluate matrix element for g + g -> Q + Qbar + H *
147C S PYSTBH to evaluate matrix element for t + b + H processes *
148C S PYTBHB auxiliary to PYSTBH *
149C S PYTBHG auxiliary to PYSTBH *
150C S PYTBHQ auxiliary to PYSTBH *
151C F PYTBHS auxiliary to PYSTBH *
152C *
153C S PYMSIN to initialize the supersymmetry simulation *
154C S PYSLHA to interface to SUSY spectrum and decay calculators *
155C S PYAPPS to determine MSSM parameters from SUGRA input *
156C S PYSUGI to determine MSSM parameters using ISASUSY *
157C S PYFEYN to determine MSSM Higgs parameters using FEYNHIGGS *
158C F PYRNMQ to determine running squark masses *
159C S PYTHRG to calculate sfermion third-gen. mass eigenstates *
160C S PYINOM to calculate neutralino/chargino mass eigenstates *
161C F PYRNM3 to determine running M3, gluino mass *
162C S PYEIG4 to calculate eigenvalues and -vectors in 4*4 matrix *
163C S PYHGGM to determine Higgs mass spectrum *
164C S PYSUBH to determine Higgs masses in the MSSM *
165C S PYPOLE to determine Higgs masses in the MSSM *
166C S PYRGHM auxiliary to PYPOLE *
167C S PYGFXX auxiliary to PYRGHM *
168C F PYFINT auxiliary to PYPOLE *
169C F PYFISB auxiliary to PYFINT *
170C S PYSFDC to calculate sfermion decay partial widths *
171C S PYGLUI to calculate gluino decay partial widths *
172C S PYTBBN to calculate 3-body decay of gluino to neutralino *
173C S PYTBBC to calculate 3-body decay of gluino to chargino *
174C S PYNJDC to calculate neutralino decay partial widths *
175C S PYCJDC to calculate chargino decay partial widths *
176C F PYXXZ6 auxiliary for ino 3-body decays *
177C F PYXXGA auxiliary for ino -> ino + gamma decay *
178C F PYX2XG auxiliary for ino -> ino + gauge boson decay *
179C F PYX2XH auxiliary for ino -> ino + Higgs decay *
180C S PYHEXT to calculate non-SM Higgs decay partial widths *
181C F PYH2XX auxiliary for H -> ino + ino decay *
182C F PYGAUS to perform Gaussian integration *
183C F PYGAU2 copy of PYGAUS to allow two-dimensional integration *
184C F PYSIMP to perform Simpson integration *
185C F PYLAMF to evaluate the lambda kinematics function *
186C S PYTBDY to perform 3-body decay of gauginos *
187C S PYTECM to calculate techni_rho/omega masses *
188C S PYXDIN to initialize Universal Extra Dimensions *
189C S PYUEDC to compute UED mass radiative corrections *
190C S PYXUED to compute UED cross sections *
191C S PYGRAM to generate UED G* (excited graviton) mass spectrum *
192C F PYGRAW to compute UED partial widths to G* *
193C F PYWDKK to compute UED differential partial widths to G* *
194C S PYEICG to calculate eigenvalues of a 4*4 complex matrix *
195C S PYCMQR auxiliary to PYEICG *
196C S PYCMQ2 auxiliary to PYEICG *
197C S PYCDIV auxiliary to PYCMQR *
198C S PYCSRT auxiliary to PYCMQR *
199C S PYTHAG auxiliary to PYCMQR *
200C S PYCBAL auxiliary to PYEICG *
201C S PYCBA2 auxiliary to PYEICG *
202C S PYCRTH auxiliary to PYEICG *
203C S PYLDCM auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
204C S PYBKSB auxiliary to PYSIGH, for technicolor in QCD 2 -> 2 *
205C S PYWIDX to calculate decay widths from within PYWIDT *
206C S PYRVSF to calculate R-violating sfermion decay widths *
207C S PYRVNE to calculate R-violating neutralino decay widths *
208C S PYRVCH to calculate R-violating chargino decay widths *
209C S PYRVGL to calculate R-violating gluino decay widths *
210C F PYRVSB auxiliary to PYRVSF *
211C S PYRVGW to calculate R-Violating 3-body widths *
212C F PYRVI1 auxiliary to PYRVGW, to do PS integration for res. *
213C F PYRVI2 auxiliary to PYRVGW, to do PS integration for LR-int.*
214C F PYRVI3 auxiliary to PYRVGW, to do PS X integral for int. *
215C F PYRVG1 auxiliary to PYRVI1, general matrix element, res. *
216C F PYRVG2 auxiliary to PYRVI2, general matrix element, LR-int. *
217C F PYRVG3 auxiliary to PYRVI3, to do PS Y integral for int. *
218C F PYRVG4 auxiliary to PYRVG3, general matrix element, int. *
219C F PYRVR auxiliary to PYRVG1, Breit-Wigner *
220C F PYRVS auxiliary to PYRVG2 & PYRVG4 *
221C *
222C S PY1ENT to fill one entry (= parton or particle) *
223C S PY2ENT to fill two entries *
224C S PY3ENT to fill three entries *
225C S PY4ENT to fill four entries *
226C S PY2FRM to interface to generic two-fermion generator *
227C S PY4FRM to interface to generic four-fermion generator *
228C S PY6FRM to interface to generic six-fermion generator *
229C S PY4JET to generate a shower from a given 4-parton config *
230C S PY4JTW to evaluate the weight od a shower history for above *
231C S PY4JTS to set up the parton configuration for above *
232C S PYJOIN to connect entries with colour flow information *
233C S PYGIVE to fill (or query) commonblock variables *
234C S PYONOF to allow easy control of particle decay modes *
235C S PYTUNE to select a predefined 'tune' for min-bias and UE *
236C S PYEXEC to administrate fragmentation and decay chain *
237C S PYPREP to rearrange showered partons along strings *
238C S PYSTRF to do string fragmentation of jet system *
239C S PYJURF to find boost to string junction rest frame *
240C S PYINDF to do independent fragmentation of one or many jets *
241C S PYDECY to do the decay of a particle *
242C S PYDCYK to select parton and hadron flavours in decays *
243C S PYKFDI to select parton and hadron flavours in fragm *
244C S PYNMES to select number of popcorn mesons *
245C S PYKFIN to calculate falvour prod. ratios from input params. *
246C S PYPTDI to select transverse momenta in fragm *
247C S PYZDIS to select longitudinal scaling variable in fragm *
248C S PYSHOW to do m-ordered timelike parton shower evolution *
249C S PYPTFS to do pT-ordered timelike parton shower evolution *
250C F PYMAEL auxiliary to PYSHOW & PYPTFS: gluon emission ME's *
251C S PYBOEI to include Bose-Einstein effects (crudely) *
252C S PYBESQ auxiliary to PYBOEI *
253C F PYMASS to give the mass of a particle or parton *
254C F PYMRUN to give the running MSbar mass of a quark *
255C S PYNAME to give the name of a particle or parton *
256C F PYCHGE to give three times the electric charge *
257C F PYCOMP to compress standard KF flavour code to internal KC *
258C S PYERRM to write error messages and abort faulty run *
259C F PYALEM to give the alpha_electromagnetic value *
260C F PYALPS to give the alpha_strong value *
261C F PYANGL to give the angle from known x and y components *
262C F PYR to provide a random number generator *
263C S PYRGET to save the state of the random number generator *
264C S PYRSET to set the state of the random number generator *
265C S PYROBO to rotate and/or boost an event *
266C S PYEDIT to remove unwanted entries from record *
267C S PYLIST to list event record or particle data *
268C S PYLOGO to write a logo *
269C S PYUPDA to update particle data *
270C F PYK to provide integer-valued event information *
271C F PYP to provide real-valued event information *
272C S PYSPHE to perform sphericity analysis *
273C S PYTHRU to perform thrust analysis *
274C S PYCLUS to perform three-dimensional cluster analysis *
275C S PYCELL to perform cluster analysis in (eta, phi, E_T) *
276C S PYJMAS to give high and low jet mass of event *
277C S PYFOWO to give Fox-Wolfram moments *
278C S PYTABU to analyze events, with tabular output *
279C *
280C S PYEEVT to administrate the generation of an e+e- event *
281C S PYXTEE to give the total cross-section at given CM energy *
282C S PYRADK to generate initial state photon radiation *
283C S PYXKFL to select flavour of primary qqbar pair *
284C S PYXJET to select (matrix element) jet multiplicity *
285C S PYX3JT to select kinematics of three-jet event *
286C S PYX4JT to select kinematics of four-jet event *
287C S PYXDIF to select angular orientation of event *
288C S PYONIA to perform generation of onium decay to gluons *
289C *
290C S PYBOOK to book a histogram *
291C S PYFILL to fill an entry in a histogram *
292C S PYFACT to multiply histogram contents by a factor *
293C S PYOPER to perform operations between histograms *
294C S PYHIST to print and reset all histograms *
295C S PYPLOT to print a single histogram *
296C S PYNULL to reset contents of a single histogram *
297C S PYDUMP to dump histogram contents onto a file *
298C *
299C S PYSTOP routine to handle Fortran STOP condition *
300C *
301C S PYKCUT dummy routine for user kinematical cuts *
302C S PYEVWT dummy routine for weighting events *
303C S UPINIT dummy routine to initialize user processes *
304C S UPEVNT dummy routine to generate a user process event *
305C S UPVETO dummy routine to abort event at parton level *
306C S PDFSET dummy routine to be removed when using PDFLIB *
307C S STRUCTM dummy routine to be removed when using PDFLIB *
308C S STRUCTP dummy routine to be removed when using PDFLIB *
309C S SUGRA dummy routine to be removed when linking with ISAJET *
310C F VISAJE dummy functn. to be removed when linking with ISAJET *
311C S SSMSSM dummy routine to be removed when linking with ISAJET *
312C S FHSETFLAGS dummy routine -"- FEYNHIGGS *
313C S FHSETPARA dummy routine -"- FEYNHIGGS *
314C S FHHIGGSCORR dummy routine -"- FEYNHIGGS *
315C S PYTAUD dummy routine for interface to tau decay libraries *
316C S PYTIME dummy routine for giving date and time *
317C *
318C*********************************************************************
319
320C...PYDATA
321C...Default values for switches and parameters,
322C...and particle, decay and process data.
323
324 BLOCK DATA PYDATA
325
326C...Double precision and integer declarations.
327 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
328 IMPLICIT INTEGER(I-N)
329 INTEGER PYK,PYCHGE,PYCOMP
330C...Commonblocks.
331 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
332 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
333 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
334 COMMON/PYDAT4/CHAF(500,2)
335 CHARACTER CHAF*16
336 COMMON/PYDATR/MRPY(6),RRPY(100)
337 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
338 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
339 COMMON/PYINT1/MINT(400),VINT(400)
340 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
341 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
342 COMMON/PYINT4/MWID(500),WIDS(500,5)
343 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
344 COMMON/PYINT6/PROC(0:500)
345 CHARACTER PROC*28
346 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
347 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
348 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
349 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
350 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
351 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
352 COMMON/PYPUED/IUED(0:99),RUED(0:99)
353 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
354 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
355 & AU(3,3),AD(3,3),AE(3,3)
356 COMMON/PYLH3C/CPRO(2),CVER(2)
357 CHARACTER CPRO*12,CVER*12
358 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,/PYSUBS/,
359 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
360 &/PYINT6/,/PYINT7/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYTCSM/,/PYPUED/,
361 &/PYBINS/,/PYLH3P/,/PYLH3C/
362
363C...PYDAT1, containing status codes and most parameters.
364 DATA MSTU/
365 & 0, 0, 0, 4000,10000, 500, 8000, 0, 0, 2,
366 1 6, 0, 1, 0, 0, 1, 0, 0, 0, 0,
367 2 2, 10, 0, 0, 1, 10, 0, 0, 0, 0,
368 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
369 4 2, 2, 1, 4, 2, 1, 1, 0, 0, 0,
370 5 25, 24, 0, 1, 0, 0, 0, 0, 0, 0,
371 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
372 7 30*0,
373 1 1, 0, 0, 0, 0, 0, 0, 0, 0, 0,
374 2 1, 5, 3, 5, 0, 0, 0, 0, 0, 0,
375 & 80*0/
376 DATA (PARU(I),I=1,100)/
377 & 3.141592653589793D0, 6.283185307179586D0,
378 & 0.197327D0, 5.06773D0, 0.389380D0, 2.56819D0, 4*0D0,
379 1 0.001D0, 0.09D0, 0.01D0, 2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
380 2 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
381 3 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
382 4 2.0D0, 1.0D0, 0.25D0, 2.5D0, 0.05D0,
383 4 0D0, 0D0, 0.0001D0, 0D0, 0D0,
384 5 2.5D0,1.5D0,7.0D0,1.0D0,0.5D0,2.0D0,3.2D0, 0D0, 0D0, 0D0,
385 6 40*0D0/
386 DATA (PARU(I),I=101,200)/
387 & 0.00729735D0, 0.232D0, 0.007764D0, 1.0D0, 1.16639D-5,
388 & 0D0, 0D0, 0D0, 0D0, 0D0,
389 1 0.20D0, 0.25D0, 1.0D0, 4.0D0, 10D0, 0D0, 0D0, 0D0, 0D0, 0D0,
390 2 -0.693D0, -1.0D0, 0.387D0, 1.0D0, -0.08D0,
391 2 -1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,
392 3 1.0D0,-1.0D0, 1.0D0,-1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
393 4 5.0D0, 1.0D0, 1.0D0, 0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0,
394 5 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
395 6 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
396 7 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
397 8 1.0D0, 1.0D0, 1.0D0, 0.0D0, 0.0D0, 1.0D0, 1.0D0, 0D0,0D0,0D0,
398 9 0D0, 0D0, 0D0, 0D0, 1.0D0, 0D0, 0D0, 0D0, 0D0, 0D0/
399 DATA MSTJ/
400 & 1, 3, 0, 0, 0, 0, 0, 0, 0, 0,
401 1 4, 2, 0, 1, 0, 2, 2, 20, 0, 0,
402 2 2, 1, 1, 2, 1, 2, 2, 0, 0, 0,
403 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
404 4 2, 2, 4, 2, 5, 3, 3, 0, 0, 3,
405 5 0, 3, 0, 2, 0, 0, 1, 0, 0, 0,
406 6 40*0,
407 & 5, 2, 7, 5, 1, 1, 0, 2, 0, 2,
408 1 0, 0, 0, 0, 1, 1, 0, 0, 0, 0,
409 2 80*0/
410 DATA PARJ/
411 & 0.10D0, 0.30D0, 0.40D0, 0.05D0, 0.50D0,
412 & 0.50D0, 0.50D0, 0.6D0, 1.2D0, 0.6D0,
413 1 0.50D0,0.60D0,0.75D0, 0D0, 0D0, 0D0, 0D0, 1.0D0, 1.0D0, 0D0,
414 2 0.36D0, 1.0D0,0.01D0, 2.0D0,1.0D0,0.4D0, 0D0, 0D0, 0D0, 0D0,
415 3 0.10D0, 1.0D0, 0.8D0, 1.5D0,0D0,2.0D0,0.2D0, 0D0,0.08D0,1D0,
416 4 0.3D0, 0.58D0, 0.5D0, 0.9D0,0.5D0,1.0D0,1.0D0,1.5D0,1D0,10D0,
417 5 0.77D0, 0.77D0, 0.77D0, -0.05D0, -0.005D0,
418 5 0D0, 0D0, 0D0, 1.0D0, 0D0,
419 6 4.5D0, 0.7D0, 0D0,0.003D0, 0.5D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
420 7 10D0, 1000D0, 100D0, 1000D0, 0D0, 0.7D0,10D0, 0D0,0D0,0.5D0,
421 8 0.29D0, 1.0D0, 1.0D0, 0D0, 10D0, 10D0, 0D0, 0D0, 0D0,1D-4,
422 9 0.02D0, 1.0D0, 0.2D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
423 & 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
424 1 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
425 2 1.0D0, 0.25D0,91.187D0,2.489D0, 0.01D0,
426 2 2.0D0, 1.0D0, 0.25D0,0.002D0, 0D0,
427 3 0D0, 0D0, 0D0, 0D0, 0.01D0, 0.99D0, 0D0, 0D0, 0.2D0, 0D0,
428 4 10*0D0,
429 5 10*0D0,
430 6 10*0D0,
431 7 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, -0.693D0,
432 8 -1.0D0, 0.387D0, 1.0D0, -0.08D0, -1.0D0,
433 8 1.0D0, 1.0D0, -0.693D0, -1.0D0, 0.387D0,
434 9 1.0D0, -0.08D0, -1.0D0, 1.0D0, 1.0D0,
435 9 5*0D0/
436
437C...PYDAT2, with particle data and flavour treatment parameters.
438 DATA (KCHG(I,1),I= 1, 500)/-1,2,-1,2,-1,2,-1,2,2*0,-3,0,-3,0,
439 &-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,
440 &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,
441 &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,
442 &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,
443 &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,
444 &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,
445 &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,
446 &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,
447 &7*0,3,
448C...UED singlet and doublet quarks, leptons, and KK g, gamma, Z, and W
449 &81*0,-1,2,-1,2,-1,2,-1,2,-1,2,-1,2,
450 &3*-3,0,-3,0,-3,0,-3,
451 &3*0,3,
452 &25*0/
453 DATA (KCHG(I,2),I= 1, 500)/8*1,12*0,2,20*0,1,107*0,-1,0,2*-1,
454 &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,
455 &-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,
456 &6*1,9*0,2,3*0,2,0,5*2,2*1,17*0,6*2,
457 &83*0,12*1,9*0,2,3*0,25*0/
458 DATA (KCHG(I,3),I= 1, 500)/8*1,2*0,8*1,5*0,1,9*0,1,2*0,1,3*0,
459 &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,
460 &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,
461 &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,
462 &81*0,21*1,3*0,1,25*0/
463 DATA (KCHG(I,4),I= 1, 290)/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,
464 &16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,
465 &37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,
466 &58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,
467 &79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,
468 &100,110,111,113,115,130,211,213,215,221,223,225,310,311,313,315,
469 &321,323,325,331,333,335,411,413,415,421,423,425,431,433,435,441,
470 &443,445,511,513,515,521,523,525,531,533,535,541,543,545,551,553,
471 &555,990,1103,1114,2101,2103,2112,2114,2203,2212,2214,2224,3101,
472 &3103,3112,3114,3122,3201,3203,3212,3214,3222,3224,3303,3312,3314,
473 &3322,3324,3334,4101,4103,4112,4114,4122,4132,4201,4203,4212,4214,
474 &4222,4224,4232,4301,4303,4312,4314,4322,4324,4332,4334,4403,4412,
475 &4414,4422,4424,4432,4434,4444,5101,5103,5112,5114,5122,5132,5142,
476 &5201,5203,5212,5214,5222,5224,5232,5242,5301,5303,5312,5314,5322,
477 &5324,5332,5334,5342,5401,5403,5412,5414,5422,5424,5432,5434,5442,
478 &5444,5503,5512,5514,5522,5524,5532,5534,5542,5544,5554,10111,
479 &10113,10211,10213,10221,10223,10311,10313,10321,10323,10331,
480 &10333,10411,10413,10421,10423,10431,10433,10441,10443,10511,
481 &10513,10521,10523,10531,10533,10541,10543,10551,10553,20113,
482 &20213,20223,20313,20323,20333,20413,20423,20433,20443,20513/
483 DATA (KCHG(I,4),I= 291, 500)/20523,20533,20543,20553,100443,
484 &100553,1000001,1000002,1000003,1000004,1000005,1000006,1000011,
485 &1000012,1000013,1000014,1000015,1000016,1000021,1000022,1000023,
486 &1000024,1000025,1000035,1000037,1000039,2000001,2000002,2000003,
487 &2000004,2000005,2000006,2000011,2000012,2000013,2000014,2000015,
488 &2000016,3000111,3000211,3000221,3000331,3000113,3000213,3000223,
489 &3100021,3100111,3200111,3100113,3200113,3300113,3400113,4000001,
490 &4000002,4000011,4000012,5000039,9900012,9900014,9900016,9900023,
491 &9900024,9900041,9900042,9900110,9900210,9900220,9900330,9900440,
492 &9902110,9902210,9900443,9900441,9910441,9900553,9900551,9910551,
493 &3000115,3000215,
494 &81*0,
495C...UED singlet and doublet quarks and leptons, and KK g, gamma, Z, and W.
496 &6100001,6100002,6100003,6100004,6100005,6100006,
497 &5100001,5100002,5100003,5100004,5100005,5100006,
498 &6100011,6100013,6100015,
499 &5100012,5100011,5100014,5100013,5100016,5100015,
500 &5100021,5100022,5100023,5100024,
501 &25*0/
502 DATA (PMAS(I,1),I= 1, 217)/2*0.33D0,0.5D0,1.5D0,4.8D0,175D0,
503 &2*400D0,2*0D0,0.00051D0,0D0,0.10566D0,0D0,1.777D0,0D0,400D0,
504 &5*0D0,91.188D0,80.45D0,115D0,6*0D0,500D0,900D0,500D0,3*300D0,
505 &3*0D0,5000D0,200D0,40*0D0,1D0,2D0,5D0,16*0D0,0.13498D0,0.7685D0,
506 &1.318D0,0.49767D0,0.13957D0,0.7669D0,1.318D0,0.54745D0,0.78194D0,
507 &1.275D0,2*0.49767D0,0.8961D0,1.432D0,0.4936D0,0.8916D0,1.425D0,
508 &0.95777D0,1.0194D0,1.525D0,1.8693D0,2.01D0,2.46D0,1.8645D0,
509 &2.0067D0,2.46D0,1.9685D0,2.1124D0,2.5735D0,2.9798D0,3.09688D0,
510 &3.5562D0,5.2792D0,5.3248D0,5.83D0,5.2789D0,5.3248D0,5.83D0,
511 &5.3693D0,5.4163D0,6.07D0,6.594D0,6.602D0,7.35D0,9.4D0,9.4603D0,
512 &9.9132D0,0D0,0.77133D0,1.234D0,0.57933D0,0.77133D0,0.93957D0,
513 &1.233D0,0.77133D0,0.93827D0,1.232D0,1.231D0,0.80473D0,0.92953D0,
514 &1.19744D0,1.3872D0,1.11568D0,0.80473D0,0.92953D0,1.19255D0,
515 &1.3837D0,1.18937D0,1.3828D0,1.09361D0,1.3213D0,1.535D0,1.3149D0,
516 &1.5318D0,1.67245D0,1.96908D0,2.00808D0,2.4521D0,2.5D0,2.2849D0,
517 &2.4703D0,1.96908D0,2.00808D0,2.4535D0,2.5D0,2.4529D0,2.5D0,
518 &2.4656D0,2.15432D0,2.17967D0,2.55D0,2.63D0,2.55D0,2.63D0,2.704D0,
519 &2.8D0,3.27531D0,3.59798D0,3.65648D0,3.59798D0,3.65648D0,
520 &3.78663D0,3.82466D0,4.91594D0,5.38897D0,5.40145D0,5.8D0,5.81D0,
521 &5.641D0,5.84D0,7.00575D0,5.38897D0,5.40145D0,5.8D0,5.81D0,5.8D0/
522 DATA (PMAS(I,1),I= 218, 500)/5.81D0,5.84D0,7.00575D0,5.56725D0,
523 &5.57536D0,5.96D0,5.97D0,5.96D0,5.97D0,6.12D0,6.13D0,7.19099D0,
524 &6.67143D0,6.67397D0,7.03724D0,7.0485D0,7.03724D0,7.0485D0,
525 &7.21101D0,7.219D0,8.30945D0,8.31325D0,10.07354D0,10.42272D0,
526 &10.44144D0,10.42272D0,10.44144D0,10.60209D0,10.61426D0,
527 &11.70767D0,11.71147D0,15.11061D0,0.9835D0,1.231D0,0.9835D0,
528 &1.231D0,1D0,1.17D0,1.429D0,1.29D0,1.429D0,1.29D0,2*1.4D0,2.272D0,
529 &2.424D0,2.272D0,2.424D0,2.5D0,2.536D0,3.4151D0,3.46D0,5.68D0,
530 &5.73D0,5.68D0,5.73D0,5.92D0,5.97D0,7.25D0,7.3D0,9.8598D0,9.875D0,
531 &2*1.23D0,1.282D0,2*1.402D0,1.427D0,2*2.372D0,2.56D0,3.5106D0,
532 &2*5.78D0,6.02D0,7.3D0,9.8919D0,3.686D0,10.0233D0,32*500D0,
533 &3*110D0,350D0,3*210D0,500D0,125D0,250D0,400D0,2*350D0,300D0,
534 &4*400D0,1000D0,3*500D0,1200D0,750D0,2*200D0,7*0D0,3*3.1D0,
535 &3*9.5D0,2*250D0,
536 &81*0,
537C...UED
538 &586.,588.,586.,588.,586.,586.,6*598.,
539 &3*505.,6*516.,640.,501.,536.,536.,25*0.D0/
540 DATA (PMAS(I,2),I= 1, 500)/5*0D0,1.39816D0,16*0D0,2.47813D0,
541 &2.07115D0,0.00367D0,6*0D0,14.54029D0,0D0,16.66099D0,8.38842D0,
542 &3.3752D0,4.17669D0,3*0D0,417.29147D0,0.39162D0,60*0D0,0.151D0,
543 &0.107D0,2*0D0,0.149D0,0.107D0,0D0,0.00843D0,0.185D0,2*0D0,
544 &0.0505D0,0.109D0,0D0,0.0498D0,0.098D0,0.0002D0,0.00443D0,0.076D0,
545 &2*0D0,0.023D0,2*0D0,0.023D0,2*0D0,0.015D0,0.0013D0,0D0,0.002D0,
546 &2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,2*0D0,0.02D0,5*0D0,0.12D0,
547 &3*0D0,0.12D0,2*0D0,2*0.12D0,3*0D0,0.0394D0,4*0D0,0.036D0,0D0,
548 &0.0358D0,2*0D0,0.0099D0,0D0,0.0091D0,74*0D0,0.06D0,0.142D0,
549 &0.06D0,0.142D0,0D0,0.36D0,0.287D0,0.09D0,0.287D0,0.09D0,0.25D0,
550 &0.08D0,0.05D0,0.02D0,0.05D0,0.02D0,0.05D0,0D0,0.014D0,0.01D0,
551 &8*0.05D0,0D0,0.01D0,2*0.4D0,0.025D0,2*0.174D0,0.053D0,3*0.05D0,
552 &0.0009D0,4*0.05D0,3*0D0,19*1D0,0D0,7*1D0,0D0,1D0,0D0,1D0,0D0,
553 &0.0208D0,0.01195D0,0.03705D0,0.09511D0,1.89978D0,1.60746D0,
554 &0.13396D0,200.47294D0,0.02296D0,0.18886D0,94.66794D0,6.08718D0,
555 &0D0,2.17482D0,2.59359D0,2.59687D0,0.42896D0,0.41912D0,0.14153D0,
556 &2*0.00098D0,0.00097D0,26.7245D0,21.74916D0,0.88159D0,0.88001D0,
557 &7*0D0,6*0.01D0,0.25499D0,0.28446D0,131*0D0/
558 DATA (PMAS(I,3),I= 1, 500)/5*0D0,13.98156D0,16*0D0,24.78129D0,
559 &20.71149D0,0.03669D0,6*0D0,145.40294D0,0D0,166.60993D0,
560 &83.88423D0,33.75195D0,41.76694D0,3*0D0,4172.91467D0,3.91621D0,
561 &60*0D0,0.4D0,0.25D0,2*0D0,0.4D0,0.25D0,0D0,0.1D0,0.17D0,2*0D0,
562 &0.2D0,0.12D0,0D0,0.2D0,0.12D0,0.002D0,0.015D0,0.2D0,2*0D0,0.12D0,
563 &2*0D0,0.12D0,2*0D0,0.05D0,0.005D0,0D0,0.01D0,2*0D0,0.05D0,2*0D0,
564 &0.05D0,2*0D0,0.05D0,2*0D0,0.05D0,5*0D0,0.14D0,3*0D0,0.14D0,2*0D0,
565 &2*0.14D0,3*0D0,0.04D0,4*0D0,0.035D0,0D0,0.035D0,2*0D0,0.05D0,0D0,
566 &0.05D0,74*0D0,0.05D0,0.25D0,0.05D0,0.25D0,0D0,0.2D0,0.4D0,
567 &0.005D0,0.4D0,0.01D0,0.35D0,0.001D0,0.1D0,0.08D0,0.1D0,0.08D0,
568 &0.1D0,0D0,0.05D0,0.02D0,6*0.1D0,0.05D0,0.1D0,0D0,0.02D0,2*0.3D0,
569 &0.05D0,2*0.3D0,0.02D0,2*0.1D0,0.03D0,0.001D0,4*0.1D0,3*0D0,
570 &19*10D0,0.00001D0,7*10D0,0.00001D0,10D0,0.00001D0,10D0,0.00001D0,
571 &0.20797D0,0.11949D0,0.37048D0,0.95114D0,18.99785D0,16.07463D0,
572 &1.33964D0,450D0,0.22959D0,1.88863D0,360D0,60.8718D0,0D0,
573 &21.74824D0,25.93594D0,25.96873D0,4.28961D0,4.19124D0,1.41528D0,
574 &0.00977D0,0.00976D0,0.00973D0,267.24501D0,217.49162D0,8.81592D0,
575 &8.80013D0,13*0D0,2.54987D0,2.84456D0,
576 &81*0,
577C...UED
578 &12*0.2D0,9*0.1D0,0.2,10.,0.07,0.3,25*0.D0/
579 DATA (PMAS(I,4),I= 1, 500)/12*0D0,658654D0,0D0,0.0872D0,68*0D0,
580 &0.1D0,0.387D0,16*0D0,0.00003D0,2*0D0,15500D0,7804.5D0,5*0D0,
581 &26.762D0,3*0D0,3709D0,5*0D0,0.317D0,2*0D0,0.1244D0,2*0D0,0.14D0,
582 &5*0D0,0.468D0,2*0D0,0.462D0,2*0D0,0.483D0,2*0D0,0.15D0,18*0D0,
583 &44.34D0,0D0,78.88D0,4*0D0,23.96D0,2*0D0,49.1D0,0D0,87.1D0,0D0,
584 &24.6D0,4*0D0,0.0618D0,0.029D0,6*0D0,0.106D0,6*0D0,0.019D0,2*0D0,
585 &7*0.1D0,4*0D0,0.342D0,2*0.387D0,6*0D0,2*0.387D0,6*0D0,0.387D0,
586 &0D0,0.387D0,2*0D0,8*0.387D0,0D0,9*0.387D0,120*0D0,131*0D0/
587
588 DATA PARF/
589 & 0.5D0,0.25D0, 0.5D0,0.25D0, 1D0, 0.5D0, 0D0, 0D0, 0D0, 0D0,
590 1 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
591 2 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
592 3 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
593 4 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
594 5 0.5D0, 0D0, 0.5D0, 0D0, 1D0, 1D0, 0D0, 0D0, 0D0, 0D0,
595 6 0.75D0, 0.5D0, 0D0,0.1667D0,0.0833D0,0.1667D0,0D0,0D0,0D0, 0D0,
596 7 0D0, 0D0, 1D0,0.3333D0,0.6667D0,0.3333D0,0D0,0D0,0D0, 0D0,
597 8 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
598 9 0.0099D0, 0.0056D0, 0.199D0, 1.23D0, 4.17D0, 165D0, 4*0D0,
599 & 0.325D0,0.325D0,0.5D0,1.6D0, 5.0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
600 1 0D0,0.11D0,0.16D0,0.048D0,0.50D0,0.45D0,0.55D0,0.60D0,0D0,0D0,
601 2 0.2D0, 0.1D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
602 3 60*0D0,
603 4 0.2D0, 0.5D0, 8*0D0,
604 5 1800*0D0/
605 DATA ((VCKM(I,J),J=1,4),I=1,4)/
606 & 0.95113D0, 0.04884D0, 0.00003D0, 0.00000D0,
607 & 0.04884D0, 0.94940D0, 0.00176D0, 0.00000D0,
608 & 0.00003D0, 0.00176D0, 0.99821D0, 0.00000D0,
609 & 0.00000D0, 0.00000D0, 0.00000D0, 1.00000D0/
610
611C...PYDAT3, with particle decay parameters and data.
612 DATA (MDCY(I,1),I= 1, 500)/5*0,3*1,6*0,1,0,1,5*0,3*1,6*0,1,0,
613 &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,
614 &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,
615 &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,
616 &81*0,
617C...UED
618 &5*1,0,5*1,0,13*1,25*0/
619 DATA (MDCY(I,2),I= 1, 351)/1,9,17,25,33,41,56,66,2*0,76,80,82,
620 &87,89,143,145,150,2*0,153,162,174,190,210,6*0,289,0,311,334,420,
621 &503,3*0,530,539,40*0,540,541,545,16*0,554,556,561,570,579,581,
622 &583,590,598,604,613,615,617,620,630,636,639,650,656,667,673,736,
623 &739,747,808,810,818,851,853,857,858,861,863,899,900,908,944,945,
624 &953,992,993,997,1028,1029,1033,1034,1043,2*0,1045,3*0,1046,2*0,
625 &1049,1052,2*0,1053,1055,1058,2*0,1062,1063,1066,1069,0,1072,1077,
626 &1079,1082,1084,2*0,1088,1089,1090,1166,2*0,1170,1171,1172,1173,
627 &1174,2*0,1178,1179,1181,1182,1184,1188,0,1189,1193,1197,1201,
628 &1205,1209,1213,2*0,1217,1218,1219,1236,1245,2*0,1254,1255,1256,
629 &1257,1258,1267,2*0,1276,1277,1278,1279,1280,1289,1290,2*0,1299,
630 &1308,1317,1326,1335,1344,1353,1362,0,1371,1380,1389,1398,1407,
631 &1416,1425,1434,1443,1452,1453,1454,1455,1456,1461,1464,1466,1471,
632 &1473,1478,1485,1489,1491,1493,1495,1497,1499,1501,1503,1504,1506,
633 &1508,1510,1512,1514,1516,1518,1520,1522,1523,1525,1527,1541,1543,
634 &1545,1549,1551,1553,1555,1557,1559,1561,1563,1565,1567,1578,1592,
635 &1637,1661,1706,1730,1775,1802,1833,1859,1891,1917,1949,1975,2162,
636 &2331,2595,2826,3106,3402,0,3657,3706,3734,3783,3811,3860,3888,0,
637 &3924,0,3960,0,3996,4004,4012,4020,4217,4243,4270,4023,4029,4036,
638 &4043,4050,4056,4062,4071,4075,4079,4082,4084,4104,4126,4148,4170/
639 DATA (MDCY(I,2),I= 352, 500)/4185,4197,4204,7*0,4211,4212,4213,
640 &4214,4215,4216,4296,4322,
641 &81*0,
642C...UED
643 %5001,5003,5005,5007,5009,5011,5013,5016,5019,5022,5025,5028,
644 &5031,5032,5033,
645 &5034,5035,5036,5037,5038,5039,5040,5064,5065,5083,
646 &25*0/
647 DATA (MDCY(I,3),I= 1, 500)/5*8,15,2*10,2*0,4,2,5,2,54,2,5,3,
648 &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,
649 &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,
650 &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,
651 &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,
652 &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,
653 &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,
654 &45,27,31,26,32,26,32,26,187,169,264,231,280,296,255,0,49,28,49,
655 &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,
656 &3*22,15,12,2*7,7*0,6*1,26,30,
657 &81*0,
658C...UED
659 &6*2,6*3,9*1,24,1,18,6,25*0/
660 DATA (MDME(I,1),I= 1,8000)/6*1,-1,7*1,-1,7*1,-1,7*1,-1,7*1,-1,
661 &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,
662 &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,
663 &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,
664 &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,
665 &3*1,-1,3*1,-1,1,18*1,4*1,2*-1,2*1,-1,1249*1,2*-1,377*1,2*-1,
666 &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,
667 &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,
668 &5*-1,3*1,-1,
669 &649*0,
670C...UED
671 &10*1,2*0,15*1,3*0,9*1,5*1,0,5*1,0,5*1,0,5*1,0,
672 &1,24*1,2912*0/
673 DATA (MDME(I,2),I= 1,8000)/43*102,4*0,102,0,6*53,3*102,4*0,102,
674 &2*0,3*102,4*0,102,2*0,6*102,42,6*102,2*42,2*0,8*41,2*0,36*41,
675 &8*102,0,102,0,102,2*0,21*102,8*32,8*0,16*32,4*0,8*32,9*0,62*53,
676 &8*32,14*0,16*32,7*0,8*32,16*0,62*53,8*32,13*0,62*53,4*32,5*0,
677 &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,
678 &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,
679 &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,
680 &14*42,16*0,48,3*13,2*42,9*0,14*42,16*0,48,3*13,2*42,9*0,14*42,
681 &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,
682 &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,
683 &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,
684 &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,
685 &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,
686 &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,
687 &9*32,17*0,6*51,10*0,8*32,15*0,16*32,14*0,8*32,18*0,8*32,18*0,
688 &16*32,
689C...UED
690 &653*0,30*0,9*0,12*0,37*0,2912*0/
691 DATA (BRAT(I) ,I= 1, 348)/43*0D0,0.00003D0,0.001765D0,
692 &0.998205D0,35*0D0,1D0,6*0D0,0.1783D0,0.1735D0,0.1131D0,0.2494D0,
693 &0.003D0,0.09D0,0.0027D0,0.01D0,0.0014D0,0.0012D0,2*0.00025D0,
694 &0.0071D0,0.012D0,0.0004D0,0.00075D0,0.00006D0,2*0.00078D0,
695 &0.0034D0,0.08D0,0.011D0,0.0191D0,0.00006D0,0.005D0,0.0133D0,
696 &0.0067D0,0.0005D0,0.0035D0,0.0006D0,0.0015D0,0.00021D0,0.0002D0,
697 &0.00075D0,0.0001D0,0.0002D0,0.0011D0,3*0.0002D0,0.00022D0,
698 &0.0004D0,0.0001D0,2*0.00205D0,2*0.00069D0,0.00025D0,0.00051D0,
699 &0.00025D0,35*0D0,0.153995D0,0.11942D0,0.153984D0,0.119259D0,
700 &0.152272D0,3*0D0,0.033576D0,0.066806D0,0.033576D0,0.066806D0,
701 &0.0335D0,0.066806D0,2*0D0,0.321369D0,0.016494D0,2*0D0,0.016502D0,
702 &0.320615D0,2*0D0,0.00001D0,0.000591D0,6*0D0,2*0.108166D0,
703 &0.108087D0,0D0,0.000001D0,0D0,0.000353D0,0.04359D0,0.795274D0,
704 &4*0D0,0.000339D0,0.095746D0,0D0,0.060724D0,0.003054D0,0.000919D0,
705 &64*0D0,0.145835D0,0.113276D0,0.145835D0,0.113271D0,0.145781D0,
706 &0.049002D0,2*0D0,0.032025D0,0.063642D0,0.032025D0,0.063642D0,
707 &0.032022D0,0.063642D0,8*0D0,0.251225D0,0.0129D0,0.000006D0,0D0,
708 &0.0129D0,0.250764D0,0.00038D0,0D0,0.000008D0,0.000465D0,
709 &0.215418D0,5*0D0,2*0.085312D0,0.08531D0,7*0D0,0.000029D0,
710 &0.000536D0,5*0D0,0.000074D0,0D0,0.000417D0,0.000015D0,0.000061D0/
711 DATA (BRAT(I) ,I= 349, 655)/0.306789D0,0.689189D0,0D0,0.00289D0,
712 &69*0D0,0.000001D0,0.000072D0,0.001333D0,4*0D0,0.000001D0,
713 &0.000184D0,0D0,0.003108D0,0.000015D0,0.000003D0,2*0D0,0.995284D0,
714 &66*0D0,0.000014D0,0.082234D0,2*0D0,0.000013D0,0.003746D0,0D0,
715 &0.913992D0,18*0D0,3*0.215119D0,0.214724D0,2*0D0,0.06996D0,
716 &0.069959D0,0D0,2*1D0,2*0.08D0,0.76D0,0.08D0,2*0.105D0,0.04D0,
717 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,0.988D0,0.012D0,
718 &0.998739D0,0.00079D0,0.00038D0,0.000046D0,0.000045D0,2*0.34725D0,
719 &0.144D0,0.104D0,0.0245D0,2*0.01225D0,0.0028D0,0.0057D0,0.2112D0,
720 &0.1256D0,2*0.1939D0,2*0.1359D0,0.002D0,0.001D0,0.0006D0,
721 &0.999877D0,0.000123D0,0.99955D0,0.00045D0,2*0.34725D0,0.144D0,
722 &0.104D0,0.049D0,0.0028D0,0.0057D0,0.3923D0,0.321D0,0.2317D0,
723 &0.0478D0,0.0049D0,0.0013D0,0.0003D0,0.0007D0,0.89D0,0.08693D0,
724 &0.0221D0,0.00083D0,2*0.00007D0,0.564D0,0.282D0,0.072D0,0.028D0,
725 &0.023D0,2*0.0115D0,0.005D0,0.003D0,0.6861D0,0.3139D0,2*0.5D0,
726 &0.665D0,0.333D0,0.002D0,0.333D0,0.166D0,0.168D0,0.084D0,0.087D0,
727 &0.043D0,0.059D0,2*0.029D0,0.002D0,0.6352D0,0.2116D0,0.0559D0,
728 &0.0173D0,0.0482D0,0.0318D0,0.666D0,0.333D0,0.001D0,0.332D0,
729 &0.166D0,0.168D0,0.084D0,0.086D0,0.043D0,0.059D0,2*0.029D0,
730 &2*0.002D0,0.437D0,0.208D0,0.302D0,0.0302D0,0.0212D0,0.0016D0/
731 DATA (BRAT(I) ,I= 656, 831)/0.48947D0,0.34D0,3*0.043D0,0.027D0,
732 &0.0126D0,0.0013D0,0.0003D0,0.00025D0,0.00008D0,0.444D0,2*0.222D0,
733 &0.104D0,2*0.004D0,0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,
734 &0.07D0,0.065D0,2*0.005D0,2*0.011D0,5*0.001D0,0.026D0,0.019D0,
735 &0.066D0,0.041D0,0.045D0,0.076D0,0.0073D0,2*0.0047D0,0.026D0,
736 &0.001D0,0.0006D0,0.0066D0,0.005D0,2*0.003D0,2*0.0006D0,2*0.001D0,
737 &0.006D0,0.005D0,0.012D0,0.0057D0,0.067D0,0.008D0,0.0022D0,
738 &0.027D0,0.004D0,0.019D0,0.012D0,0.002D0,0.009D0,0.0218D0,0.001D0,
739 &0.022D0,0.087D0,0.001D0,0.0019D0,0.0015D0,0.0028D0,0.683D0,
740 &0.306D0,0.011D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,
741 &0.04D0,0.034D0,0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.034D0,
742 &0.027D0,2*0.002D0,2*0.004D0,2*0.002D0,0.0365D0,0.045D0,0.073D0,
743 &0.062D0,3*0.021D0,0.0061D0,0.015D0,0.025D0,0.0088D0,0.074D0,
744 &0.0109D0,0.0041D0,0.002D0,0.0035D0,0.0011D0,0.001D0,0.0027D0,
745 &2*0.0016D0,0.0018D0,0.011D0,0.0063D0,0.0052D0,0.018D0,0.016D0,
746 &0.0034D0,0.0036D0,0.0009D0,0.0006D0,0.015D0,0.0923D0,0.018D0,
747 &0.022D0,0.0077D0,0.009D0,0.0075D0,0.024D0,0.0085D0,0.067D0,
748 &0.0511D0,0.017D0,0.0004D0,0.0028D0,0.619D0,0.381D0,0.3D0,0.15D0,
749 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.01D0,2*0.02D0,0.03D0,
750 &2*0.005D0,2*0.02D0,0.03D0,2*0.005D0,0.015D0,0.037D0,0.028D0/
751 DATA (BRAT(I) ,I= 832, 997)/0.079D0,0.095D0,0.052D0,0.0078D0,
752 &4*0.001D0,0.028D0,0.033D0,0.026D0,0.05D0,0.01D0,4*0.005D0,0.25D0,
753 &0.0952D0,0.94D0,0.06D0,2*0.4D0,2*0.1D0,1D0,0.0602D0,0.0601D0,
754 &0.8797D0,0.135D0,0.865D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
755 &0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,
756 &0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,
757 &0.0185D0,0.0135D0,0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,
758 &0.0019D0,0.0025D0,0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,
759 &1D0,0.3D0,0.15D0,0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,
760 &0.02D0,0.055D0,2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,
761 &2*0.005D0,0.008D0,0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,
762 &0.0055D0,0.0042D0,0.009D0,0.018D0,0.015D0,0.0185D0,0.0135D0,
763 &0.025D0,0.0004D0,0.0007D0,0.0008D0,0.0014D0,0.0019D0,0.0025D0,
764 &0.4291D0,0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,1D0,0.3D0,0.15D0,
765 &0.16D0,0.08D0,0.13D0,0.06D0,0.08D0,0.04D0,0.02D0,0.055D0,
766 &2*0.005D0,0.008D0,0.012D0,0.02D0,0.055D0,2*0.005D0,0.008D0,
767 &0.012D0,0.01D0,0.03D0,0.0035D0,0.011D0,0.0055D0,0.0042D0,0.009D0,
768 &0.018D0,0.015D0,0.0185D0,0.0135D0,0.025D0,2*0.0002D0,0.0007D0,
769 &2*0.0004D0,0.0014D0,0.001D0,0.0009D0,0.0025D0,0.4291D0,0.08D0,
770 &0.07D0,0.02D0,0.015D0,0.005D0,1D0,2*0.3D0,2*0.2D0,0.047D0/
771 DATA (BRAT(I) ,I= 998,1188)/0.122D0,0.006D0,0.012D0,0.035D0,
772 &0.012D0,0.035D0,0.003D0,0.007D0,0.15D0,0.037D0,0.008D0,0.002D0,
773 &0.05D0,0.015D0,0.003D0,0.001D0,0.014D0,0.042D0,0.014D0,0.042D0,
774 &0.24D0,0.065D0,0.012D0,0.003D0,0.001D0,0.002D0,0.001D0,0.002D0,
775 &0.014D0,0.003D0,1D0,2*0.3D0,2*0.2D0,1D0,0.0252D0,0.0248D0,
776 &0.0267D0,0.015D0,0.045D0,0.015D0,0.045D0,0.7743D0,0.029D0,0.22D0,
777 &0.78D0,1D0,0.331D0,0.663D0,0.006D0,0.663D0,0.331D0,0.006D0,1D0,
778 &0.999D0,0.001D0,0.88D0,2*0.06D0,0.639D0,0.358D0,0.002D0,0.001D0,
779 &1D0,0.88D0,2*0.06D0,0.516D0,0.483D0,0.001D0,0.88D0,2*0.06D0,
780 &0.9988D0,0.0001D0,0.0006D0,0.0004D0,0.0001D0,0.667D0,0.333D0,
781 &0.9954D0,0.0011D0,0.0035D0,0.333D0,0.667D0,0.676D0,0.234D0,
782 &0.085D0,0.005D0,2*1D0,0.018D0,2*0.005D0,0.003D0,0.002D0,
783 &2*0.006D0,0.018D0,2*0.005D0,0.003D0,0.002D0,2*0.006D0,0.0066D0,
784 &0.025D0,0.016D0,0.0088D0,2*0.005D0,0.0058D0,0.005D0,0.0055D0,
785 &4*0.004D0,2*0.002D0,2*0.004D0,0.003D0,0.002D0,2*0.003D0,
786 &3*0.002D0,2*0.001D0,0.002D0,2*0.001D0,2*0.002D0,0.0013D0,
787 &0.0018D0,5*0.001D0,4*0.003D0,2*0.005D0,2*0.002D0,2*0.001D0,
788 &2*0.002D0,2*0.001D0,0.2432D0,0.057D0,2*0.035D0,0.15D0,2*0.075D0,
789 &0.03D0,2*0.015D0,2*0.08D0,0.76D0,0.08D0,4*1D0,2*0.08D0,0.76D0,
790 &0.08D0,1D0,2*0.5D0,1D0,2*0.5D0,2*0.08D0,0.76D0,0.08D0,1D0/
791 DATA (BRAT(I) ,I=1189,1381)/2*0.08D0,0.76D0,3*0.08D0,0.76D0,
792 &3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,3*0.08D0,0.76D0,
793 &3*0.08D0,0.76D0,0.08D0,2*1D0,2*0.105D0,0.04D0,0.0077D0,0.02D0,
794 &0.0235D0,0.0285D0,0.0435D0,0.0011D0,0.0022D0,0.0044D0,0.4291D0,
795 &0.08D0,0.07D0,0.02D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
796 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,
797 &0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,0.04D0,
798 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,0.04D0,
799 &0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,4*1D0,2*0.105D0,
800 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,1D0,2*0.105D0,
801 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
802 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
803 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,2*0.105D0,
804 &0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,0.015D0,0.005D0,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 DATA (BRAT(I) ,I=1382,1582)/0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
812 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
813 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
814 &0.015D0,0.005D0,2*0.105D0,0.04D0,0.5D0,0.08D0,0.14D0,0.01D0,
815 &0.015D0,0.005D0,2*0.105D0,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,4*1D0,0.52D0,0.26D0,0.11D0,2*0.055D0,0.333D0,
820 &0.334D0,0.333D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,
821 &0.11D0,0.667D0,0.333D0,0.28D0,0.14D0,0.313D0,0.157D0,0.11D0,
822 &0.36D0,0.18D0,0.03D0,2*0.015D0,2*0.2D0,4*0.25D0,0.667D0,0.333D0,
823 &0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.007D0,
824 &0.993D0,1D0,0.667D0,0.333D0,0.667D0,0.333D0,0.667D0,0.333D0,
825 &0.667D0,0.333D0,8*0.5D0,0.02D0,0.98D0,1D0,4*0.5D0,3*0.146D0,
826 &3*0.05D0,0.15D0,2*0.05D0,4*0.024D0,0.066D0,0.667D0,0.333D0,
827 &0.667D0,0.333D0,4*0.25D0,0.667D0,0.333D0,0.667D0,0.333D0,2*0.5D0,
828 &0.273D0,0.727D0,0.667D0,0.333D0,0.667D0,0.333D0,4*0.5D0,0.35D0,
829 &0.65D0,2*0.0083D0,0.1866D0,0.324D0,0.184D0,0.027D0,0.001D0,
830 &0.093D0,0.087D0,0.078D0,0.0028D0,3*0.014D0,0.008D0,0.024D0/
831 DATA (BRAT(I) ,I=1583,4150)/0.008D0,0.024D0,0.425D0,0.02D0,
832 &0.185D0,0.088D0,0.043D0,0.067D0,0.066D0,2404*0D0,0.024396D0,
833 &0.045285D0,0.83119D0,2*0D0,0.000349D0,0.09878D0,0D0,0.019884D0,
834 &0.02341D0,0.362776D0,0.550787D0,2*0D0,0.000152D0,0.042991D0,
835 &0.013695D0,0.025421D0,0.466595D0,2*0D0,0.000196D0,0.055451D0,
836 &0.438642D0,0.445781D0,0D0,0.554219D0,4*0.00335D0,0.522257D0,
837 &0.464343D0,6*0D0,1D0,6*0D0,1D0,4*0.013853D0,0.562703D0,
838 &0.376702D0,0.00518D0,4*0.006254D0,0.974985D0,7*0D0,4*0.148299D0,
839 &0.015351D0,0D0,0.182109D0,0.167099D0,0.042247D0,0.850973D0,
840 &0.005411D0,0.045025D0,0.098591D0,0.849898D0,0.021617D0,
841 &0.030018D0,0.098466D0,0.294448D0,0.10945D0,0.596102D0,0.389906D0,
842 &0.610094D0,3*0.0633D0,0.063299D0,0.063295D0,0.056281D0,2*0D0,
843 &6*0.020495D0,2*0D0,0.327919D0,0.04099D0,0.045236D0,0.090112D0,
844 &0.19874D0,0.010204D0,0.000003D0,0.010205D0,0.198356D0,0.000151D0,
845 &0.000006D0,0.000367D0,0.081967D0,0.19874D0,0.010204D0,0.000003D0,
846 &0.010205D0,0.198356D0,0.000151D0,0.000006D0,0.000367D0,
847 &0.081967D0,4*0D0,0.198776D0,0.010206D0,0.000003D0,0.010207D0,
848 &0.19839D0,0.000151D0,0.000006D0,0.000367D0,0.081893D0,0.198776D0,
849 &0.010206D0,0.000003D0,0.010207D0,0.19839D0,0.000151D0,0.000006D0,
850 &0.000367D0,0.081893D0,4*0D0,0.199344D0,0.010234D0,0.000003D0/
851 DATA (BRAT(I) ,I=4151,4281)/0.010236D0,0.198928D0,0.000149D0,
852 &0.000006D0,0.000368D0,0.080733D0,0.199344D0,0.010234D0,
853 &0.000003D0,0.010236D0,0.198928D0,0.000149D0,0.000006D0,
854 &0.000368D0,0.080733D0,4*0D0,0.184738D0,0.104588D0,0.184738D0,
855 &0.104587D0,0.184731D0,0.09582D0,0.022902D0,0.008429D0,0.015602D0,
856 &0.022902D0,0.008429D0,0.015602D0,0.022902D0,0.008429D0,
857 &0.015602D0,0.28959D0,0.01487D0,0.000008D0,0.01487D0,0.289061D0,
858 &0.000492D0,0.000009D0,0.000536D0,0.27911D0,2*0.037151D0,
859 &0.03715D0,0.090266D0,2*0.001805D0,0.090266D0,0.001805D0,
860 &0.812263D0,0.00179D0,0.090428D0,0.001809D0,0.001808D0,0.090428D0,
861 &0.001808D0,0.81372D0,0D0,6*1D0,0.095602D0,2*0.338272D0,
862 &0.156896D0,0.019193D0,0.017993D0,0.001168D0,0.001462D0,
863 &0.009608D0,0.003306D0,0.002132D0,0.003127D0,0.002132D0,
864 &0.003127D0,0.00213D0,3*0D0,0.001411D0,0.00045D0,0.001411D0,
865 &0.00045D0,0.001411D0,0.00045D0,2*0D0,0.097996D0,0.399787D0,
866 &0.262464D0,0.185427D0,0.022683D0,0.007648D0,0.004259D0,
867 &0.005925D0,0.000304D0,2*0D0,0.000304D0,0.005914D0,0.000002D0,
868 &2*0D0,0.000011D0,0.001258D0,5*0D0,3*0.002005D0,0D0,0.272178D0,
869 &0.022112D0,0.255165D0,0.015534D0,2*0.108965D0,0.031557D0,
870 &0.005562D0,0.044965D0,0.004674D0,0.007637D0,0.020597D0/
871 DATA (BRAT(I) ,I=4282,8000)/0.007636D0,0.020595D0,0.007616D0,
872 &3*0D0,0.017298D0,0.004782D0,0.017298D0,0.004782D0,0.017297D0,
873 &0.004782D0,2*0D0,0.055332D0,2*0.319757D0,0.121576D0,2*0.001556D0,
874 &4*0D0,0.0277D0,0.021481D0,0.027699D0,0.021477D0,0.027658D0,3*0D0,
875 &0.006071D0,0.01208D0,0.006071D0,0.01208D0,0.006069D0,0.01208D0,
876 &2*0D0,0.035891D0,0.209476D0,0.129084D0,0.286631D0,0.10742D0,
877 &0.109486D0,4*0D0,0.035282D0,0.001812D0,2*0D0,0.001812D0,
878 &0.035215D0,0.000021D0,0D0,0.000001D0,0.000065D0,0.011965D0,5*0D0,
879 &2*0.011947D0,0.011946D0,0D0,
880 &649*0.D0,
881C....UED
882 &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0,
883 &0.001D0,0.999D0,0.001D0,0.999D0,0.001D0,0.999D0,
884 &0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,0.33D0,0.66D0,0.01D0,
885 &0.33D0,0.66D0,0.01D0,0.98D0,0.D0,0.02D0,0.33D0,0.66D0,0.01D0,
886 &9*1.D0,
887 &24*0.0416667,
888 &1.,
889 &3*0.D0,6*0.08333D0,
890 &3*0.D0,6*0.08333D0,
891 &6*0.166667D0,
892 &2912*0.D0/
893 DATA (KFDP(I,1),I= 1, 377)/21,22,23,4*-24,25,21,22,23,4*24,25,
894 &21,22,23,4*-24,25,21,22,23,4*24,25,21,22,23,4*-24,25,21,22,23,
895 &4*24,25,37,1000022,1000023,1000025,1000035,1000021,1000039,21,22,
896 &23,4*-24,25,2*-37,21,22,23,4*24,25,2*37,22,23,-24,25,23,24,-12,
897 &22,23,-24,25,23,24,-12,-14,48*16,22,23,-24,25,23,24,22,23,-24,25,
898 &-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,
899 &3,4,5,6,7,8,11,12,13,14,15,16,17,18,4*-1,4*-3,4*-5,4*-7,-11,-13,
900 &-15,-17,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,1000022,
901 &2*1000023,3*1000025,4*1000035,2*1000024,2*1000037,1000001,
902 &2000001,1000001,-1000001,1000002,2000002,1000002,-1000002,
903 &1000003,2000003,1000003,-1000003,1000004,2000004,1000004,
904 &-1000004,1000005,2000005,1000005,-1000005,1000006,2000006,
905 &1000006,-1000006,1000011,2000011,1000011,-1000011,1000012,
906 &2000012,1000012,-1000012,1000013,2000013,1000013,-1000013,
907 &1000014,2000014,1000014,-1000014,1000015,2000015,1000015,
908 &-1000015,1000016,2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,12,
909 &13,14,15,16,17,18,24,37,2*23,25,35,4*-1,4*-3,4*-5,4*-7,-11,-13,
910 &-15,-17,3*24,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,24,23,25,24,
911 &37,23,25,36,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
912 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002/
913 DATA (KFDP(I,1),I= 378, 580)/1000002,-1000002,1000003,2000003,
914 &1000003,-1000003,1000004,2000004,1000004,-1000004,1000005,
915 &2000005,1000005,-1000005,1000006,2000006,1000006,-1000006,
916 &1000011,2000011,1000011,-1000011,1000012,2000012,1000012,
917 &-1000012,1000013,2000013,1000013,-1000013,1000014,2000014,
918 &1000014,-1000014,1000015,2000015,1000015,-1000015,1000016,
919 &2000016,1000016,-1000016,1,2,3,4,5,6,7,8,11,13,15,17,21,2*22,23,
920 &24,23,25,24,37,1000022,2*1000023,3*1000025,4*1000035,2*1000024,
921 &2*1000037,1000001,2000001,1000001,-1000001,1000002,2000002,
922 &1000002,-1000002,1000003,2000003,1000003,-1000003,1000004,
923 &2000004,1000004,-1000004,1000005,2000005,1000005,-1000005,
924 &1000006,2000006,1000006,-1000006,1000011,2000011,1000011,
925 &-1000011,1000012,2000012,1000012,-1000012,1000013,2000013,
926 &1000013,-1000013,1000014,2000014,1000014,-1000014,1000015,
927 &2000015,1000015,-1000015,1000016,2000016,1000016,-1000016,-1,-3,
928 &-5,-7,-11,-13,-15,-17,24,2*1000022,2*1000023,2*1000025,2*1000035,
929 &1000006,2000006,1000006,2000006,-1000001,-1000003,-1000011,
930 &-1000013,-1000015,-2000015,1,2,3,4,5,6,11,13,15,2,82,-11,-13,2*2,
931 &-12,-14,-16,2*-2,2*-4,-2,-4,2*22,211,111,221,13,11,213,-213,221,
932 &223,321,130,310,111,331,111,211,-12,12,-14,14,211,111,22,-13,-11/
933 DATA (KFDP(I,1),I= 581, 992)/2*211,213,113,221,223,321,211,331,
934 &22,111,211,2*22,211,22,111,211,22,211,221,111,11,211,111,2*211,
935 &321,130,310,221,111,211,111,130,310,321,2*311,321,311,323,313,
936 &323,313,321,3*311,-13,3*211,12,14,311,2*321,311,321,313,323,313,
937 &323,311,4*321,211,111,3*22,111,321,130,-213,113,213,211,22,111,
938 &11,13,211,321,130,310,221,211,111,11*-11,11*-13,-311,-313,-311,
939 &-313,-20313,2*-311,-313,-311,-313,2*111,2*221,2*331,2*113,2*223,
940 &2*333,-311,-313,2*-321,211,-311,-321,333,-311,-313,-321,211,
941 &2*-321,2*-311,-321,211,113,421,2*411,421,411,423,413,423,413,421,
942 &411,8*-11,8*-13,-321,-323,-321,-323,-311,2*-313,-311,-313,2*-311,
943 &-321,-10323,-321,-323,-321,-311,2*-313,211,111,333,3*-321,-311,
944 &-313,-321,-313,310,333,211,2*-321,-311,-313,-311,211,-321,3*-311,
945 &211,113,321,2*421,411,421,413,423,413,423,411,421,-15,5*-11,
946 &5*-13,221,331,333,221,331,333,10221,211,213,211,213,321,323,321,
947 &323,2212,221,331,333,221,2*2,2*431,421,411,423,413,82,11,13,82,
948 &443,82,6*12,6*14,2*16,3*-411,3*-413,2*-411,2*-413,2*441,2*443,
949 &2*20443,2*2,2*4,2,4,511,521,511,523,513,523,513,521,511,6*12,
950 &6*14,2*16,3*-421,3*-423,2*-421,2*-423,2*441,2*443,2*20443,2*2,
951 &2*4,2,4,521,511,521,513,523,513,523,511,521,6*12,6*14,2*16,
952 &3*-431,3*-433,2*-431,2*-433,3*441,3*443,3*20443,2*2,2*4,2,4,531/
953 DATA (KFDP(I,1),I= 993,1402)/521,511,523,513,16,2*4,2*12,2*14,
954 &2*16,4*2,4*4,2*-11,2*-13,2*-1,2*-3,2*-11,2*-13,2*-1,541,511,521,
955 &513,523,21,11,13,15,1,2,3,4,21,22,553,21,2112,2212,2*2112,2212,
956 &2112,2*2212,2112,-12,3122,3212,3112,2212,2*2112,-12,2*3122,3222,
957 &3112,2212,2112,2212,3122,3222,3212,3122,3112,-12,-14,-12,3322,
958 &3312,2*3122,3212,3322,3312,3122,3322,3312,-12,2*4122,7*-11,7*-13,
959 &2*2224,2*2212,2*2214,2*3122,2*3212,2*3214,5*3222,4*3224,2*3322,
960 &3324,2*2224,7*2212,5*2214,2*2112,2*2114,2*3122,2*3212,2*3214,
961 &2*3222,2*3224,4*2,3,2*2,1,2*2,-11,-13,2*2,4*4122,-11,-13,2*2,
962 &3*4132,3*4232,-11,-13,2*2,4332,-11,-13,2*2,-11,-13,2*2,-11,-13,
963 &2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,-11,-13,2*2,2*5122,-12,
964 &-14,-16,5*4122,441,443,20443,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,
965 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,4*5122,-12,-14,-16,2*-2,
966 &2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,2*5132,2*5232,-12,-14,-16,
967 &2*-2,2*-4,-2,-4,5332,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,
968 &2*-2,2*-4,-2,-4,-12,-14,-16,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,-12,-14,-16,2*-2,2*-4,-2,
970 &-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,-14,-16,2*-2,2*-4,-2,-4,-12,
971 &-14,-16,2*-2,2*-4,-2,-4,-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 DATA (KFDP(I,1),I=1403,1713)/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,221,223,221,
976 &223,211,111,321,130,310,213,113,-213,321,311,321,311,323,313,
977 &2*311,321,311,321,313,323,321,211,111,321,130,310,2*211,313,-313,
978 &323,-323,421,411,423,413,411,421,413,423,411,421,423,413,443,
979 &2*82,521,511,523,513,511,521,513,523,521,511,523,513,511,521,513,
980 &523,553,2*21,213,-213,113,213,10211,10111,-10211,2*221,213,2*113,
981 &-213,2*321,2*311,113,323,2*313,323,313,-313,323,-323,423,2*413,
982 &2*423,413,443,82,523,2*513,2*523,2*513,523,553,21,11,13,82,4*443,
983 &10441,20443,445,441,11,13,15,1,2,3,4,21,22,2*553,10551,20553,555,
984 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
985 &1000002,2000002,1000002,2000002,1000021,3*-12,3*-14,3*-16,12,11,
986 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
987 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000001,
988 &2000001,1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,
989 &1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
990 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
991 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,
992 &1000039,1000024,1000037,1000022,1000023,1000025,1000035,1000003/
993 DATA (KFDP(I,1),I=1714,1984)/2000003,1000003,2000003,1000021,
994 &3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,-1000037,1000022,
995 &1000023,1000025,1000035,1000006,2000006,1000006,2000006,1000021,
996 &3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,14,13,16,15,16,
997 &15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,1000022,1000023,
998 &1000025,1000035,1000005,2000005,1000005,2000005,1000021,1000022,
999 &1000016,-1000015,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1000 &-1000037,1000022,1000023,1000025,1000035,1000012,2000012,1000012,
1001 &2*12,2*14,2*16,3*-14,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
1002 &1000037,1000022,1000023,1000025,1000035,1000011,2000011,1000011,
1003 &2000011,3*-13,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
1004 &1000022,1000023,1000025,1000035,1000014,2000014,1000014,2000014,
1005 &2*12,2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,1000024,
1006 &1000037,1000022,1000023,1000025,1000035,1000013,2000013,1000013,
1007 &2000013,3*-11,3*-15,3*-1,3*-3,3*-5,1000039,-1000024,-1000037,
1008 &1000022,1000023,1000025,1000035,1000016,2000016,1000016,2000016,
1009 &2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,1000039,1000024,
1010 &1000037,1000022,1000023,1000025,1000035,1000015,2000015,1000015,
1011 &2000015,3*-11,3*-13,3*-1,3*-3,3*-5,1000039,1000001,-1000001,
1012 &2000001,-2000001,1000002,-1000002,2000002,-2000002,1000003/
1013 DATA (KFDP(I,1),I=1985,2321)/-1000003,2000003,-2000003,1000004,
1014 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1015 &1000006,-1000006,2000006,-2000006,6*1000022,6*1000023,6*1000025,
1016 &6*1000035,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1017 &1000037,-1000037,1000037,-1000037,1000037,-1000037,-12,12,-11,11,
1018 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,
1019 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,
1020 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,
1021 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,
1022 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,
1023 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,
1024 &-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,4,1,-12,12,-12,12,-12,12,
1025 &-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,14,-14,14,-14,14,
1026 &-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,12,-11,11,-12,12,
1027 &-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,
1028 &-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,14,-13,13,-14,14,
1029 &-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,
1030 &-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,16,-15,15,-16,16,
1031 &-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,
1032 &-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,-2,2,-2,2,-4,4,-4/
1033 DATA (KFDP(I,1),I=2322,2573)/4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1034 &16*1000022,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1035 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000037,
1036 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037,
1037 &1000037,-1000037,1000037,-1000037,1000024,-1000024,1000037,
1038 &-1000037,1000001,-1000001,2000001,-2000001,1000002,-1000002,
1039 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1040 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1041 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1042 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1043 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1044 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1045 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1046 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1047 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1048 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1049 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1050 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1051 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1052 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16/
1053 DATA (KFDP(I,1),I=2574,2892)/16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,
1054 &-4,4,-6,6,-6,6,-6,6,2*1000039,6*1000022,6*1000023,6*1000025,
1055 &6*1000035,1000022,1000023,1000025,1000035,1000002,2000002,
1056 &-1000001,-2000001,1000004,2000004,-1000003,-2000003,1000006,
1057 &2000006,-1000005,-2000005,1000012,2000012,-1000011,-2000011,
1058 &1000014,2000014,-1000013,-2000013,1000016,2000016,-1000015,
1059 &-2000015,2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1060 &-12,12,-11,-12,12,-11,-14,-13,-14,-13,-14,-13,-14,14,-13,-14,14,
1061 &-13,-14,14,-13,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,-16,-15,
1062 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,
1063 &-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-14,2*-13,14,
1064 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,
1065 &-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,2*-15,16,-16,2*-15,16,
1066 &-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,
1067 &-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,2,-1,3*2,-1,2*4,-3,
1068 &3*4,-3,2*6,5*1000039,16*1000022,16*1000023,1000024,-1000024,
1069 &1000024,-1000024,1000024,-1000024,1000024,-1000024,1000024,
1070 &-1000024,1000024,-1000024,1000037,-1000037,1000037,-1000037,
1071 &1000037,-1000037,1000037,-1000037,1000037,-1000037,1000037,
1072 &-1000037,1000024,-1000024,1000037,-1000037,1000001,-1000001/
1073 DATA (KFDP(I,1),I=2893,3182)/2000001,-2000001,1000002,-1000002,
1074 &2000002,-2000002,1000003,-1000003,2000003,-2000003,1000004,
1075 &-1000004,2000004,-2000004,1000005,-1000005,2000005,-2000005,
1076 &1000006,-1000006,2000006,-2000006,1000011,-1000011,2000011,
1077 &-2000011,1000012,-1000012,2000012,-2000012,1000013,-1000013,
1078 &2000013,-2000013,1000014,-1000014,2000014,-2000014,1000015,
1079 &-1000015,2000015,-2000015,1000016,-1000016,2000016,-2000016,
1080 &5*1000021,-12,12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,
1081 &14,-14,14,-14,14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,
1082 &16,-16,16,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1083 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,
1084 &12,-11,11,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1085 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,
1086 &14,-13,13,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1087 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,
1088 &16,-15,15,-2,2,-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,5*1000039,
1089 &16*1000022,16*1000023,16*1000025,1000024,-1000024,1000024,
1090 &-1000024,1000024,-1000024,1000024,-1000024,1000024,-1000024,
1091 &1000024,-1000024,1000037,-1000037,1000037,-1000037,1000037,
1092 &-1000037,1000037,-1000037,1000037,-1000037,1000037,-1000037/
1093 DATA (KFDP(I,1),I=3183,3459)/1000024,-1000024,1000037,-1000037,
1094 &1000001,-1000001,2000001,-2000001,1000002,-1000002,2000002,
1095 &-2000002,1000003,-1000003,2000003,-2000003,1000004,-1000004,
1096 &2000004,-2000004,1000005,-1000005,2000005,-2000005,1000006,
1097 &-1000006,2000006,-2000006,1000011,-1000011,2000011,-2000011,
1098 &1000012,-1000012,2000012,-2000012,1000013,-1000013,2000013,
1099 &-2000013,1000014,-1000014,2000014,-2000014,1000015,-1000015,
1100 &2000015,-2000015,1000016,-1000016,2000016,-2000016,5*1000021,-12,
1101 &12,-12,12,-12,12,-12,12,-12,12,-12,12,-14,14,-14,14,-14,14,-14,
1102 &14,-14,14,-14,14,-16,16,-16,16,-16,16,-16,16,-16,16,-16,16,-12,
1103 &12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,
1104 &11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-12,12,-11,11,-14,
1105 &14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,
1106 &13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-14,14,-13,13,-16,
1107 &16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,
1108 &15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-16,16,-15,15,-2,2,
1109 &-2,2,-2,2,-4,4,-4,4,-4,4,-6,6,-6,6,-6,6,2*1000039,15*1000024,
1110 &6*1000022,6*1000023,6*1000025,6*1000035,1000022,1000023,1000025,
1111 &1000035,1000002,2000002,-1000001,-2000001,1000004,2000004,
1112 &-1000003,-2000003,1000006,2000006,-1000005,-2000005,1000012/
1113 DATA (KFDP(I,1),I=3460,3782)/2000012,-1000011,-2000011,1000014,
1114 &2000014,-1000013,-2000013,1000016,2000016,-1000015,-2000015,
1115 &2*1000021,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,-12,12,-11,
1116 &-12,12,-11,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,-13,-14,14,
1117 &-13,-14,14,-13,-16,16,-15,-16,16,-15,-16,16,-15,-16,16,-15,-16,
1118 &16,-15,-16,16,-15,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1119 &2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,2*-11,12,-12,
1120 &2*-11,12,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,
1121 &2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-14,2*-13,14,-16,
1122 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,
1123 &2*-15,16,-16,2*-15,16,-16,2*-15,16,-16,2*-15,16,2,-1,2,-1,2*2,-1,
1124 &2,-1,3*2,-1,2*4,-3,3*4,-3,2*6,1000039,-1000024,-1000037,1000022,
1125 &1000023,1000025,1000035,4*1000001,1000002,2000002,1000002,
1126 &2000002,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,11,14,13,14,13,
1127 &14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,1000024,1000037,
1128 &1000022,1000023,1000025,1000035,4*1000002,1000001,2000001,
1129 &1000001,2000001,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,
1130 &-1000024,-1000037,1000022,1000023,1000025,1000035,4*1000003,
1131 &1000004,2000004,1000004,2000004,1000021,3*-12,3*-14,3*-16,12,11,
1132 &12,11,12,11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6/
1133 DATA (KFDP(I,1),I=3783,4156)/1000039,1000024,1000037,1000022,
1134 &1000023,1000025,1000035,4*1000004,1000003,2000003,1000003,
1135 &2000003,1000021,3*-11,3*-13,3*-15,2*-1,-3,1000039,-1000024,
1136 &-1000037,1000022,1000023,1000025,1000035,4*1000005,1000006,
1137 &2000006,1000006,2000006,1000021,3*-12,3*-14,3*-16,12,11,12,11,12,
1138 &11,14,13,14,13,14,13,16,15,16,15,16,15,2*-2,2*-4,2*-6,1000039,
1139 &1000024,1000037,1000022,1000023,1000025,1000035,4*1000006,
1140 &1000005,2000005,1000005,2000005,1000021,3*-11,3*-13,3*-15,2*-1,
1141 &-3,1000039,-1000024,-1000037,1000022,1000023,1000025,1000035,
1142 &4*1000011,1000012,2000012,1000012,2000012,2*12,2*14,2*16,3*-14,
1143 &3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,1000022,1000023,
1144 &1000025,1000035,4*1000013,1000014,2000014,1000014,2000014,2*12,
1145 &2*14,2*16,3*-12,3*-16,3*-2,3*-4,3*-6,1000039,-1000024,-1000037,
1146 &1000022,1000023,1000025,1000035,4*1000015,1000016,2000016,
1147 &1000016,2000016,2*12,2*14,2*16,3*-12,3*-14,3*-2,3*-4,3*-6,3,4,5,
1148 &6,11,13,15,21,2*4,2,4,24,-11,-13,-15,3,4,5,6,11,13,15,21,5,6,21,
1149 &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,
1150 &5,6,1,2,3,4,5,6,1,2,3,4,5,6,21,3100111,3200111,21,22,23,-24,21,
1151 &22,23,24,22,23,-24,23,24,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,18,
1152 &21,22,23,24,9*11,9*-11,11,-11,11,-11,9*13,9*-13,13,-13,13,-13,
1153 &9*15/
1154 DATA (KFDP(I,1),I=4157,8000)/9*-15,15,-15,15,-15,1,2,3,4,5,6,11,
1155 &12,9900012,13,14,9900014,15,16,9900016,3*-1,3*-3,3*-5,-11,-13,-15,
1156 &3*-11,2*-13,-15,24,3*-11,2*-13,-15,9900024,3*443,3*553,2*24,
1157 &2*3000211,2*22,2*23,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,16,17,
1158 &18,2*24,3*3000211,2*24,4*-1,4*-3,4*-5,4*-7,-11,-13,-15,-17,22,23,
1159 &22,23,24,3000211,24,3000211,22,23,1,2,3,4,5,6,7,8,11,12,13,14,15,
1160 &16,17,18,2*24,-24,23,2*22,24,-24,2*23,1,2,3,4,5,6,7,8,11,12,13,
1161 &14,15,16,17,18,2*22,23,2*24,23,22,2*24,23,4*-1,4*-3,4*-5,4*-7,
1162 &-11,-13,-15,-17,
1163 &649*0,
1164C...UED
1165 &5100023,5100022,5100023,5100022,5100023,5100022,
1166 &5100023,5100022,5100023,5100022,5100023,5100022,
1167 &5100023,-5100024,5100022,5100023,5100024,5100022,
1168 &5100023,-5100024,5100022,5100023,5100024,5100022,
1169 &5100023,-5100024,5100022,5100023,5100024,5100022,
1170 &9*5100022,
1171 &6100001,6100002,6100003,6100004,6100005,6100006,
1172 &5100001,5100002,5100003,5100004,5100005,5100006,
1173 &-6100001,-6100002,-6100003,-6100004,-6100005,-6100006,
1174 &-5100001,-5100002,-5100003,-5100004,-5100005,-5100006,
1175 &39,
1176 &6100011,6100013,6100015,
1177 &5100011,5100013,5100015,
1178 %5100012,5100014,5100016,
1179 &-6100011,-6100013,-6100015,
1180 &-5100011,-5100013,-5100015,
1181 %-5100012,-5100014,-5100016,
1182 &-5100011,-5100013,-5100015,
1183 &5100012,5100014,5100016,
1184 &2912*0/
1185 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,
1186 &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,
1187 &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,
1188 &13,11,13,-211,-213,-211,-213,-211,-213,-211,-213,2*-211,-321,
1189 &-323,-321,2*-323,3*-321,4*-211,-213,-211,-213,-211,-213,-211,
1190 &-213,-211,-213,3*-211,-213,4*-211,-323,-321,2*-211,2*-321,3*-211,
1191 &2*15,16,15,16,15,2*17,18,17,2*18,2*17,-1,-2,-3,-4,-5,-6,-7,-8,21,
1192 &-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,-1,-2,-3,-4,-5,-6,-7,-8,
1193 &-11,-12,-13,-14,-15,-16,-17,-18,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,
1194 &12,14,16,18,-1,-2,-3,-4,-5,-6,-7,-8,-11,-13,-15,-17,21,22,2*23,
1195 &-24,2*1000022,1000023,1000022,1000023,1000025,1000022,1000023,
1196 &1000025,1000035,-1000024,-1000037,-1000024,-1000037,-1000001,
1197 &2*-2000001,2000001,-1000002,2*-2000002,2000002,-1000003,
1198 &2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1199 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1200 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1201 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1202 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1203 &-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,-37,22,25,2*36,2,4,6,8,
1204 &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/
1205 DATA (KFDP(I,2),I= 340, 533)/-7,-8,-11,-13,-15,-17,21,22,2*23,
1206 &-24,2*25,-37,-24,3*36,2*1000022,1000023,1000022,1000023,1000025,
1207 &1000022,1000023,1000025,1000035,-1000024,-1000037,-1000024,
1208 &-1000037,-1000001,2*-2000001,2000001,-1000002,2*-2000002,2000002,
1209 &-1000003,2*-2000003,2000003,-1000004,2*-2000004,2000004,-1000005,
1210 &2*-2000005,2000005,-1000006,2*-2000006,2000006,-1000011,
1211 &2*-2000011,2000011,-1000012,2*-2000012,2000012,-1000013,
1212 &2*-2000013,2000013,-1000014,2*-2000014,2000014,-1000015,
1213 &2*-2000015,2000015,-1000016,2*-2000016,2000016,-1,-2,-3,-4,-5,-6,
1214 &-7,-8,-11,-13,-15,-17,21,22,2*23,-24,2*25,-37,-24,2*1000022,
1215 &1000023,1000022,1000023,1000025,1000022,1000023,1000025,1000035,
1216 &-1000024,-1000037,-1000024,-1000037,-1000001,2*-2000001,2000001,
1217 &-1000002,2*-2000002,2000002,-1000003,2*-2000003,2000003,-1000004,
1218 &2*-2000004,2000004,-1000005,2*-2000005,2000005,-1000006,
1219 &2*-2000006,2000006,-1000011,2*-2000011,2000011,-1000012,
1220 &2*-2000012,2000012,-1000013,2*-2000013,2000013,-1000014,
1221 &2*-2000014,2000014,-1000015,2*-2000015,2000015,-1000016,
1222 &2*-2000016,2000016,2,4,6,8,12,14,16,18,25,1000024,1000037,
1223 &1000024,1000037,1000024,1000037,1000024,1000037,2*-1000005,
1224 &2*-2000005,1000002,1000004,1000012,1000014,2*1000016,-3,-4,-5,-6/
1225 DATA (KFDP(I,2),I= 534, 938)/-7,-8,-13,-15,-17,11,-82,12,14,-1,
1226 &-3,11,13,15,1,4,3,4,1,3,22,11,-211,2*22,-13,-11,-211,211,111,211,
1227 &-321,130,310,22,2*111,-211,11,-11,13,-13,-211,111,22,14,12,111,
1228 &22,111,3*211,-311,22,211,22,111,-211,211,11,-211,13,22,-211,111,
1229 &-211,22,111,-11,-211,111,2*-211,-321,130,310,221,111,-211,111,
1230 &2*0,-211,111,22,-211,111,-211,111,-211,211,-213,113,223,221,14,
1231 &111,211,111,-11,-13,211,111,22,211,111,211,111,2*211,213,113,223,
1232 &221,22,-211,111,113,223,22,111,-321,310,211,111,2*-211,221,22,
1233 &-11,-13,-211,-321,130,310,221,-211,111,11*12,11*14,2*211,2*213,
1234 &211,20213,2*321,2*323,211,213,211,213,211,213,211,213,211,213,
1235 &211,213,3*211,213,211,2*321,8*211,2*113,3*211,111,22,211,111,211,
1236 &111,4*211,8*12,8*14,2*211,2*213,2*111,221,2*113,223,333,20213,
1237 &211,2*321,323,2*311,313,-211,111,113,2*211,321,2*211,311,321,310,
1238 &211,-211,4*211,321,4*211,113,2*211,-321,111,22,-211,111,-211,111,
1239 &-211,211,-211,211,16,5*12,5*14,3*211,3*213,211,2*111,2*113,
1240 &2*-311,2*-313,-2112,3*321,323,2*-1,22,111,321,311,321,311,-82,
1241 &-11,-13,-82,22,-82,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,
1242 &431,433,431,433,311,313,311,313,311,313,-1,-4,-3,-4,-1,-3,22,
1243 &-211,111,-211,111,-211,211,-211,211,6*-11,6*-13,2*-15,211,213,
1244 &20213,211,213,20213,431,433,431,433,321,323,321,323,321,323,-1/
1245 DATA (KFDP(I,2),I= 939,1352)/-4,-3,-4,-1,-3,22,211,111,211,111,
1246 &4*211,6*-11,6*-13,2*-15,211,213,20213,211,213,20213,431,433,431,
1247 &433,221,331,333,221,331,333,221,331,333,-1,-4,-3,-4,-1,-3,22,
1248 &-321,-311,-321,-311,-15,-3,-1,2*-11,2*-13,2*-15,-1,-4,-3,-4,-3,
1249 &-4,-1,-4,2*12,2*14,2,3,2,3,2*12,2*14,2,1,22,411,421,411,421,21,
1250 &-11,-13,-15,-1,-2,-3,-4,2*21,22,21,2*-211,111,22,111,211,22,211,
1251 &-211,11,2*-211,111,-211,111,22,11,22,111,-211,211,111,211,22,211,
1252 &111,211,-211,22,11,13,11,-211,2*111,2*22,111,211,-321,-211,111,
1253 &11,2*-211,7*12,7*14,-321,-323,-311,-313,-311,-313,211,213,211,
1254 &213,211,213,111,221,331,113,223,111,221,113,223,321,323,321,-211,
1255 &-213,111,221,331,113,223,333,10221,111,221,331,113,223,211,213,
1256 &211,213,321,323,321,323,321,323,311,313,311,313,2*-1,-3,-1,2203,
1257 &3201,3203,2203,2101,2103,12,14,-1,-3,2*111,2*211,12,14,-1,-3,22,
1258 &111,2*22,111,22,12,14,-1,-3,22,12,14,-1,-3,12,14,-1,-3,12,14,-1,
1259 &-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,12,14,-1,-3,2*-211,11,13,
1260 &15,-211,-213,-20213,-431,-433,3*3122,1,4,3,4,1,3,11,13,15,1,4,3,
1261 &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,
1262 &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,
1263 &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,
1264 &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/
1265 DATA (KFDP(I,2),I=1353,1815)/11,13,15,1,4,3,4,1,3,11,13,15,1,4,3,
1266 &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,
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 &2*111,2*211,-211,111,-321,130,310,-211,111,211,-211,111,-213,113,
1270 &-211,111,223,211,111,213,113,211,111,223,-211,111,-321,130,310,
1271 &2*-211,-311,311,-321,321,211,111,211,111,-211,111,-211,111,311,
1272 &2*321,311,22,2*-82,-211,111,-211,111,211,111,211,111,-321,-311,
1273 &-321,-311,411,421,411,421,22,2*21,-211,2*211,111,-211,111,2*211,
1274 &111,-211,211,111,211,-321,2*-311,-321,22,-211,111,211,111,-311,
1275 &311,-321,321,211,111,-211,111,321,311,22,-82,-211,111,211,111,
1276 &-321,-311,411,421,22,21,-11,-13,-82,211,111,221,111,4*22,-11,-13,
1277 &-15,-1,-2,-3,-4,2*21,211,111,3*22,1,2*2,4*1,2*-24,2*-37,2*1,3,5,
1278 &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,
1279 &-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,
1280 &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,
1281 &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,
1282 &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,
1283 &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,
1284 &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/
1285 DATA (KFDP(I,2),I=1816,2317)/11,13,11,13,15,11,13,15,1,3,5,1,3,5,
1286 &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,
1287 &13,2*14,4*13,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1288 &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,
1289 &5,1,3,5,15,2*16,4*15,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1290 &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,
1291 &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,
1292 &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,
1293 &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,
1294 &-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,
1295 &-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,
1296 &-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,
1297 &-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,
1298 &-3,3,-1,1,-1,1,-3,3,22,23,25,35,36,-1,-3,-13,13,-13,13,-13,13,
1299 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1300 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1301 &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,
1302 &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,
1303 &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,
1304 &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/
1305 DATA (KFDP(I,2),I=2318,2770)/3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,22,
1306 &23,25,35,36,22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,-24,24,11,
1307 &-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,-15,1,-1,3,
1308 &-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,-4,4,-5,5,-5,
1309 &5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13,13,-14,14,-14,
1310 &14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,
1311 &-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,
1312 &-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,
1313 &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,
1314 &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,
1315 &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,
1316 &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,
1317 &3,-1,1,-1,1,-3,3,-1,1,-1,1,-3,3,24,37,24,-11,-13,-15,-1,-3,24,
1318 &-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,4*37,
1319 &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,
1320 &-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,16,2*-15,16,-15,
1321 &6*-11,-15,16,2*-15,16,2*-15,16,-15,6*-11,6*-13,-1,-2,-1,2,-1,-2,
1322 &-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,
1323 &-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1324 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1/
1325 DATA (KFDP(I,2),I=2771,3221)/2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,
1326 &-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,
1327 &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,
1328 &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,
1329 &25,35,36,-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,
1330 &-13,15,-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,
1331 &-4,4,-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,
1332 &-13,13,-14,14,-14,14,-15,15,-15,15,-16,16,-16,16,1,3,5,2,4,-13,
1333 &13,-13,13,-13,13,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,-15,
1334 &15,-15,15,-15,15,-11,11,-11,11,-11,11,-13,13,-13,13,-13,13,-1,1,
1335 &-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,
1336 &-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,
1337 &-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,
1338 &-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,
1339 &-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,
1340 &22,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,22,23,11,13,15,12,14,
1341 &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,
1342 &-24,24,11,-11,13,-13,15,-15,1,-1,3,-3,-24,24,11,-11,13,-13,15,
1343 &-15,1,-1,3,-3,-37,37,-37,37,-1,1,-1,1,-2,2,-2,2,-3,3,-3,3,-4,4,
1344 &-4,4,-5,5,-5,5,-6,6,-6,6,-11,11,-11,11,-12,12,-12,12,-13,13,-13/
1345 DATA (KFDP(I,2),I=3222,3669)/13,-14,14,-14,14,-15,15,-15,15,-16,
1346 &16,-16,16,1,3,5,2,4,-13,13,-13,13,-13,13,-15,15,-15,15,-15,15,
1347 &-11,11,-11,11,-11,11,-15,15,-15,15,-15,15,-11,11,-11,11,-11,11,
1348 &-13,13,-13,13,-13,13,-1,1,-2,2,-1,1,-2,2,-1,1,-2,2,-3,3,-4,4,-3,
1349 &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,
1350 &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,
1351 &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,
1352 &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,
1353 &1,-1,1,-3,3,24,37,23,11,13,15,12,14,16,1,3,5,2,4,25,35,36,24,-11,
1354 &-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,-13,-15,-1,-3,24,-11,
1355 &-13,-15,-1,-3,4*37,2*-1,2*2,2*-3,2*4,2*-5,2*6,2*-11,2*12,2*-13,
1356 &2*14,2*-15,2*16,-1,-3,-13,14,2*-13,14,2*-13,14,-13,-15,16,2*-15,
1357 &16,2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-15,16,2*-15,16,
1358 &2*-15,16,-15,-11,12,2*-11,12,2*-11,12,-11,-13,14,2*-13,14,2*-13,
1359 &14,-13,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,
1360 &-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,
1361 &-1,-2,-1,2,-3,-4,-3,4,-3,-4,-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,
1362 &6,-5,-6,-5,6,-1,-2,-1,2,-1,-2,-1,2,-1,-2,-1,2,-3,-4,-3,4,-3,-4,
1363 &-3,4,-3,-4,-3,4,-5,-6,-5,6,-5,-6,-5,6,-5,-6,-5,6,2,-1,2,-1,2*4,
1364 &-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/
1365 DATA (KFDP(I,2),I=3670,4183)/2*-37,2*1,3,5,1,3,5,1,3,5,1,2,3,4,5,
1366 &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,
1367 &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,
1368 &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,
1369 &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,
1370 &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,
1371 &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,
1372 &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,
1373 &2*12,4*11,23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,
1374 &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,
1375 &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,
1376 &23,25,35,36,2*-24,2*-37,13,15,11,15,11,13,11,13,15,11,13,15,1,3,
1377 &5,1,3,5,1,3,5,-3,-4,-5,-6,-11,-13,-15,21,-1,-3,2*-5,5,12,14,16,
1378 &-3,-4,-5,-6,-11,-13,-15,21,-5,-6,21,-1,-2,-3,-4,-5,-6,-1,-2,-3,
1379 &-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,-4,-5,-6,21,-1,-2,-3,
1380 &-4,-5,-6,-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,3*21,3*1,4*2,1,2*11,
1381 &2*12,11,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,
1382 &21,22,23,-24,3*-1,3*-3,3*-5,3*1,3*3,3*5,-13,13,-15,15,3*-1,3*-3,
1383 &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,
1384 &-13,13,-1,-2,-3,-4,-5,-6,-11,-12,9900012,-13,-14,9900014,-15,-16/
1385 DATA (KFDP(I,2),I=4184,8000)/9900016,2,4,6,2,4,6,2,4,6,9900012,
1386 &9900014,9900016,-11,-13,-15,-13,2*-15,24,-11,-13,-15,-13,2*-15,
1387 &9900024,6*21,-24,-3000211,-24,-3000211,3000111,3000221,3000111,
1388 &3000221,2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,
1389 &-18,23,3000111,23,3000111,22,3000221,22,2,4,6,8,2,4,6,8,2,4,6,8,
1390 &2,4,6,8,12,14,16,18,2*3000111,2*3000221,-3000211,2*-24,-3000211,
1391 &2*23,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,-17,-18,-24,
1392 &-3000211,3000211,3000221,3000113,3000223,-3000213,3000213,
1393 &3000113,3000223,-1,-2,-3,-4,-5,-6,-7,-8,-11,-12,-13,-14,-15,-16,
1394 &-17,-18,24,3000211,24,3000111,3000221,3000211,3000213,3000113,
1395 &3000223,3000213,2,4,6,8,2,4,6,8,2,4,6,8,2,4,6,8,12,14,16,18,
1396 &649*0,
1397C...UED
1398 &1,1,2,2,3,3,4,4,5,5,6,6,
1399 &1,2,1,2,1,2,3,4,3,4,3,4,5,6,5,6,5,6,
1400 &11,13,15,12,11,14,13,16,15,
1401 &-1,-2,-3,-4,-5,-6,-1,-2,-3,-4,-5,-6,
1402 &1,2,3,4,5,6,1,2,3,4,5,6,
1403 &22,
1404 &-11,-13,-15,-11,-13,-15,-12,-14,-16,
1405 &11,13,15,11,13,15,12,14,16,
1406 &12,14,16,-11,-13,-15,
1407 &2912*0/
1408 DATA (KFDP(I,3),I= 1,1021)/81*0,14,6*0,2*16,2*0,6*111,310,130,
1409 &2*0,3*111,310,130,321,113,211,223,221,2*113,2*211,2*223,2*221,
1410 &2*113,221,2*113,2*213,-213,113,2*111,310,130,310,130,2*310,130,
1411 &402*0,4*3,4*4,1,4,3,2*2,0,-11,8*0,-211,5*0,2*111,211,-211,211,
1412 &-211,10*0,111,4*0,2*111,-211,-11,11,-13,22,111,3*0,22,3*0,111,
1413 &211,4*0,111,11*0,111,-211,6*0,-211,3*111,7*0,111,-211,5*0,2*221,
1414 &3*0,111,5*0,111,11*0,-311,-313,-311,-321,-313,-323,111,221,331,
1415 &113,223,-311,-313,-311,-321,-313,-323,111,221,331,113,223,22*0,
1416 &111,113,2*211,-211,-311,211,111,3*211,-211,7*211,7*0,111,-211,
1417 &111,-211,-321,-323,-311,-321,-313,-323,-211,-213,-321,-323,-311,
1418 &-321,-313,-323,-211,-213,22*0,111,113,-311,2*-211,211,-211,310,
1419 &-211,2*111,211,2*-211,-321,-211,2*211,-211,111,-211,2*211,6*0,
1420 &111,-211,111,-211,0,221,331,333,321,311,221,331,333,321,311,20*0,
1421 &3,13*0,-411,-413,-10413,-10411,-20413,-415,-411,-413,-10413,
1422 &-10411,-20413,-415,-411,-413,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1423 &111,-211,-421,-423,-10423,-10421,-20423,-425,-421,-423,-10423,
1424 &-10421,-20423,-425,-421,-423,16*0,-4,-1,-4,-3,2*-2,5*0,111,-211,
1425 &111,-211,-431,-433,-10433,-10431,-20433,-435,-431,-433,-10433,
1426 &-10431,-20433,-435,-431,-433,19*0,-4,-1,-4,-3,2*-2,8*0,441,443,
1427 &441,443,441,443,-4,-1,-4,-3,-4,-3,-4,-1,531,533,531,533,3,2,3,2/
1428 DATA (KFDP(I,3),I=1022,2223)/511,513,511,513,1,2,13*0,2*21,11*0,
1429 &2112,6*0,2212,12*0,2*3122,3212,10*0,3322,2*0,3122,3212,3214,2112,
1430 &2114,2212,2112,3122,3212,3214,2112,2114,2212,2112,52*0,3*3,1,6*0,
1431 &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,
1432 &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,
1433 &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,
1434 &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,
1435 &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,
1436 &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,
1437 &3,2*2,31*0,211,111,45*0,-211,2*111,-211,3*111,-211,111,211,30*0,
1438 &-211,111,13*0,2*21,-211,111,199*0,2*5,210*0,-1,-3,-5,-2,-4,-6,-1,
1439 &-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-1,-3,-5,-2,-4,-6,-2,2,-4,4,-6,
1440 &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,
1441 &-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,
1442 &-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,
1443 &-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,
1444 &-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,
1445 &-5,5,-5,5,5*0,11,12,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1446 &-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,
1447 &-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,-5,5,-5,1,-1,1,-1,3,-3,3/
1448 DATA (KFDP(I,3),I=2224,2783)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1449 &-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,
1450 &-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,
1451 &-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,
1452 &-5,5,-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,
1453 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1454 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1455 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1456 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1457 &-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,
1458 &-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,
1459 &-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,
1460 &-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,
1461 &-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,
1462 &4,0,12,14,16,2,4,0,12,14,16,2,4,28*0,2,4,12,-11,11,14,-13,13,16,
1463 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,11,14,13,16,15,12,-11,11,
1464 &14,-13,13,16,-15,15,12,11,14,13,16,15,12,11,14,13,16,15,2*2,1,-1,
1465 &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,
1466 &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,
1467 &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/
1468 DATA (KFDP(I,3),I=2784,3354)/2*4,3,-3,2*6,5,-5,2*2,1,-1,2*4,3,-3,
1469 &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,
1470 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,
1471 &-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,-2,2,-4,4,2*0,-12,12,
1472 &-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,11,-11,13,-13,15,-15,
1473 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1474 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,-1,1,-1,3,-3,3,-3,5,
1475 &-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,
1476 &-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,
1477 &-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,
1478 &-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,
1479 &-5,5,-3,3,-5,5,-5,5,-3,3,-5,5,-5,5,7*0,-11,-13,-15,-12,-14,-16,
1480 &-1,-3,-5,-2,-4,5*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,
1481 &-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,5*0,-12,12,-14,14,-16,16,
1482 &-2,2,-4,4,2*0,-12,12,-14,14,-16,16,-2,2,-4,4,52*0,-1,-3,-5,-2,-4,
1483 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,
1484 &11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,11,-11,13,-13,15,-15,1,
1485 &-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,
1486 &-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,
1487 &-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/
1488 DATA (KFDP(I,3),I=3355,8000)/-3,5,-5,5,-5,1,-1,1,-1,3,-3,3,-3,5,
1489 &-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,
1490 &-5,5,-3,3,-5,5,-5,5,3*0,-11,-13,-15,-12,-14,-16,-1,-3,-5,-2,-4,
1491 &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,
1492 &28*0,2,4,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,
1493 &-15,15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,
1494 &15,12,-11,11,14,-13,13,16,-15,15,12,-11,11,14,-13,13,16,-15,15,
1495 &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,
1496 &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,
1497 &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,
1498 &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,
1499 &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,
1500 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900014,2*9900016,2,4,6,2,4,
1501 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900016,2,4,6,2,4,
1502 &6,2,4,6,-2,-4,-6,-2,-4,-6,-2,-4,-6,2*9900012,2*9900014,3831*0/
1503 DATA (KFDP(I,4),I= 1,8000)/94*0,4*111,6*0,111,2*0,-211,0,-211,
1504 &3*0,111,2*-211,0,111,0,2*111,113,221,2*111,-213,-211,211,113,
1505 &6*111,310,2*130,402*0,13*81,41*0,-11,10*0,111,-211,4*0,111,62*0,
1506 &111,211,111,211,7*0,111,211,111,211,35*0,2*-211,2*111,211,111,
1507 &-211,2*211,2*-211,13*0,-211,111,-211,111,4*0,-211,111,-211,111,
1508 &34*0,111,-211,3*111,3*-211,2*111,3*-211,14*0,-321,-311,3*0,-321,
1509 &-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,
1510 &2*-5,67*0,-211,111,5*0,-211,111,52*0,2101,2103,2*2101,6*0,4*81,
1511 &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,
1512 &162*81,31*0,-211,111,6516*0/
1513 DATA (KFDP(I,5),I= 1,8000)/96*0,2*111,17*0,111,7*0,2*111,0,
1514 &3*111,0,111,597*0,-211,2*111,-211,111,-211,111,65*0,111,-211,
1515 &3*111,-211,111,7193*0/
1516
1517C...PYDAT4, with particle names (character strings).
1518 DATA (CHAF(I,1),I= 1, 202)/'d','u','s','c','b','t','b''','t''',
1519 &2*' ','e-','nu_e','mu-','nu_mu','tau-','nu_tau','tau''-',
1520 &'nu''_tau',2*' ','g','gamma','Z0','W+','h0',6*' ','Z''0','Z"0',
1521 &'W''+','H0','A0','H+',' ','Graviton',' ','R0','LQ_ue',38*' ',
1522 &'specflav','rndmflav','phasespa','c-hadron','b-hadron',2*' ',
1523 &'junction',' ','system','cluster','string','indep.','CMshower',
1524 &'SPHEaxis','THRUaxis','CLUSjet','CELLjet','table',' ','reggeon',
1525 &'pi0','rho0','a_20','K_L0','pi+','rho+','a_2+','eta','omega',
1526 &'f_2','K_S0','K0','K*0','K*_20','K+','K*+','K*_2+','eta''','phi',
1527 &'f''_2','D+','D*+','D*_2+','D0','D*0','D*_20','D_s+','D*_s+',
1528 &'D*_2s+','eta_c','J/psi','chi_2c','B0','B*0','B*_20','B+','B*+',
1529 &'B*_2+','B_s0','B*_s0','B*_2s0','B_c+','B*_c+','B*_2c+','eta_b',
1530 &'Upsilon','chi_2b','pomeron','dd_1','Delta-','ud_0','ud_1','n0',
1531 &'Delta0','uu_1','p+','Delta+','Delta++','sd_0','sd_1','Sigma-',
1532 &'Sigma*-','Lambda0','su_0','su_1','Sigma0','Sigma*0','Sigma+',
1533 &'Sigma*+','ss_1','Xi-','Xi*-','Xi0','Xi*0','Omega-','cd_0',
1534 &'cd_1','Sigma_c0','Sigma*_c0','Lambda_c+','Xi_c0','cu_0','cu_1',
1535 &'Sigma_c+','Sigma*_c+','Sigma_c++','Sigma*_c++','Xi_c+','cs_0',
1536 &'cs_1','Xi''_c0','Xi*_c0','Xi''_c+','Xi*_c+','Omega_c0',
1537 &'Omega*_c0','cc_1','Xi_cc+','Xi*_cc+','Xi_cc++','Xi*_cc++'/
1538 DATA (CHAF(I,1),I= 203, 332)/'Omega_cc+','Omega*_cc+',
1539 &'Omega*_ccc++','bd_0','bd_1','Sigma_b-','Sigma*_b-','Lambda_b0',
1540 &'Xi_b-','Xi_bc0','bu_0','bu_1','Sigma_b0','Sigma*_b0','Sigma_b+',
1541 &'Sigma*_b+','Xi_b0','Xi_bc+','bs_0','bs_1','Xi''_b-','Xi*_b-',
1542 &'Xi''_b0','Xi*_b0','Omega_b-','Omega*_b-','Omega_bc0','bc_0',
1543 &'bc_1','Xi''_bc0','Xi*_bc0','Xi''_bc+','Xi*_bc+','Omega''_bc0',
1544 &'Omega*_bc0','Omega_bcc+','Omega*_bcc+','bb_1','Xi_bb-',
1545 &'Xi*_bb-','Xi_bb0','Xi*_bb0','Omega_bb-','Omega*_bb-',
1546 &'Omega_bbc0','Omega*_bbc0','Omega*_bbb-','a_00','b_10','a_0+',
1547 &'b_1+','f_0','h_1','K*_00','K_10','K*_0+','K_1+','f''_0','h''_1',
1548 &'D*_0+','D_1+','D*_00','D_10','D*_0s+','D_1s+','chi_0c','h_1c',
1549 &'B*_00','B_10','B*_0+','B_1+','B*_0s0','B_1s0','B*_0c+','B_1c+',
1550 &'chi_0b','h_1b','a_10','a_1+','f_1','K*_10','K*_1+','f''_1',
1551 &'D*_1+','D*_10','D*_1s+','chi_1c','B*_10','B*_1+','B*_1s0',
1552 &'B*_1c+','chi_1b','psi''','Upsilon''','~d_L','~u_L','~s_L',
1553 &'~c_L','~b_1','~t_1','~e_L-','~nu_eL','~mu_L-','~nu_muL',
1554 &'~tau_1-','~nu_tauL','~g','~chi_10','~chi_20','~chi_1+',
1555 &'~chi_30','~chi_40','~chi_2+','~Gravitino','~d_R','~u_R','~s_R',
1556 &'~c_R','~b_2','~t_2','~e_R-','~nu_eR','~mu_R-','~nu_muR',
1557 &'~tau_2-','~nu_tauR','pi_tc0','pi_tc+','pi''_tc0','eta_tc0'/
1558 DATA (CHAF(I,1),I= 333, 500)/'rho_tc0','rho_tc+','omega_tc',
1559 &'V8_tc','pi_22_1_tc','pi_22_8_tc','rho_11_tc','rho_12_tc',
1560 &'rho_21_tc','rho_22_tc','d*','u*','e*-','nu*_e0','Graviton*',
1561 &'nu_Re','nu_Rmu','nu_Rtau','Z_R0','W_R+','H_L++','H_R++',
1562 &'rho_diff0','pi_diffr+','omega_di','phi_diff','J/psi_di',
1563 &'n_diffr0','p_diffr+','cc~[3S18]','cc~[1S08]','cc~[3P08]',
1564 &'bb~[3S18]','bb~[1S08]','bb~[3P08]','a_tc0','a_tc+',
1565 &81*' ',
1566C...UED
1567 &'d*_S','u*_S','s*_S','c*_S','b*_S','t*_S',
1568 &'d*_D','u*_D','s*_D','c*_D','b*_D','t*_D',
1569 &'e*_S-','mu*_S-','tau*_S-',
1570 &'nu*_eD','e*_D-','nu*_muD','mu*_D-','nu*_tauD','tau*_D-',
1571 &'g*','gamma*','Z*0','W*+',25*' '/
1572 DATA (CHAF(I,2),I= 1, 205)/'dbar','ubar','sbar','cbar','bbar',
1573 &'tbar','b''bar','t''bar',2*' ','e+','nu_ebar','mu+','nu_mubar',
1574 &'tau+','nu_taubar','tau''+','nu''_taubar',5*' ','W-',9*' ',
1575 &'W''-',2*' ','H-',3*' ','Rbar0','LQ_uebar',39*' ','rndmflavbar',
1576 &' ','c-hadronbar','b-hadronbar',20*' ','pi-','rho-','a_2-',4*' ',
1577 &'Kbar0','K*bar0','K*_2bar0','K-','K*-','K*_2-',3*' ','D-','D*-',
1578 &'D*_2-','Dbar0','D*bar0','D*_2bar0','D_s-','D*_s-','D*_2s-',
1579 &3*' ','Bbar0','B*bar0','B*_2bar0','B-','B*-','B*_2-','B_sbar0',
1580 &'B*_sbar0','B*_2sbar0','B_c-','B*_c-','B*_2c-',4*' ','dd_1bar',
1581 &'Deltabar+','ud_0bar','ud_1bar','nbar0','Deltabar0','uu_1bar',
1582 &'pbar-','Deltabar-','Deltabar--','sd_0bar','sd_1bar','Sigmabar+',
1583 &'Sigma*bar+','Lambdabar0','su_0bar','su_1bar','Sigmabar0',
1584 &'Sigma*bar0','Sigmabar-','Sigma*bar-','ss_1bar','Xibar+',
1585 &'Xi*bar+','Xibar0','Xi*bar0','Omegabar+','cd_0bar','cd_1bar',
1586 &'Sigma_cbar0','Sigma*_cbar0','Lambda_cbar-','Xi_cbar0','cu_0bar',
1587 &'cu_1bar','Sigma_cbar-','Sigma*_cbar-','Sigma_cbar--',
1588 &'Sigma*_cbar--','Xi_cbar-','cs_0bar','cs_1bar','Xi''_cbar0',
1589 &'Xi*_cbar0','Xi''_cbar-','Xi*_cbar-','Omega_cbar0',
1590 &'Omega*_cbar0','cc_1bar','Xi_ccbar-','Xi*_ccbar-','Xi_ccbar--',
1591 &'Xi*_ccbar--','Omega_ccbar-','Omega*_ccbar-','Omega*_cccbar-'/
1592 DATA (CHAF(I,2),I= 206, 325)/'bd_0bar','bd_1bar','Sigma_bbar+',
1593 &'Sigma*_bbar+','Lambda_bbar0','Xi_bbar+','Xi_bcbar0','bu_0bar',
1594 &'bu_1bar','Sigma_bbar0','Sigma*_bbar0','Sigma_bbar-',
1595 &'Sigma*_bbar-','Xi_bbar0','Xi_bcbar-','bs_0bar','bs_1bar',
1596 &'Xi''_bbar+','Xi*_bbar+','Xi''_bbar0','Xi*_bbar0','Omega_bbar+',
1597 &'Omega*_bbar+','Omega_bcbar0','bc_0bar','bc_1bar','Xi''_bcbar0',
1598 &'Xi*_bcbar0','Xi''_bcbar-','Xi*_bcbar-','Omega''_bcba',
1599 &'Omega*_bcbar0','Omega_bccbar-','Omega*_bccbar-','bb_1bar',
1600 &'Xi_bbbar+','Xi*_bbbar+','Xi_bbbar0','Xi*_bbbar0','Omega_bbbar+',
1601 &'Omega*_bbbar+','Omega_bbcbar0','Omega*_bbcbar0',
1602 &'Omega*_bbbbar+',2*' ','a_0-','b_1-',2*' ','K*_0bar0','K_1bar0',
1603 &'K*_0-','K_1-',2*' ','D*_0-','D_1-','D*_0bar0','D_1bar0',
1604 &'D*_0s-','D_1s-',2*' ','B*_0bar0','B_1bar0','B*_0-','B_1-',
1605 &'B*_0sbar0','B_1sbar0','B*_0c-','B_1c-',3*' ','a_1-',' ',
1606 &'K*_1bar0','K*_1-',' ','D*_1-','D*_1bar0','D*_1s-',' ',
1607 &'B*_1bar0','B*_1-','B*_1sbar0','B*_1c-',3*' ','~d_Lbar',
1608 &'~u_Lbar','~s_Lbar','~c_Lbar','~b_1bar','~t_1bar','~e_L+',
1609 &'~nu_eLbar','~mu_L+','~nu_muLbar','~tau_1+','~nu_tauLbar',3*' ',
1610 &'~chi_1-',2*' ','~chi_2-',' ','~d_Rbar','~u_Rbar','~s_Rbar',
1611 &'~c_Rbar','~b_2bar','~t_2bar','~e_R+','~nu_eRbar','~mu_R+'/
1612 DATA (CHAF(I,2),I= 326, 500)/'~nu_muRbar','~tau_2+',
1613 &'~nu_tauRbar',' ','pi_tc-',3*' ','rho_tc-',8*' ','d*bar','u*bar',
1614 &'e*bar+','nu*_ebar0',5*' ','W_R-','H_L--','H_R--',' ',
1615 &'pi_diffr-',3*' ','n_diffrbar0','p_diffrbar-',7*' ','a_tc-',
1616 &81*' ',
1617C...UED
1618 &'d*_Sbar','u*_Sbar','s*_Sbar','c*_Sbar','b*_Sbar','t*_Sbar',
1619 &'d*_Dbar','u*_Dbar','s*_Dbar','c*_Dbar','b*_Dbar','t*_Dbar',
1620 &'e*_Sbar+','mu*_Sbar+','tau*_Sbar+',
1621 &'nu*_eDbar','e*_Dbar+',
1622 &'nu*_muDbar','mu*_Dbar+',
1623 &'nu*_tauDbar','tau*_Dbar+',
1624 &'g*','gamma*','Z*0','W*-',25*' '/
1625
1626C...PYDATR, with initial values for the random number generator.
1627 DATA MRPY/19780503,0,0,97,33,0/
1628
1629C...Default values for allowed processes and kinematics constraints.
1630 DATA MSEL/1/
1631 DATA MSUB/500*0/
1632 DATA ((KFIN(I,J),J=-40,40),I=1,2)/16*0,4*1,4*0,6*1,5*0,5*1,0,
1633 &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,
1634 &6*1,4*0,4*1,16*0/
1635 DATA CKIN/
1636 & 2.0D0, -1.0D0, 0.0D0, -1.0D0, 1.0D0,
1637 & 1.0D0, -10D0, 10D0, -40D0, 40D0,
1638 1 -40D0, 40D0, -40D0, 40D0, -40D0,
1639 1 40D0, -1.0D0, 1.0D0, -1.0D0, 1.0D0,
1640 2 0.0D0, 1.0D0, 0.0D0, 1.0D0, -1.0D0,
1641 2 1.0D0, -1.0D0, 1.0D0, 0D0, 0D0,
1642 3 2.0D0, -1.0D0, 0D0, 0D0, 0.0D0,
1643 3 -1.0D0, 0.0D0, -1.0D0, 4.0D0, -1.0D0,
1644 4 12.0D0, -1.0D0, 12.0D0, -1.0D0, 12.0D0,
1645 4 -1.0D0, 12.0D0, -1.0D0, 0D0, 0D0,
1646 5 0.0D0, -1.0D0, 0.0D0, -1.0D0, 0.0D0,
1647 5 -1.0D0, 0D0, 0D0, 0D0, 0D0,
1648 6 0.0001D0, 0.99D0, 0.0001D0, 0.99D0, 0D0,
1649 6 -1D0, 0D0, -1D0, 0D0, -1D0,
1650 7 0D0, -1D0, 0.0001D0, 0.99D0, 0.0001D0,
1651 7 0.99D0, 2D0, -1D0, 0D0, 0D0,
1652 8 120*0D0/
1653
1654C...Default values for main switches and parameters. Reset information.
1655 DATA (MSTP(I),I=1,100)/
1656 & 3, 1, 2, 0, 0, 0, 0, 0, 0, 0,
1657 1 1, 0, 1, 30, 0, 1, 4, 3, 4, 3,
1658 2 1, 0, 1, 0, 0, 0, 0, 0, 0, 1,
1659 3 1, 8, 0, 1, 0, 2, 1, 5, 2, 0,
1660 4 2, 1, 3, 7, 3, 1, 1, 0, 1, 0,
1661 5 7, 1, 3, 1, 5, 1, 1, 5, 1, 7,
1662 6 2, 3, 2, 2, 1, 5, 2, 3, 0, 0,
1663 7 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1664 8 1, 4, 100, 1, 1, 2, 4, 1, 1, 0,
1665 9 1, 3, 1, 3, 1, 0, 0, 0, 0, 0/
1666 DATA (MSTP(I),I=101,200)/
1667 & 3, 1, 0, 0, 0, 0, 0, 0, 0, 0,
1668 1 1, 1, 1, 0, 0, 0, 0, 0, 0, 0,
1669 2 0, 1, 2, 1, 1, 100, 0, 0, 10, 0,
1670 3 0, 4, 0, 1, 0, 0, 0, 0, 0, 0,
1671 4 0, 0, 0, 0, 0, 1, 0, 0, 0, 0,
1672 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1673 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1674 7 0, 2, 0, 0, 0, 0, 0, 0, 0, 0,
1675 8 6, 425, 2011, 03, 23, 0, 0, 0, 0, 0,
1676 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1677 DATA (PARP(I),I=1,100)/
1678 & 0.25D0, 10D0, 8*0D0,
1679 1 0D0, 0D0, 1.0D0, 0.01D0, 0.5D0, 1.0D0, 1.0D0, 0.4D0, 2*0D0,
1680 2 10*0D0,
1681 3 1.5D0,2.0D0,0.075D0,1.0D0,0.2D0,0D0,1.0D0,0.70D0,0.006D0,0D0,
1682 4 0.02D0,2.0D0,0.10D0,1000D0,2054D0,123D0,246D0,50D0,0D0,0.054D0,
1683 5 10*0D0,
1684 6 0.25D0, 1.0D0,0.25D0, 1.0D0, 2.0D0,1D-3, 4.0D0,1D-3,2*0D0,
1685 7 4.0D0, 0.25D0, 5*0D0, 0.025D0, 2.0D0, 0.1D0,
1686 8 1.90D0, 2.0D0, 0.5D0, 0.4D0, 0.90D0,
1687 8 0.95D0, 0.7D0, 0.5D0, 1800D0, 0.25D0,
1688 9 2.0D0,0.40D0,5.0D0,1.0D0,0.0D0,3.0D0,1.0D0,0.75D0,1.0D0,5.0D0/
1689 DATA (PARP(I),I=101,200)/
1690 & 0.5D0, 0.28D0, 1.0D0, 0.8D0, 0D0, 0D0, 0D0, 0D0, 0D0, 1D0,
1691 1 2.0D0, 3*0D0, 1.5D0, 0.5D0, 0.6D0, 2.5D0, 2.0D0, 1.0D0,
1692 2 1.0D0, 0.4D0, 8*0D0,
1693 3 0.01D0, 9*0D0,
1694 4 1.16D0, 0.0119D0, 0.01D0, 0.01D0, 0.05D0,
1695 4 9.28D0, 0.15D0, 0.02D0, 0.48D0, 0.09D0,
1696 5 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0, 0D0,
1697 6 2.20D0, 23.6D0, 18.4D0, 11.5D0, 0.5D0, 0D0, 0D0, 0D0, 2*0D0,
1698 7 0D0, 0D0, 0D0, 1.0D0, 6*0D0,
1699 8 0.1D0, 0.01D0, 0.01D0, 0.01D0, 0.1D0, 0.01D0, 0.01D0, 0.01D0,
1700 8 0.3D0, 0.64D0,
1701 9 0.64D0, 5.0D0, 1.0D4, 1.0D4, 6*0D0/
1702 DATA MSTI/200*0/
1703 DATA PARI/200*0D0/
1704 DATA MINT/400*0/
1705 DATA VINT/400*0D0/
1706
1707C...Constants for the generation of the various processes.
1708 DATA (ISET(I),I=1,100)/
1709 & 1, 1, 1, -1, 3, -1, -1, 3, -2, 2,
1710 1 2, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1711 2 -1, 2, 2, 2, 2, 2, -1, 2, 2, 2,
1712 3 2, 2, 2, 2, 2, 2, -1, -1, -1, -1,
1713 4 -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
1714 5 -1, -1, 2, 2, -1, -1, -1, 2, -1, -1,
1715 6 -1, -1, -1, -1, -1, -1, -1, 2, 2, 2,
1716 7 4, 4, 4, -1, -1, 4, 4, -1, -1, 2,
1717 8 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1718 9 0, 0, 0, 0, 0, 9, -2, -2, 8, -2/
1719 DATA (ISET(I),I=101,200)/
1720 & -1, 1, 1, 1, 1, 2, 2, 2, -2, 2,
1721 1 2, 2, 2, 2, 2, -1, -1, -1, -2, -2,
1722 2 5, 5, 5, 5, -2, -2, -2, -2, -2, -2,
1723 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1724 4 1, 1, 1, 1, 1, 1, 1, 1, 1, -2,
1725 5 1, 1, 1, -2, -2, 1, 1, 1, -2, -2,
1726 6 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1727 7 2, 2, 5, 5, -2, 2, 2, 5, 5, -2,
1728 8 5, 5, 2, 2, 2, 5, 5, 2, 2, 2,
1729 9 1, 1, 1, 2, 2, -2, -2, -2, -2, -2/
1730 DATA (ISET(I),I=201,300)/
1731 & 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1732 1 2, 2, 2, 2, -2, 2, 2, 2, 2, 2,
1733 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1734 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1735 4 2, 2, 2, 2, -1, 2, 2, 2, 2, 2,
1736 5 2, 2, 2, 2, -1, 2, -1, 2, 2, -2,
1737 6 2, 2, 2, 2, 2, -1, -1, -1, -1, -1,
1738 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1739 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1740 9 2, 2, 2, 2, 2, 2, 2, 2, 2, 2/
1741 DATA (ISET(I),I=301,500)/
1742 & 2, 9*-2, 9*2, 21*-2,
1743 4 1, 1, 2, 2, 2, 2, 2, 2, 2, 2,
1744 5 5, 5, 1, 1, -1, -1, -1, -1, -1, -1,
1745 6 2, 2, 2, 2, 2, 2, 2, 2, -1, 2,
1746 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1747 8 2, 2, 2, 2, 2, 2, 2, 2, -2, -2,
1748 9 1, 1, 2, 2, 2, 5*-2,
1749 & 5, 5, 18*-2,
1750 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1751 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 21*-2,
1752 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
1753 7 2, 2, 2, 2, 2, 2, 2, 2, 2, -2,
1754 8 2, 2, 18*-2/
1755 DATA ((KFPR(I,J),J=1,2),I=1,50)/
1756 & 23, 0, 24, 0, 25, 0, 24, 0, 25, 0,
1757 & 24, 0, 23, 0, 25, 0, 0, 0, 0, 0,
1758 1 0, 0, 0, 0, 21, 21, 21, 22, 21, 23,
1759 1 21, 24, 21, 25, 22, 22, 22, 23, 22, 24,
1760 2 22, 25, 23, 23, 23, 24, 23, 25, 24, 24,
1761 2 24, 25, 25, 25, 0, 21, 0, 22, 0, 23,
1762 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1763 3 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1764 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23,
1765 4 0, 24, 0, 25, 0, 21, 0, 22, 0, 23/
1766 DATA ((KFPR(I,J),J=1,2),I=51,100)/
1767 5 0, 24, 0, 25, 0, 0, 0, 0, 0, 0,
1768 5 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1769 6 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1770 6 0, 0, 0, 0, 21, 21, 24, 24, 23, 24,
1771 7 23, 23, 24, 24, 23, 24, 23, 25, 22, 22,
1772 7 23, 23, 24, 24, 24, 25, 25, 25, 0, 211,
1773 8 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1774 8 443, 21,10441, 21,20443, 21, 445, 21, 0, 0,
1775 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1776 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1777 DATA ((KFPR(I,J),J=1,2),I=101,150)/
1778 & 23, 0, 25, 0, 25, 0,10441, 0, 445, 0,
1779 & 443, 22, 443, 21, 443, 22, 0, 0, 22, 25,
1780 1 21, 25, 0, 25, 21, 25, 22, 22, 21, 22,
1781 1 22, 23, 23, 23, 24, 24, 0, 0, 0, 0,
1782 2 25, 6, 25, 6, 25, 0, 25, 0, 0, 0,
1783 2 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1784 3 0, 21, 0, 21, 0, 22, 0, 22, 0, 0,
1785 3 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
1786 4 32, 0, 34, 0, 37, 0, 41, 0, 42, 0,
1787 4 4000011, 0, 4000001, 0, 4000002, 0, 3000331, 0, 0, 0/
1788 DATA ((KFPR(I,J),J=1,2),I=151,200)/
1789 5 35, 0, 35, 0, 35, 0, 0, 0, 0, 0,
1790 5 36, 0, 36, 0, 36, 0, 0, 0, 0, 0,
1791 6 6, 37, 42, 0, 42, 42, 42, 42, 11, 0,
1792 6 11, 0, 0, 4000001, 0, 4000002, 0, 4000011, 0, 0,
1793 7 23, 35, 24, 35, 35, 0, 35, 0, 0, 0,
1794 7 23, 36, 24, 36, 36, 0, 36, 0, 0, 0,
1795 8 35, 6, 35, 6, 21, 35, 0, 35, 21, 35,
1796 8 36, 6, 36, 6, 21, 36, 0, 36, 21, 36,
1797 9 3000113, 0, 3000213, 0, 3000223, 0, 11, 0, 11, 0,
1798 9 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/
1799 DATA ((KFPR(I,J),J=1,2),I=201,240)/
1800 & 1000011, 1000011, 2000011, 2000011, 1000011,
1801 & 2000011, 1000013, 1000013, 2000013, 2000013,
1802 & 1000013, 2000013, 1000015, 1000015, 2000015,
1803 & 2000015, 1000015, 2000015, 1000011, 1000012,
1804 1 1000015, 1000016, 2000015, 1000016, 1000012,
1805 1 1000012, 1000016, 1000016, 0, 0,
1806 1 1000022, 1000022, 1000023, 1000023, 1000025,
1807 1 1000025, 1000035, 1000035, 1000022, 1000023,
1808 2 1000022, 1000025, 1000022, 1000035, 1000023,
1809 2 1000025, 1000023, 1000035, 1000025, 1000035,
1810 2 1000024, 1000024, 1000037, 1000037, 1000024,
1811 2 1000037, 1000022, 1000024, 1000023, 1000024,
1812 3 1000025, 1000024, 1000035, 1000024, 1000022,
1813 3 1000037, 1000023, 1000037, 1000025, 1000037,
1814 3 1000035, 1000037, 1000021, 1000022, 1000021,
1815 3 1000023, 1000021, 1000025, 1000021, 1000035/
1816 DATA ((KFPR(I,J),J=1,2),I=241,280)/
1817 4 1000021, 1000024, 1000021, 1000037, 1000021,
1818 4 1000021, 1000021, 1000021, 0, 0,
1819 4 1000002, 1000022, 2000002, 1000022, 1000002,
1820 4 1000023, 2000002, 1000023, 1000002, 1000025,
1821 5 2000002, 1000025, 1000002, 1000035, 2000002,
1822 5 1000035, 1000001, 1000024, 2000005, 1000024,
1823 5 1000001, 1000037, 2000005, 1000037, 1000002,
1824 5 1000021, 2000002, 1000021, 0, 0,
1825 6 1000006, 1000006, 2000006, 2000006, 1000006,
1826 6 2000006, 1000006, 1000006, 2000006, 2000006,
1827 6 0, 0, 0, 0, 0,
1828 6 0, 0, 0, 0, 0,
1829 7 1000002, 1000002, 2000002, 2000002, 1000002,
1830 7 2000002, 1000002, 1000002, 2000002, 2000002,
1831 7 1000002, 2000002, 1000002, 1000002, 2000002,
1832 7 2000002, 1000002, 1000002, 2000002, 2000002/
1833 DATA ((KFPR(I,J),J=1,2),I=281,350)/
1834 8 1000005, 1000002, 2000005, 2000002, 1000005,
1835 8 2000002, 1000005, 1000002, 2000005, 2000002,
1836 8 1000005, 2000002, 1000005, 1000005, 2000005,
1837 8 2000005, 1000005, 1000005, 2000005, 2000005,
1838 9 1000005, 1000005, 2000005, 2000005, 1000005,
1839 9 2000005, 1000005, 1000021, 2000005, 1000021,
1840 9 1000005, 2000005, 37, 25, 37,
1841 9 35, 36, 25, 36, 35,
1842 & 37, 37, 18*0,
1843C...UED: 311-319
1844 & 5100021, 5100021,
1845 & 5100002, 5100021,
1846 & 5100002, 5100001,
1847 & 5100002, -5100002,
1848 & 5100002, -5100002,
1849 & 5100002, -6100001,
1850 & 5100002, -5100001,
1851 & 5100002, 6100001,
1852 & 5100001, -5100001,
1853 & 42*0,
1854 4 9900041, 0, 9900042, 0, 9900041,
1855 4 11, 9900042, 11, 9900041, 13,
1856 4 9900042, 13, 9900041, 15, 9900042,
1857 4 15, 9900041, 9900041, 9900042, 9900042/
1858 DATA ((KFPR(I,J),J=1,2),I=351,400)/
1859 5 9900041, 0, 9900042, 0, 9900023,
1860 5 0, 9900024, 0, 0, 0,
1861 5 0, 0, 0, 0, 0,
1862 5 0, 0, 0, 0, 0,
1863 6 24, 24, 24, 3000211, 3000211,
1864 6 3000211, 22, 3000111, 22, 3000221,
1865 6 23, 3000111, 23, 3000221, 24,
1866 6 3000211, 0, 0, 24, 23,
1867 7 24, 3000111, 3000211, 23, 3000211,
1868 7 3000111, 22, 3000211, 23, 3000211,
1869 7 24, 3000111, 24, 3000221, 22,
1870 7 24, 22, 23, 23, 23,
1871 8 0, 0, 0, 0, 21, 21, 0, 21, 0, 0,
1872 8 21, 21, 0, 0, 0, 0, 0, 0, 0, 0,
1873 9 5000039, 0, 5000039, 0, 21,
1874 9 5000039, 0, 5000039, 21, 5000039,
1875 9 10*0/
1876 DATA ((KFPR(I,J),J=1,2),I=401,500)/
1877 & 37, 6, 37, 6, 36*0,
1878 2 443, 21, 9900443, 21, 9900441,
1879 2 21, 9910441, 21, 0, 9900443,
1880 2 0, 9900441, 0, 9910441, 21,
1881 2 9900443, 21, 9900441, 21, 9910441,
1882 3 10441, 21, 20443, 21, 445, 21, 0, 10441, 0, 20443,
1883 3 0, 445, 21, 10441, 21, 20443, 21, 445, 42*0,
1884 6 553, 21, 9900553, 21, 9900551,
1885 6 21, 9910551, 21, 0, 9900553,
1886 6 0, 9900551, 0, 9910551, 21,
1887 6 9900553, 21, 9900551, 21, 9910551,
1888 7 10551, 21, 20553, 21, 555, 21, 0, 10551, 0, 20553,
1889 7 0, 555, 21, 10551, 21, 20553, 21, 555, 42*0/
1890 DATA COEF/10000*0D0/
1891 DATA (((ICOL(I,J,K),K=1,2),J=1,4),I=1,40)/
1892 &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,
1893 &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,
1894 &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,
1895 &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,
1896 &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,
1897 &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,
1898 &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,
1899 &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,
1900 &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,
1901 &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/
1902
1903C...Treatment of resonances.
1904 DATA (MWID(I) ,I= 1, 500)/5*0,3*1,8*0,1,5*0,3*1,6*0,1,0,4*1,
1905 &3*0,2*1,254*0,19*2,0,7*2,0,2,0,2,0,26*1,7*0,6*2,2*1,
1906 &81*0,21*1,4*1,25*0/
1907
1908C...Character constants: name of processes.
1909 DATA PROC(0)/ 'All included subprocesses '/
1910 DATA (PROC(I),I=1,20)/
1911 &'f + fbar -> gamma*/Z0 ', 'f + fbar'' -> W+/- ',
1912 &'f + fbar -> h0 ', 'gamma + W+/- -> W+/- ',
1913 &'Z0 + Z0 -> h0 ', 'Z0 + W+/- -> W+/- ',
1914 &' ', 'W+ + W- -> h0 ',
1915 &' ', 'f + f'' -> f + f'' (QFD) ',
1916 1'f + f'' -> f + f'' (QCD) ','f + fbar -> f'' + fbar'' ',
1917 1'f + fbar -> g + g ', 'f + fbar -> g + gamma ',
1918 1'f + fbar -> g + Z0 ', 'f + fbar'' -> g + W+/- ',
1919 1'f + fbar -> g + h0 ', 'f + fbar -> gamma + gamma ',
1920 1'f + fbar -> gamma + Z0 ', 'f + fbar'' -> gamma + W+/- '/
1921 DATA (PROC(I),I=21,40)/
1922 2'f + fbar -> gamma + h0 ', 'f + fbar -> Z0 + Z0 ',
1923 2'f + fbar'' -> Z0 + W+/- ', 'f + fbar -> Z0 + h0 ',
1924 2'f + fbar -> W+ + W- ', 'f + fbar'' -> W+/- + h0 ',
1925 2'f + fbar -> h0 + h0 ', 'f + g -> f + g ',
1926 2'f + g -> f + gamma ', 'f + g -> f + Z0 ',
1927 3'f + g -> f'' + W+/- ', 'f + g -> f + h0 ',
1928 3'f + gamma -> f + g ', 'f + gamma -> f + gamma ',
1929 3'f + gamma -> f + Z0 ', 'f + gamma -> f'' + W+/- ',
1930 3'f + gamma -> f + h0 ', 'f + Z0 -> f + g ',
1931 3'f + Z0 -> f + gamma ', 'f + Z0 -> f + Z0 '/
1932 DATA (PROC(I),I=41,60)/
1933 4'f + Z0 -> f'' + W+/- ', 'f + Z0 -> f + h0 ',
1934 4'f + W+/- -> f'' + g ', 'f + W+/- -> f'' + gamma ',
1935 4'f + W+/- -> f'' + Z0 ', 'f + W+/- -> f'' + W+/- ',
1936 4'f + W+/- -> f'' + h0 ', 'f + h0 -> f + g ',
1937 4'f + h0 -> f + gamma ', 'f + h0 -> f + Z0 ',
1938 5'f + h0 -> f'' + W+/- ', 'f + h0 -> f + h0 ',
1939 5'g + g -> f + fbar ', 'g + gamma -> f + fbar ',
1940 5'g + Z0 -> f + fbar ', 'g + W+/- -> f + fbar'' ',
1941 5'g + h0 -> f + fbar ', 'gamma + gamma -> f + fbar ',
1942 5'gamma + Z0 -> f + fbar ', 'gamma + W+/- -> f + fbar'' '/
1943 DATA (PROC(I),I=61,80)/
1944 6'gamma + h0 -> f + fbar ', 'Z0 + Z0 -> f + fbar ',
1945 6'Z0 + W+/- -> f + fbar'' ', 'Z0 + h0 -> f + fbar ',
1946 6'W+ + W- -> f + fbar ', 'W+/- + h0 -> f + fbar'' ',
1947 6'h0 + h0 -> f + fbar ', 'g + g -> g + g ',
1948 6'gamma + gamma -> W+ + W- ', 'gamma + W+/- -> Z0 + W+/- ',
1949 7'Z0 + Z0 -> Z0 + Z0 ', 'Z0 + Z0 -> W+ + W- ',
1950 7'Z0 + W+/- -> Z0 + W+/- ', 'Z0 + Z0 -> Z0 + h0 ',
1951 7'W+ + W- -> gamma + gamma ', 'W+ + W- -> Z0 + Z0 ',
1952 7'W+/- + W+/- -> W+/- + W+/- ', 'W+/- + h0 -> W+/- + h0 ',
1953 7'h0 + h0 -> h0 + h0 ', 'q + gamma -> q'' + pi+/- '/
1954 DATA (PROC(I),I=81,100)/
1955 8'q + qbar -> Q + Qbar, mass ', 'g + g -> Q + Qbar, massive ',
1956 8'f + q -> f'' + Q, massive ', 'g + gamma -> Q + Qbar, mass ',
1957 8'gamma + gamma -> F + Fbar, m', 'g + g -> J/Psi + g ',
1958 8'g + g -> chi_0c + g ', 'g + g -> chi_1c + g ',
1959 8'g + g -> chi_2c + g ', ' ',
1960 9'Elastic scattering ', 'Single diffractive (XB) ',
1961 9'Single diffractive (AX) ', 'Double diffractive ',
1962 9'Low-pT scattering ', 'Semihard QCD 2 -> 2 ',
1963 9' ', ' ',
1964 9'q + gamma* -> q ', ' '/
1965 DATA (PROC(I),I=101,120)/
1966 &'g + g -> gamma*/Z0 ', 'g + g -> h0 ',
1967 &'gamma + gamma -> h0 ', 'g + g -> chi_0c ',
1968 &'g + g -> chi_2c ', 'g + g -> J/Psi + gamma ',
1969 &'gamma + g -> J/Psi + g ', 'gamma+gamma -> J/Psi + gamma',
1970 &' ', 'f + fbar -> gamma + h0 ',
1971 1'q + qbar -> g + h0 ', 'q + g -> q + h0 ',
1972 1'g + g -> g + h0 ', 'g + g -> gamma + gamma ',
1973 1'g + g -> g + gamma ', 'g + g -> gamma + Z0 ',
1974 1'g + g -> Z0 + Z0 ', 'g + g -> W+ + W- ',
1975 1' ', ' '/
1976 DATA (PROC(I),I=121,140)/
1977 2'g + g -> Q + Qbar + h0 ', 'q + qbar -> Q + Qbar + h0 ',
1978 2'f + f'' -> f + f'' + h0 ',
1979 2'f + f'' -> f" + f"'' + h0 ',
1980 2' ', ' ',
1981 2' ', ' ',
1982 2' ', ' ',
1983 3'f + gamma*_T -> f + g ', 'f + gamma*_L -> f + g ',
1984 3'f + gamma*_T -> f + gamma ', 'f + gamma*_L -> f + gamma ',
1985 3'g + gamma*_T -> f + fbar ', 'g + gamma*_L -> f + fbar ',
1986 3'gamma*_T+gamma*_T -> f+fbar ', 'gamma*_T+gamma*_L -> f+fbar ',
1987 3'gamma*_L+gamma*_T -> f+fbar ', 'gamma*_L+gamma*_L -> f+fbar '/
1988 DATA (PROC(I),I=141,160)/
1989 4'f + fbar -> gamma*/Z0/Z''0 ', 'f + fbar'' -> W''+/- ',
1990 4'f + fbar'' -> H+/- ', 'f + fbar'' -> R ',
1991 4'q + l -> LQ ', 'e + gamma -> e* ',
1992 4'd + g -> d* ', 'u + g -> u* ',
1993 4'g + g -> eta_tc ', ' ',
1994 5'f + fbar -> H0 ', 'g + g -> H0 ',
1995 5'gamma + gamma -> H0 ', ' ',
1996 5' ', 'f + fbar -> A0 ',
1997 5'g + g -> A0 ', 'gamma + gamma -> A0 ',
1998 5' ', ' '/
1999 DATA (PROC(I),I=161,180)/
2000 6'f + g -> f'' + H+/- ', 'q + g -> LQ + lbar ',
2001 6'g + g -> LQ + LQbar ', 'q + qbar -> LQ + LQbar ',
2002 6'f + fbar -> f'' + fbar'' (g/Z)',
2003 6'f +fbar'' -> f" + fbar"'' (W) ',
2004 6'q + q'' -> q" + d* ', 'q + q'' -> q" + u* ',
2005 6'q + qbar -> e + e* ', ' ',
2006 7'f + fbar -> Z0 + H0 ', 'f + fbar'' -> W+/- + H0 ',
2007 7'f + f'' -> f + f'' + H0 ',
2008 7'f + f'' -> f" + f"'' + H0 ',
2009 7' ', 'f + fbar -> Z0 + A0 ',
2010 7'f + fbar'' -> W+/- + A0 ',
2011 7'f + f'' -> f + f'' + A0 ',
2012 7'f + f'' -> f" + f"'' + A0 ',
2013 7' '/
2014 DATA (PROC(I),I=181,200)/
2015 8'g + g -> Q + Qbar + H0 ', 'q + qbar -> Q + Qbar + H0 ',
2016 8'q + qbar -> g + H0 ', 'q + g -> q + H0 ',
2017 8'g + g -> g + H0 ', 'g + g -> Q + Qbar + A0 ',
2018 8'q + qbar -> Q + Qbar + A0 ', 'q + qbar -> g + A0 ',
2019 8'q + g -> q + A0 ', 'g + g -> g + A0 ',
2020 9'f + fbar -> rho_tc0 ', 'f + f'' -> rho_tc+/- ',
2021 9'f + fbar -> omega_tc0 ', 'f+fbar -> f''+fbar'' (ETC) ',
2022 9'f+fbar'' -> f"+fbar"'' (ETC)',' ',
2023 9' ', ' ',
2024 9' ', ' '/
2025 DATA (PROC(I),I=201,220)/
2026 &'f + fbar -> ~e_L + ~e_Lbar ', 'f + fbar -> ~e_R + ~e_Rbar ',
2027 &'f + fbar -> ~e_R + ~e_Lbar ', 'f + fbar -> ~mu_L + ~mu_Lbar',
2028 &'f + fbar -> ~mu_R + ~mu_Rbar', 'f + fbar -> ~mu_L + ~mu_Rbar',
2029 &'f+fbar -> ~tau_1 + ~tau_1bar', 'f+fbar -> ~tau_2 + ~tau_2bar',
2030 &'f+fbar -> ~tau_1 + ~tau_2bar', 'q + qbar'' -> ~l_L + ~nulbar ',
2031 1'q+qbar''-> ~tau_1 + ~nutaubar', 'q+qbar''-> ~tau_2 + ~nutaubar',
2032 1'f + fbar -> ~nul + ~nulbar ', 'f+fbar -> ~nutau + ~nutaubar',
2033 1' ', 'f + fbar -> ~chi1 + ~chi1 ',
2034 1'f + fbar -> ~chi2 + ~chi2 ', 'f + fbar -> ~chi3 + ~chi3 ',
2035 1'f + fbar -> ~chi4 + ~chi4 ', 'f + fbar -> ~chi1 + ~chi2 '/
2036 DATA (PROC(I),I=221,240)/
2037 2'f + fbar -> ~chi1 + ~chi3 ', 'f + fbar -> ~chi1 + ~chi4 ',
2038 2'f + fbar -> ~chi2 + ~chi3 ', 'f + fbar -> ~chi2 + ~chi4 ',
2039 2'f + fbar -> ~chi3 + ~chi4 ', 'f+fbar -> ~chi+-1 + ~chi-+1 ',
2040 2'f+fbar -> ~chi+-2 + ~chi-+2 ', 'f+fbar -> ~chi+-1 + ~chi-+2 ',
2041 2'q + qbar'' -> ~chi1 + ~chi+-1', 'q + qbar'' -> ~chi2 + ~chi+-1',
2042 3'q + qbar'' -> ~chi3 + ~chi+-1', 'q + qbar'' -> ~chi4 + ~chi+-1',
2043 3'q + qbar'' -> ~chi1 + ~chi+-2', 'q + qbar'' -> ~chi2 + ~chi+-2',
2044 3'q + qbar'' -> ~chi3 + ~chi+-2', 'q + qbar'' -> ~chi4 + ~chi+-2',
2045 3'q + qbar -> ~chi1 + ~g ', 'q + qbar -> ~chi2 + ~g ',
2046 3'q + qbar -> ~chi3 + ~g ', 'q + qbar -> ~chi4 + ~g '/
2047 DATA (PROC(I),I=241,260)/
2048 4'q + qbar'' -> ~chi+-1 + ~g ', 'q + qbar'' -> ~chi+-2 + ~g ',
2049 4'q + qbar -> ~g + ~g ', 'g + g -> ~g + ~g ',
2050 4' ', 'qj + g -> ~qj_L + ~chi1 ',
2051 4'qj + g -> ~qj_R + ~chi1 ', 'qj + g -> ~qj_L + ~chi2 ',
2052 4'qj + g -> ~qj_R + ~chi2 ', 'qj + g -> ~qj_L + ~chi3 ',
2053 5'qj + g -> ~qj_R + ~chi3 ', 'qj + g -> ~qj_L + ~chi4 ',
2054 5'qj + g -> ~qj_R + ~chi4 ', 'qj + g -> ~qk_L + ~chi+-1 ',
2055 5'qj + g -> ~qk_R + ~chi+-1 ', 'qj + g -> ~qk_L + ~chi+-2 ',
2056 5'qj + g -> ~qk_R + ~chi+-2 ', 'qj + g -> ~qj_L + ~g ',
2057 5'qj + g -> ~qj_R + ~g ', ' '/
2058 DATA (PROC(I),I=261,300)/
2059 6'f + fbar -> ~t_1 + ~t_1bar ', 'f + fbar -> ~t_2 + ~t_2bar ',
2060 6'f + fbar -> ~t_1 + ~t_2bar ', 'g + g -> ~t_1 + ~t_1bar ',
2061 6'g + g -> ~t_2 + ~t_2bar ', ' ',
2062 6' ', ' ',
2063 6' ', ' ',
2064 7'qi + qj -> ~qi_L + ~qj_L ', 'qi + qj -> ~qi_R + ~qj_R ',
2065 7'qi + qj -> ~qi_L + ~qj_R ', 'qi+qjbar -> ~qi_L + ~qj_Lbar',
2066 7'qi+qjbar -> ~qi_R + ~qj_Rbar', 'qi+qjbar -> ~qi_L + ~qj_Rbar',
2067 7'f + fbar -> ~qi_L + ~qi_Lbar', 'f + fbar -> ~qi_R + ~qi_Rbar',
2068 7'g + g -> ~qi_L + ~qi_Lbar ', 'g + g -> ~qi_R + ~qi_Rbar ',
2069 8'b + qj -> ~b_1 + ~qj_L ', 'b + qj -> ~b_2 + ~qj_R ',
2070 8'b + qj -> ~b_1 + ~qj_R ', 'b + qjbar -> ~b_1 + ~qj_Lbar',
2071 8'b + qjbar -> ~b_2 + ~qj_Rbar', 'b + qjbar -> ~b_1 + ~qj_Rbar',
2072 8'f + fbar -> ~b_1 + ~b_1bar ', 'f + fbar -> ~b_2 + ~b_2bar ',
2073 8'g + g -> ~b_1 + ~b_1bar ', 'g + g -> ~b_2 + ~b_2bar ',
2074 9'b + b -> ~b_1 + ~b_1 ', 'b + b -> ~b_2 + ~b_2 ',
2075 9'b + b -> ~b_1 + ~b_2 ', 'b + g -> ~b_1 + ~g ',
2076 9'b + g -> ~b_2 + ~g ', 'b + bbar -> ~b_1 + ~b_2bar ',
2077 9'f + fbar'' -> H+/- + h0 ', 'f + fbar -> H+/- + H0 ',
2078 9'f + fbar -> A0 + h0 ', 'f + fbar -> A0 + H0 '/
2079 DATA (PROC(I),I=301,340)/
2080 &'f + fbar -> H+ + H- ',
2081 &9*' ', 'g + g -> g* + g* ',
2082 &'q + g -> q*_D + g* ', 'qi + qj -> q*_Di + q*_Dj ',
2083 &'g + g -> q*_D + q*_Dbar ', 'q + qbar -> q*_D + q*_Dbar ',
2084 &'qi + qbarj -> q*Di + q*Sbarj', 'qi + qjbar -> q*Di + q*Dbarj',
2085 &'qi + qj -> q*_Di + q*_Sj ', 'qi + qibar -> q*Dj + q*Dbarj',
2086 &21*' '/
2087 DATA (PROC(I),I=341,380)/
2088 4'l + l -> H_L++/-- ', 'l + l -> H_R++/-- ',
2089 4'l + gamma -> H_L++/-- e-/+ ', 'l + gamma -> H_R++/-- e-/+ ',
2090 4'l + gamma -> H_L++/-- mu-/+ ', 'l + gamma -> H_R++/-- mu-/+ ',
2091 4'l + gamma -> H_L++/-- tau-/+', 'l + gamma -> H_R++/-- tau-/+',
2092 4'f + fbar -> H_L++ + H_L-- ', 'f + fbar -> H_R++ + H_R-- ',
2093 5'f + f -> f'' + f'' + H_L++/-- ',
2094 5'f + f -> f'' + f'' + H_R++/-- ','f + fbar -> Z_R0 ',
2095 5'f + fbar'' -> W_R+/- ',5*' ',
2096 6' ', 'f + fbar -> W_L+ W_L- ',
2097 6'f + fbar -> W_L+/- pi_T-/+ ', 'f + fbar -> pi_T+ pi_T- ',
2098 6'f + fbar -> gamma pi_T0 ', 'f + fbar -> gamma pi_T0'' ',
2099 6'f + fbar -> Z0 pi_T0 ', 'f + fbar -> Z0 pi_T0'' ',
2100 6'f + fbar -> W+/- pi_T-/+ ', ' ',
2101 7'f + fbar'' -> W_L+/- Z_L0 ', 'f + fbar'' -> W_L+/- pi_T0 ',
2102 7'f + fbar'' -> pi_T+/- Z_L0 ', 'f + fbar'' -> pi_T+/- pi_T0 ',
2103 7'f + fbar'' -> gamma pi_T+/- ', 'f + fbar'' -> Z0 pi_T+/- ',
2104 7'f + fbar'' -> W+/- pi_T0 ',
2105 7'f + fbar'' -> W+/- pi_T0'' ',
2106 7'f + fbar'' -> gamma W+/-(ETC)','f + fbar -> gamma Z0 (ETC)',
2107 7'f + fbar -> Z0 Z0 (ETC) '/
2108 DATA (PROC(I),I=381,420)/
2109 8'f + f'' -> f + f'' (ETC) ','f + fbar -> f'' + fbar'' (ETC)',
2110 8'f + fbar -> g + g (ETC) ', 'f + g -> f + g (ETC) ',
2111 8'g + g -> f + fbar (ETC) ', 'g + g -> g + g (ETC) ',
2112 8'q + qbar -> Q + Qbar (ETC) ', 'g + g -> Q + Qbar (ETC) ',
2113 8' ', ' ',
2114 9'f + fbar -> G* ', 'g + g -> G* ',
2115 9'q + qbar -> g + G* ', 'q + g -> q + G* ',
2116 9'g + g -> g + G* ', ' ',
2117 9 4*' ',
2118 &'g + g -> t + b + H+/- ', 'q + qbar -> t + b + H+/- ',
2119 & 18*' '/
2120 DATA (PROC(I),I=421,460)/
2121 2'g + g -> cc~[3S1(1)] + g ', 'g + g -> cc~[3S1(8)] + g ',
2122 2'g + g -> cc~[1S0(8)] + g ', 'g + g -> cc~[3PJ(8)] + g ',
2123 2'g + q -> q + cc~[3S1(8)] ', 'g + q -> q + cc~[1S0(8)] ',
2124 2'g + q -> q + cc~[3PJ(8)] ', 'q + q~ -> g + cc~[3S1(8)] ',
2125 2'q + q~ -> g + cc~[1S0(8)] ', 'q + q~ -> g + cc~[3PJ(8)] ',
2126 3'g + g -> cc~[3P0(1)] + g ', 'g + g -> cc~[3P1(1)] + g ',
2127 3'g + g -> cc~[3P2(1)] + g ', 'q + g -> q + cc~[3P0(1)] ',
2128 3'q + g -> q + cc~[3P1(1)] ', 'q + g -> q + cc~[3P2(1)] ',
2129 3'q + q~ -> g + cc~[3P0(1)] ', 'q + q~ -> g + cc~[3P1(1)] ',
2130 3'q + q~ -> g + cc~[3P2(1)] ',
2131 3 21 *' '/
2132 DATA (PROC(I),I=461,500)/
2133 6'g + g -> bb~[3S1(1)] + g ', 'g + g -> bb~[3S1(8)] + g ',
2134 6'g + g -> bb~[1S0(8)] + g ', 'g + g -> bb~[3PJ(8)] + g ',
2135 6'g + q -> q + bb~[3S1(8)] ', 'g + q -> q + bb~[1S0(8)] ',
2136 6'g + q -> q + bb~[3PJ(8)] ', 'q + q~ -> g + bb~[3S1(8)] ',
2137 6'q + q~ -> g + bb~[1S0(8)] ', 'q + q~ -> g + bb~[3PJ(8)] ',
2138 7'g + g -> bb~[3P0(1)] + g ', 'g + g -> bb~[3P1(1)] + g ',
2139 7'g + g -> bb~[3P2(1)] + g ', 'q + g -> q + bb~[3P0(1)] ',
2140 7'q + g -> q + bb~[3P1(1)] ', 'q + g -> q + bb~[3P2(1)] ',
2141 7'q + q~ -> g + bb~[3P0(1)] ', 'q + q~ -> g + bb~[3P1(1)] ',
2142 7'q + q~ -> g + bb~[3P2(1)] ',
2143 7 21 *' '/
2144
2145C...Cross sections and slope offsets.
2146 DATA SIGT/294*0D0/
2147
2148C...Supersymmetry switches and parameters.
2149 DATA IMSS/0,
2150 & 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
2151 1 89*0/
2152 DATA RMSS/0D0,
2153 & 80D0,160D0,500D0,800D0,2D0,250D0,200D0,800D0,700D0,800D0,
2154 1 700D0,500D0,250D0,200D0,800D0,400D0,0D0,0.1D0,850D0,0.041D0,
2155 2 1D0,800D0,1D4,1D4,1D4,0D0,0D0,0D0,24D17,0D0,
2156 3 10*0D0,
2157 4 0D0,1D0,8*0D0,
2158 5 49*0D0/
2159C...Initial values for R-violating SUSY couplings.
2160C...Should not be changed here. See PYMSIN.
2161 DATA RVLAM/27*0D0/
2162 DATA RVLAMP/27*0D0/
2163 DATA RVLAMB/27*0D0/
2164
2165C...Technicolor switches and parameters
2166 DATA ITCM/0,
2167 & 4, 0, 0, 0, 0, 0, 0, 0, 0, 0,
2168 1 89*0/
2169 DATA RTCM/0D0,
2170 & 82D0,1.333D0,.333D0,0.408D0,1D0,1D0,.0182D0,1D0,0D0,1.333D0,
2171 1 .05D0,200D0,200D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2172 2 .283D0,.707D0,0D0,0D0,0D0,1.667D0,250D0,250D0,.707D0,0D0,
2173 3 .707D0,0D0,1D0,0D0,0D0,0D0,0D0,0D0,0D0,0D0,
2174 4 1000D0, 1D0, 1D0, 1D0, 1D0, 0D0, 1D0, 3*200D0,
2175 4 200D0, 48*0D0/
2176
2177C...UED switches and parameters.
2178C... IUED(0) empty IUED vector element
2179C... IUED(1) UED ON(=1)/OFF(=0) switch
2180C... IUED(2) ON(=1)/OFF(=0) switch for gravity mediated decays
2181C... IUED(3) NFLAVOURS Number of KK excitation quark flavours
2182C... IUED(4) N the number of large extra dimensions
2183C... IUED(5) Selects whether the code takes Lambda (=0)
2184C... or Lambda*R (=1) as input.
2185C... IUED(6) With radiative corrections to the masses (=1)
2186C... or without (=0)
2187C...
2188C... RUED(0) empty RUED vector element
2189C... RUED(1) RINV (1/R) the curvature of the extra dimension
2190C... RUED(2) XMD the (4+N)-dimensional Planck scale
2191C... RUED(3) LAMUED (Lambda cutoff scale)
2192C... RUED(4) LAMUED/RINV (feasible values are order of 10-20)
2193C...
2194 DATA IUED/0,0,0,5,6,0,1,93*0/
2195 DATA RUED/0.D0,1000D0,5000D0,20000.,20.,95*0D0/
2196
2197C...Data for histogramming routines.
2198 DATA IHIST/1000,20000,55,1/
2199 DATA INDX/1000*0/
2200
2201C...Data for SUSY Les Houches Accord.
2202 DATA CPRO/'PYTHIA ','PYTHIA '/
2203 DATA CVER/'6.4 ','6.4 '/
2204 DATA MODSEL/200*0/
2205 DATA PARMIN/100*0D0/
2206 DATA RMSOFT/101*0D0/
2207 DATA AU/9*0D0/
2208 DATA AD/9*0D0/
2209 DATA AE/9*0D0/
2210
2211 END
2212
2213C*********************************************************************
2214
2215C...PYCKBD
2216C...Check that BLOCK DATA PYDATA has been loaded.
2217C...Should not be required, except that some compilers/linkers
2218C...are pretty buggy in this respect.
2219
2220 SUBROUTINE PYCKBD
2221
2222C...Double precision and integer declarations.
2223 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2224 IMPLICIT INTEGER(I-N)
2225 INTEGER PYK,PYCHGE,PYCOMP
2226C...Commonblocks.
2227 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2228 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2229 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2230 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2231 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2232 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2233 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2234
2235C...Check a few variables to see they have been sensibly initialized.
2236 IF(MSTU(4).LT.10.OR.MSTU(4).GT.900000.OR.PMAS(2,1).LT.0.001D0
2237 &.OR.PMAS(2,1).GT.1D0.OR.CKIN(5).LT.0.01D0.OR.MSTP(1).LT.1.OR.
2238 &MSTP(1).GT.5) THEN
2239C...If not, abort the run right away.
2240 WRITE(*,*) 'Fatal error: BLOCK DATA PYDATA has not been loaded!'
2241 WRITE(*,*) 'The program execution is stopped now!'
2242 CALL PYSTOP(8)
2243 ENDIF
2244
2245 RETURN
2246 END
2247
2248C*********************************************************************
2249
2250C...PYTEST
2251C...A simple program (disguised as subroutine) to run at installation
2252C...as a check that the program works as intended.
2253
2254 SUBROUTINE PYTEST(MTEST)
2255
2256C...Double precision and integer declarations.
2257 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2258 IMPLICIT INTEGER(I-N)
2259 INTEGER PYK,PYCHGE,PYCOMP
2260C...Commonblocks.
2261 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2262 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2263 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2264 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2265 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2266 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2267 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/
2268C...Local arrays.
2269 DIMENSION PSUM(5),PINI(6),PFIN(6)
2270
2271C...Save defaults for values that are changed.
2272 MSTJ1=MSTJ(1)
2273 MSTJ3=MSTJ(3)
2274 MSTJ11=MSTJ(11)
2275 MSTJ42=MSTJ(42)
2276 MSTJ43=MSTJ(43)
2277 MSTJ44=MSTJ(44)
2278 PARJ17=PARJ(17)
2279 PARJ22=PARJ(22)
2280 PARJ43=PARJ(43)
2281 PARJ54=PARJ(54)
2282 MST101=MSTJ(101)
2283 MST104=MSTJ(104)
2284 MST105=MSTJ(105)
2285 MST107=MSTJ(107)
2286 MST116=MSTJ(116)
2287
2288C...First part: loop over simple events to be generated.
2289 IF(MTEST.GE.1) CALL PYTABU(20)
2290 NERR=0
2291 DO 180 IEV=1,500
2292
2293C...Reset parameter values. Switch on some nonstandard features.
2294 MSTJ(1)=1
2295 MSTJ(3)=0
2296 MSTJ(11)=1
2297 MSTJ(42)=2
2298 MSTJ(43)=4
2299 MSTJ(44)=2
2300 PARJ(17)=0.1D0
2301 PARJ(22)=1.5D0
2302 PARJ(43)=1D0
2303 PARJ(54)=-0.05D0
2304 MSTJ(101)=5
2305 MSTJ(104)=5
2306 MSTJ(105)=0
2307 MSTJ(107)=1
2308 IF(IEV.EQ.301.OR.IEV.EQ.351.OR.IEV.EQ.401) MSTJ(116)=3
2309
2310C...Ten events each for some single jets configurations.
2311 IF(IEV.LE.50) THEN
2312 ITY=(IEV+9)/10
2313 MSTJ(3)=-1
2314 IF(ITY.EQ.3.OR.ITY.EQ.4) MSTJ(11)=2
2315 IF(ITY.EQ.1) CALL PY1ENT(1,1,15D0,0D0,0D0)
2316 IF(ITY.EQ.2) CALL PY1ENT(1,3101,15D0,0D0,0D0)
2317 IF(ITY.EQ.3) CALL PY1ENT(1,-2203,15D0,0D0,0D0)
2318 IF(ITY.EQ.4) CALL PY1ENT(1,-4,30D0,0D0,0D0)
2319 IF(ITY.EQ.5) CALL PY1ENT(1,21,15D0,0D0,0D0)
2320
2321C...Ten events each for some simple jet systems; string fragmentation.
2322 ELSEIF(IEV.LE.130) THEN
2323 ITY=(IEV-41)/10
2324 IF(ITY.EQ.1) CALL PY2ENT(1,1,-1,40D0)
2325 IF(ITY.EQ.2) CALL PY2ENT(1,4,-4,30D0)
2326 IF(ITY.EQ.3) CALL PY2ENT(1,2,2103,100D0)
2327 IF(ITY.EQ.4) CALL PY2ENT(1,21,21,40D0)
2328 IF(ITY.EQ.5) CALL PY3ENT(1,2101,21,-3203,30D0,0.6D0,0.8D0)
2329 IF(ITY.EQ.6) CALL PY3ENT(1,5,21,-5,40D0,0.9D0,0.8D0)
2330 IF(ITY.EQ.7) CALL PY3ENT(1,21,21,21,60D0,0.7D0,0.5D0)
2331 IF(ITY.EQ.8) CALL PY4ENT(1,2,21,21,-2,40D0,
2332 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2333
2334C...Seventy events with independent fragmentation and momentum cons.
2335 ELSEIF(IEV.LE.200) THEN
2336 ITY=1+(IEV-131)/16
2337 MSTJ(2)=1+MOD(IEV-131,4)
2338 MSTJ(3)=1+MOD((IEV-131)/4,4)
2339 IF(ITY.EQ.1) CALL PY2ENT(1,4,-5,40D0)
2340 IF(ITY.EQ.2) CALL PY3ENT(1,3,21,-3,40D0,0.9D0,0.4D0)
2341 IF(ITY.EQ.3) CALL PY4ENT(1,2,21,21,-2,40D0,
2342 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2343 IF(ITY.GE.4) CALL PY4ENT(1,2,-3,3,-2,40D0,
2344 & 0.4D0,0.64D0,0.6D0,0.12D0,0.2D0)
2345
2346C...A hundred events with random jets (check invariant mass).
2347 ELSEIF(IEV.LE.300) THEN
2348 100 DO 110 J=1,5
2349 PSUM(J)=0D0
2350 110 CONTINUE
2351 NJET=2D0+6D0*PYR(0)
2352 DO 130 I=1,NJET
2353 KFL=21
2354 IF(I.EQ.1) KFL=INT(1D0+4D0*PYR(0))
2355 IF(I.EQ.NJET) KFL=-INT(1D0+4D0*PYR(0))
2356 EJET=5D0+20D0*PYR(0)
2357 THETA=ACOS(2D0*PYR(0)-1D0)
2358 PHI=6.2832D0*PYR(0)
2359 IF(I.LT.NJET) CALL PY1ENT(-I,KFL,EJET,THETA,PHI)
2360 IF(I.EQ.NJET) CALL PY1ENT(I,KFL,EJET,THETA,PHI)
2361 IF(I.EQ.1.OR.I.EQ.NJET) MSTJ(93)=1
2362 IF(I.EQ.1.OR.I.EQ.NJET) PSUM(5)=PSUM(5)+PYMASS(KFL)
2363 DO 120 J=1,4
2364 PSUM(J)=PSUM(J)+P(I,J)
2365 120 CONTINUE
2366 130 CONTINUE
2367 IF(PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2.LT.
2368 & (PSUM(5)+PARJ(32))**2) GOTO 100
2369
2370C...Fifty e+e- continuum events with matrix elements.
2371 ELSEIF(IEV.LE.350) THEN
2372 MSTJ(101)=2
2373 CALL PYEEVT(0,40D0)
2374
2375C...Fifty e+e- continuum event with varying shower options.
2376 ELSEIF(IEV.LE.400) THEN
2377 MSTJ(42)=1+MOD(IEV,2)
2378 MSTJ(43)=1+MOD(IEV/2,4)
2379 MSTJ(44)=MOD(IEV/8,3)
2380 CALL PYEEVT(0,90D0)
2381
2382C...Fifty e+e- continuum events with coherent shower.
2383 ELSEIF(IEV.LE.450) THEN
2384 CALL PYEEVT(0,500D0)
2385
2386C...Fifty Upsilon decays to ggg or gammagg with coherent shower.
2387 ELSE
2388 CALL PYONIA(5,9.46D0)
2389 ENDIF
2390
2391C...Generate event. Find total momentum, energy and charge.
2392 DO 140 J=1,4
2393 PINI(J)=PYP(0,J)
2394 140 CONTINUE
2395 PINI(6)=PYP(0,6)
2396 CALL PYEXEC
2397 DO 150 J=1,4
2398 PFIN(J)=PYP(0,J)
2399 150 CONTINUE
2400 PFIN(6)=PYP(0,6)
2401
2402C...Check conservation of energy, momentum and charge;
2403C...usually exact, but only approximate for single jets.
2404 MERR=0
2405 IF(IEV.LE.50) THEN
2406 IF((PFIN(1)-PINI(1))**2+(PFIN(2)-PINI(2))**2.GE.10D0)
2407 & MERR=MERR+1
2408 EPZREM=PINI(4)+PINI(3)-PFIN(4)-PFIN(3)
2409 IF(EPZREM.LT.0D0.OR.EPZREM.GT.2D0*PARJ(31)) MERR=MERR+1
2410 IF(ABS(PFIN(6)-PINI(6)).GT.2.1D0) MERR=MERR+1
2411 ELSE
2412 DO 160 J=1,4
2413 IF(ABS(PFIN(J)-PINI(J)).GT.0.0001D0*PINI(4)) MERR=MERR+1
2414 160 CONTINUE
2415 IF(ABS(PFIN(6)-PINI(6)).GT.0.1D0) MERR=MERR+1
2416 ENDIF
2417 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2418 & (PFIN(J),J=1,4),PFIN(6)
2419
2420C...Check that all KF codes are known ones, and that partons/particles
2421C...satisfy energy-momentum-mass relation. Store particle statistics.
2422 DO 170 I=1,N
2423 IF(K(I,1).GT.20) GOTO 170
2424 IF(PYCOMP(K(I,2)).EQ.0) THEN
2425 WRITE(MSTU(11),5100) I
2426 MERR=MERR+1
2427 ENDIF
2428 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
2429 IF(ABS(PD).GT.MAX(0.1D0,0.001D0*P(I,4)**2).OR.P(I,4).LT.0D0)
2430 & THEN
2431 WRITE(MSTU(11),5200) I
2432 MERR=MERR+1
2433 ENDIF
2434 170 CONTINUE
2435 IF(MTEST.GE.1) CALL PYTABU(21)
2436
2437C...List all erroneous events and some normal ones.
2438 IF(MERR.NE.0.OR.MSTU(24).NE.0.OR.MSTU(28).NE.0) THEN
2439 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2440 CALL PYLIST(2)
2441 ELSEIF(MTEST.GE.1.AND.MOD(IEV-5,100).EQ.0) THEN
2442 CALL PYLIST(1)
2443 ENDIF
2444
2445C...Stop execution if too many errors.
2446 IF(MERR.NE.0) NERR=NERR+1
2447 IF(NERR.GE.10) THEN
2448 WRITE(MSTU(11),6300)
2449 CALL PYLIST(1)
2450 CALL PYSTOP(9)
2451 ENDIF
2452 180 CONTINUE
2453
2454C...Summarize result of run.
2455 IF(MTEST.GE.1) CALL PYTABU(22)
2456
2457C...Reset commonblock variables changed during run.
2458 MSTJ(1)=MSTJ1
2459 MSTJ(3)=MSTJ3
2460 MSTJ(11)=MSTJ11
2461 MSTJ(42)=MSTJ42
2462 MSTJ(43)=MSTJ43
2463 MSTJ(44)=MSTJ44
2464 PARJ(17)=PARJ17
2465 PARJ(22)=PARJ22
2466 PARJ(43)=PARJ43
2467 PARJ(54)=PARJ54
2468 MSTJ(101)=MST101
2469 MSTJ(104)=MST104
2470 MSTJ(105)=MST105
2471 MSTJ(107)=MST107
2472 MSTJ(116)=MST116
2473
2474C...Second part: complete events of various kinds.
2475C...Common initial values. Loop over initiating conditions.
2476 MSTP(122)=MAX(0,MIN(2,MTEST))
2477 MDCY(PYCOMP(111),1)=0
2478 DO 230 IPROC=1,8
2479
2480C...Reset process type, kinematics cuts, and the flags used.
2481 MSEL=0
2482 DO 190 ISUB=1,500
2483 MSUB(ISUB)=0
2484 190 CONTINUE
2485 CKIN(1)=2D0
2486 CKIN(3)=0D0
2487 MSTP(2)=1
2488 MSTP(11)=0
2489 MSTP(33)=0
2490 MSTP(81)=1
2491 MSTP(82)=1
2492 MSTP(111)=1
2493 MSTP(131)=0
2494 MSTP(133)=0
2495 PARP(131)=0.01D0
2496
2497C...Prompt photon production at fixed target.
2498 IF(IPROC.EQ.1) THEN
2499 PZSUM=300D0
2500 PESUM=SQRT(PZSUM**2+PYMASS(211)**2)+PYMASS(2212)
2501 PQSUM=2D0
2502 MSEL=10
2503 CKIN(3)=5D0
2504 CALL PYINIT('FIXT','pi+','p',PZSUM)
2505
2506C...QCD processes at ISR energies.
2507 ELSEIF(IPROC.EQ.2) THEN
2508 PESUM=63D0
2509 PZSUM=0D0
2510 PQSUM=2D0
2511 MSEL=1
2512 CKIN(3)=5D0
2513 CALL PYINIT('CMS','p','p',PESUM)
2514
2515C...W production + multiple interactions at CERN Collider.
2516 ELSEIF(IPROC.EQ.3) THEN
2517 PESUM=630D0
2518 PZSUM=0D0
2519 PQSUM=0D0
2520 MSEL=12
2521 CKIN(1)=20D0
2522 MSTP(82)=4
2523 MSTP(2)=2
2524 MSTP(33)=3
2525 CALL PYINIT('CMS','p','pbar',PESUM)
2526
2527C...W/Z gauge boson pairs + pileup events at the Tevatron.
2528 ELSEIF(IPROC.EQ.4) THEN
2529 PESUM=1800D0
2530 PZSUM=0D0
2531 PQSUM=0D0
2532 MSUB(22)=1
2533 MSUB(23)=1
2534 MSUB(25)=1
2535 CKIN(1)=200D0
2536 MSTP(111)=0
2537 MSTP(131)=1
2538 MSTP(133)=2
2539 PARP(131)=0.04D0
2540 CALL PYINIT('CMS','p','pbar',PESUM)
2541
2542C...Higgs production at LHC.
2543 ELSEIF(IPROC.EQ.5) THEN
2544 PESUM=15400D0
2545 PZSUM=0D0
2546 PQSUM=2D0
2547 MSUB(3)=1
2548 MSUB(102)=1
2549 MSUB(123)=1
2550 MSUB(124)=1
2551 PMAS(25,1)=300D0
2552 CKIN(1)=200D0
2553 MSTP(81)=0
2554 MSTP(111)=0
2555 CALL PYINIT('CMS','p','p',PESUM)
2556
2557C...Z' production at SSC.
2558 ELSEIF(IPROC.EQ.6) THEN
2559 PESUM=40000D0
2560 PZSUM=0D0
2561 PQSUM=2D0
2562 MSEL=21
2563 PMAS(32,1)=600D0
2564 CKIN(1)=400D0
2565 MSTP(81)=0
2566 MSTP(111)=0
2567 CALL PYINIT('CMS','p','p',PESUM)
2568
2569C...W pair production at 1 TeV e+e- collider.
2570 ELSEIF(IPROC.EQ.7) THEN
2571 PESUM=1000D0
2572 PZSUM=0D0
2573 PQSUM=0D0
2574 MSUB(25)=1
2575 MSUB(69)=1
2576 MSTP(11)=1
2577 CALL PYINIT('CMS','e+','e-',PESUM)
2578
2579C...Deep inelastic scattering at a LEP+LHC ep collider.
2580 ELSEIF(IPROC.EQ.8) THEN
2581 P(1,1)=0D0
2582 P(1,2)=0D0
2583 P(1,3)=8000D0
2584 P(2,1)=0D0
2585 P(2,2)=0D0
2586 P(2,3)=-80D0
2587 PESUM=8080D0
2588 PZSUM=7920D0
2589 PQSUM=0D0
2590 MSUB(10)=1
2591 CKIN(3)=50D0
2592 MSTP(111)=0
2593 CALL PYINIT('3MOM','p','e-',PESUM)
2594 ENDIF
2595
2596C...Generate 20 events of each required type.
2597 DO 220 IEV=1,20
2598 CALL PYEVNT
2599 PESUMM=PESUM
2600 IF(IPROC.EQ.4) PESUMM=MSTI(41)*PESUM
2601
2602C...Check conservation of energy/momentum/flavour.
2603 PINI(1)=0D0
2604 PINI(2)=0D0
2605 PINI(3)=PZSUM
2606 PINI(4)=PESUMM
2607 PINI(6)=PQSUM
2608 DO 200 J=1,4
2609 PFIN(J)=PYP(0,J)
2610 200 CONTINUE
2611 PFIN(6)=PYP(0,6)
2612 MERR=0
2613 DEVE=ABS(PFIN(4)-PINI(4))+ABS(PFIN(3)-PINI(3))
2614 DEVT=ABS(PFIN(1)-PINI(1))+ABS(PFIN(2)-PINI(2))
2615 DEVQ=ABS(PFIN(6)-PINI(6))
2616 IF(DEVE.GT.2D-3*PESUM.OR.DEVT.GT.MAX(0.01D0,1D-4*PESUM).OR.
2617 & DEVQ.GT.0.1D0) MERR=1
2618 IF(MERR.NE.0) WRITE(MSTU(11),5000) (PINI(J),J=1,4),PINI(6),
2619 & (PFIN(J),J=1,4),PFIN(6)
2620
2621C...Check that all KF codes are known ones, and that partons/particles
2622C...satisfy energy-momentum-mass relation.
2623 DO 210 I=1,N
2624 IF(K(I,1).GT.20) GOTO 210
2625 IF(PYCOMP(K(I,2)).EQ.0) THEN
2626 WRITE(MSTU(11),5100) I
2627 MERR=MERR+1
2628 ENDIF
2629 PD=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2*
2630 & SIGN(1D0,P(I,5))
2631 IF(ABS(PD).GT.MAX(0.1D0,0.002D0*P(I,4)**2,0.002D0*P(I,5)**2)
2632 & .OR.(P(I,5).GE.0D0.AND.P(I,4).LT.0D0)) THEN
2633 WRITE(MSTU(11),5200) I
2634 MERR=MERR+1
2635 ENDIF
2636 210 CONTINUE
2637
2638C...Listing of erroneous events, and first event of each type.
2639 IF(MERR.GE.1) NERR=NERR+1
2640 IF(NERR.GE.10) THEN
2641 WRITE(MSTU(11),6300)
2642 CALL PYLIST(1)
2643 CALL PYSTOP(9)
2644 ENDIF
2645 IF(MTEST.GE.1.AND.(MERR.GE.1.OR.IEV.EQ.1)) THEN
2646 IF(MERR.GE.1) WRITE(MSTU(11),6400)
2647 CALL PYLIST(1)
2648 ENDIF
2649 220 CONTINUE
2650
2651C...List statistics for each process type.
2652 IF(MTEST.GE.1) CALL PYSTAT(1)
2653 230 CONTINUE
2654
2655C...Summarize result of run.
2656 IF(NERR.EQ.0) WRITE(MSTU(11),6500)
2657 IF(NERR.GT.0) WRITE(MSTU(11),6600) NERR
2658
2659C...Format statements for output.
2660 5000 FORMAT(/' Momentum, energy and/or charge were not conserved ',
2661 &'in following event'/' sum of',9X,'px',11X,'py',11X,'pz',11X,
2662 &'E',8X,'charge'/' before',2X,4(1X,F12.5),1X,F8.2/' after',3X,
2663 &4(1X,F12.5),1X,F8.2)
2664 5100 FORMAT(/5X,'Entry no.',I4,' in following event not known code')
2665 5200 FORMAT(/5X,'Entry no.',I4,' in following event has faulty ',
2666 &'kinematics')
2667 6300 FORMAT(/5X,'This is the tenth error experienced! Something is ',
2668 &'wrong.'/5X,'Execution will be stopped after listing of event.')
2669 6400 FORMAT(5X,'Faulty event follows:')
2670 6500 FORMAT(//5X,'End result of PYTEST: no errors detected.')
2671 6600 FORMAT(//5X,'End result of PYTEST:',I2,' errors detected.'/
2672 &5X,'This should not have happened!')
2673
2674 RETURN
2675 END
2676
2677C*********************************************************************
2678
2679C...PYHEPC
2680C...Converts PYTHIA event record contents to or from
2681C...the standard event record commonblock.
2682
2683 SUBROUTINE PYHEPC(MCONV)
2684
2685C...Double precision and integer declarations.
2686 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2687 IMPLICIT INTEGER(I-N)
2688 INTEGER PYK,PYCHGE,PYCOMP
2689C...Commonblocks.
2690 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
2691 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2692 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2693 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
2694C...HEPEVT commonblock.
2695 PARAMETER (NMXHEP=4000)
2696 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
2697 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
2698 DOUBLE PRECISION PHEP,VHEP
2699 SAVE /HEPEVT/
2700
2701C...Store HEPEVT commonblock size (for interfacing issues).
2702 MSTU(8)=NMXHEP
2703
2704C...Initialize variable(s)
2705 INEW = 1
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) THEN
2805 K(I,1)=11
2806 IF(K(I,4).GT.0.AND.(K(I,4).EQ.K(I,5)).AND.
2807 $ (K(K(I,4),2).GE.91.AND.K(K(I,4),2).LE.93).AND.
2808 $ (I.LT.N).AND.(K(I,4).EQ.K(I+1,4))) K(I,1)=12
2809 ENDIF
2810 IF(ISTHEP(I).EQ.3) K(I,1)=21
2811 K(I,2)=IDHEP(I)
2812 K(I,3)=JMOHEP(1,I)
2813 K(I,4)=JDAHEP(1,I)
2814 K(I,5)=JDAHEP(2,I)
2815 DO 170 J=1,5
2816 P(I,J)=PHEP(J,I)
2817 170 CONTINUE
2818 DO 180 J=1,4
2819 V(I,J)=VHEP(J,I)
2820 180 CONTINUE
2821 V(I,5)=0D0
2822 IF(ISTHEP(I).EQ.2.AND.PHEP(4,I).GT.PHEP(5,I)) THEN
2823 I1=JDAHEP(1,I)
2824 IF(I1.GT.0.AND.I1.LE.NHEP) V(I,5)=(VHEP(4,I1)-VHEP(4,I))*
2825 & PHEP(5,I)/PHEP(4,I)
2826 ENDIF
2827
2828C...Fill in missing information on colour connection in jet systems.
2829 IF(ISTHEP(I).EQ.1) THEN
2830 KC=PYCOMP(K(I,2))
2831 KQ=0
2832 IF(KC.NE.0) KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
2833 IF(KQ.NE.0) NKQ=NKQ+1
2834 IF(KQ.NE.2) KQSUM=KQSUM+KQ
2835 IF(KQ.NE.0.AND.KQSUM.NE.0) THEN
2836 K(I,1)=2
2837 ELSEIF(KQ.EQ.2.AND.I.LT.N) THEN
2838 IF(K(I+1,2).EQ.21) K(I,1)=2
2839 ENDIF
2840 ENDIF
2841 190 CONTINUE
2842 IF(NKQ.EQ.1.OR.KQSUM.NE.0) CALL PYERRM(8,
2843 & '(PYHEPC:) input parton configuration not colour singlet')
2844 ENDIF
2845
2846 END
2847
2848C*********************************************************************
2849
2850C...PYINIT
2851C...Initializes the generation procedure; finds maxima of the
2852C...differential cross-sections to be used for weighting.
2853
2854 SUBROUTINE PYINIT(FRAME,BEAM,TARGET,WIN)
2855
2856C...Double precision and integer declarations.
2857 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
2858 IMPLICIT INTEGER(I-N)
2859 INTEGER PYK,PYCHGE,PYCOMP
2860C...Commonblocks.
2861 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
2862 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
2863 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
2864 COMMON/PYDAT4/CHAF(500,2)
2865 CHARACTER CHAF*16
2866 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
2867 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
2868 COMMON/PYINT1/MINT(400),VINT(400)
2869 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
2870 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
2871 COMMON/PYPUED/IUED(0:99),RUED(0:99)
2872 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
2873 &/PYINT1/,/PYINT2/,/PYINT5/,/PYPUED/
2874C...Local arrays and character variables.
2875 DIMENSION ALAMIN(20),NFIN(20)
2876 CHARACTER*(*) FRAME,BEAM,TARGET
2877 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHLH(2)*6
2878
2879C...Interface to PDFLIB.
6cd66bd2 2880 COMMON/W50511/NPTYPEPDFL,NGROUPPDFL,NSETPDFL,MODEPDFL,NFLPDFL,LOPDFL,TMASPDFL
8ff9ce7d 2881 COMMON/LW50512/QCDL4,QCDL5
2882 SAVE /W50511/,/LW50512/
92e27c01 2883 DOUBLE PRECISION VALUE(20),TMAS,QCDL4,QCDL5
2884 CHARACTER*20 PARM(20)
2885 DATA VALUE/20*0D0/,PARM/20*' '/
2886
2887C...Data:Lambda and n_f values for parton distributions..
2888 DATA ALAMIN/0.177D0,0.239D0,0.247D0,0.2322D0,0.248D0,0.248D0,
2889 &0.192D0,0.326D0,2*0.2D0,0.2D0,0.2D0,0.29D0,0.2D0,0.4D0,5*0.2D0/,
2890 &NFIN/20*4/
2891 DATA CHLH/'lepton','hadron'/
2892
2893C...Check that BLOCK DATA PYDATA has been loaded.
2894 CALL PYCKBD
2895
2896C...Reset MINT and VINT arrays. Write headers.
2897 MSTI(53)=0
2898 DO 100 J=1,400
2899 MINT(J)=0
2900 VINT(J)=0D0
2901 100 CONTINUE
2902 IF(MSTU(12).NE.12345) CALL PYLIST(0)
2903 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
2904
2905C...Reset error counters.
2906 MSTU(23)=0
2907 MSTU(27)=0
2908 MSTU(30)=0
2909
2910C...Reset processes that should not be on.
2911 MSUB(96)=0
2912 MSUB(97)=0
2913
2914C...Select global FSR/ISR/UE parameter set = 'tune'
2915C...See routine PYTUNE for details
2916 IF (MSTP(5).NE.0) THEN
2917 MSTP5=MSTP(5)
2918 CALL PYTUNE(MSTP5)
2919 ENDIF
2920
2921C...Call user process initialization routine.
2922 IF(FRAME(1:1).EQ.'u'.OR.FRAME(1:1).EQ.'U') THEN
2923 MSEL=0
2924 CALL UPINIT
2925 MSEL=0
2926 ENDIF
2927
2928C...Maximum 4 generations; set maximum number of allowed flavours.
2929 MSTP(1)=MIN(4,MSTP(1))
2930 MSTU(114)=MIN(MSTU(114),2*MSTP(1))
2931 MSTP(58)=MIN(MSTP(58),2*MSTP(1))
2932
2933C...Sum up Cabibbo-Kobayashi-Maskawa factors for each quark/lepton.
2934 DO 120 I=-20,20
2935 VINT(180+I)=0D0
2936 IA=IABS(I)
2937 IF(IA.GE.1.AND.IA.LE.2*MSTP(1)) THEN
2938 DO 110 J=1,MSTP(1)
2939 IB=2*J-1+MOD(IA,2)
2940 IF(IB.GE.6.AND.MSTP(9).EQ.0) GOTO 110
2941 IPM=(5-ISIGN(1,I))/2
2942 IDC=J+MDCY(IA,2)+2
2943 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) VINT(180+I)=
2944 & VINT(180+I)+VCKM((IA+1)/2,(IB+1)/2)
2945 110 CONTINUE
2946 ELSEIF(IA.GE.11.AND.IA.LE.10+2*MSTP(1)) THEN
2947 VINT(180+I)=1D0
2948 ENDIF
2949 120 CONTINUE
2950
2951C...Initialize parton distributions: PDFLIB.
2952 IF(MSTP(52).EQ.2) THEN
2953 PARM(1)='NPTYPE'
2954 VALUE(1)=1
2955 PARM(2)='NGROUP'
2956 VALUE(2)=MSTP(51)/1000
2957 PARM(3)='NSET'
2958 VALUE(3)=MOD(MSTP(51),1000)
2959 PARM(4)='TMAS'
2960 VALUE(4)=PMAS(6,1)
2961 CALL PDFSET_ALICE(PARM,VALUE)
2962 MINT(93)=1000000+MSTP(51)
2963 ENDIF
2964
2965C...Choose Lambda value to use in alpha-strong.
2966 MSTU(111)=MSTP(2)
2967 IF(MSTP(3).GE.2) THEN
2968 ALAM=0.2D0
2969 NF=4
2970 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
2971 ALAM=ALAMIN(MSTP(51))
2972 NF=NFIN(MSTP(51))
2973 ELSEIF(MSTP(52).EQ.2.AND.NFL.EQ.5) THEN
2974 ALAM=QCDL5
2975 NF=5
2976 ELSEIF(MSTP(52).EQ.2) THEN
2977 ALAM=QCDL4
2978 NF=4
2979 ENDIF
2980 PARP(1)=ALAM
2981 PARP(61)=ALAM
2982 PARP(72)=ALAM
2983 PARU(112)=ALAM
2984 MSTU(112)=NF
2985 IF(MSTP(3).EQ.3) PARJ(81)=ALAM
2986 ENDIF
2987
2988C...Initialize the UED masses and widths
2989 IF (IUED(1).EQ.1) CALL PYXDIN
2990
2991C...Initialize the SUSY generation: couplings, masses,
2992C...decay modes, branching ratios, and so on.
2993 CALL PYMSIN
2994C...Initialize widths and partial widths for resonances.
2995 CALL PYINRE
2996C...Set Z0 mass and width for e+e- routines.
2997 PARJ(123)=PMAS(23,1)
2998 PARJ(124)=PMAS(23,2)
2999
3000C...Identify beam and target particles and frame of process.
3001 CHFRAM=FRAME//' '
3002 CHBEAM=BEAM//' '
3003 CHTARG=TARGET//' '
3004 CALL PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
3005 IF(MINT(65).EQ.1) GOTO 170
3006
3007C...For gamma-p or gamma-gamma allow many (3 or 6) alternatives.
3008C...For e-gamma allow 2 alternatives.
3009 MINT(121)=1
3010 IF(MSTP(14).EQ.10.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3011 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3012 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
3013 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=6
3014 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3015 & (IABS(MINT(11)).EQ.11.OR.IABS(MINT(12)).EQ.11)) MINT(121)=2
3016 ELSEIF(MSTP(14).EQ.20.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3017 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3018 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=3
3019 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=9
3020 ELSEIF(MSTP(14).EQ.25.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3021 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3022 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=2
3023 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=4
3024 ELSEIF(MSTP(14).EQ.30.AND.(MSEL.EQ.1.OR.MSEL.EQ.2)) THEN
3025 IF((MINT(11).EQ.22.OR.MINT(12).EQ.22).AND.
3026 & (IABS(MINT(11)).GT.100.OR.IABS(MINT(12)).GT.100)) MINT(121)=4
3027 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) MINT(121)=13
3028 ENDIF
3029 MINT(123)=MSTP(14)
3030 IF((MSTP(14).EQ.10.OR.MSTP(14).EQ.20.OR.MSTP(14).EQ.25.OR.
3031 &MSTP(14).EQ.30).AND.MSEL.NE.1.AND.MSEL.NE.2) MINT(123)=0
3032 IF(MSTP(14).GE.11.AND.MSTP(14).LE.19) THEN
3033 IF(MSTP(14).EQ.11) MINT(123)=0
3034 IF(MSTP(14).EQ.12.OR.MSTP(14).EQ.14) MINT(123)=5
3035 IF(MSTP(14).EQ.13.OR.MSTP(14).EQ.17) MINT(123)=6
3036 IF(MSTP(14).EQ.15) MINT(123)=2
3037 IF(MSTP(14).EQ.16.OR.MSTP(14).EQ.18) MINT(123)=7
3038 IF(MSTP(14).EQ.19) MINT(123)=3
3039 ELSEIF(MSTP(14).GE.21.AND.MSTP(14).LE.24) THEN
3040 IF(MSTP(14).EQ.21) MINT(123)=0
3041 IF(MSTP(14).EQ.22.OR.MSTP(14).EQ.23) MINT(123)=4
3042 IF(MSTP(14).EQ.24) MINT(123)=1
3043 ELSEIF(MSTP(14).GE.26.AND.MSTP(14).LE.29) THEN
3044 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28) MINT(123)=8
3045 IF(MSTP(14).EQ.27.OR.MSTP(14).EQ.29) MINT(123)=9
3046 ENDIF
3047
3048C...Set up kinematics of process.
3049 CALL PYINKI(0)
3050
3051C...Set up kinematics for photons inside leptons.
3052 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(1,WTGAGA)
3053
3054C...Precalculate flavour selection weights.
3055 CALL PYKFIN
3056
3057C...Loop over gamma-p or gamma-gamma alternatives.
3058 CKIN3=CKIN(3)
3059 MSAV48=0
3060 DO 160 IGA=1,MINT(121)
3061 CKIN(3)=CKIN3
3062 MINT(122)=IGA
3063
3064C...Select partonic subprocesses to be included in the simulation.
3065 CALL PYINPR
3066 MINT(101)=1
3067 MINT(102)=1
3068 MINT(103)=MINT(11)
3069 MINT(104)=MINT(12)
3070
3071C...Count number of subprocesses on.
3072 MINT(48)=0
3073 DO 130 ISUB=1,500
3074 IF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
3075 & MSUB(ISUB).EQ.1.AND.MINT(121).GT.1) THEN
3076 MSUB(ISUB)=0
3077 ELSEIF(MINT(50).EQ.0.AND.ISUB.GE.91.AND.ISUB.LE.96.AND.
3078 & MSUB(ISUB).EQ.1) THEN
3079 WRITE(MSTU(11),5200) ISUB,CHLH(MINT(41)),CHLH(MINT(42))
3080 CALL PYSTOP(1)
3081 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).EQ.-1) THEN
3082 WRITE(MSTU(11),5300) ISUB
3083 CALL PYSTOP(1)
3084 ELSEIF(MSUB(ISUB).EQ.1.AND.ISET(ISUB).LE.-2) THEN
3085 WRITE(MSTU(11),5400) ISUB
3086 CALL PYSTOP(1)
3087 ELSEIF(MSUB(ISUB).EQ.1) THEN
3088 MINT(48)=MINT(48)+1
3089 ENDIF
3090 130 CONTINUE
3091
3092C...Stop or raise warning flag if no subprocesses on.
3093 IF(MINT(121).EQ.1.AND.MINT(48).EQ.0) THEN
3094 IF(MSTP(127).NE.1) THEN
3095 WRITE(MSTU(11),5500)
3096 CALL PYSTOP(1)
3097 ELSE
3098 WRITE(MSTU(11),5700)
3099 MSTI(53)=1
3100 ENDIF
3101 ENDIF
3102 MINT(49)=MINT(48)-MSUB(91)-MSUB(92)-MSUB(93)-MSUB(94)
3103 MSAV48=MSAV48+MINT(48)
3104
3105C...Reset variables for cross-section calculation.
3106 DO 150 I=0,500
3107 DO 140 J=1,3
3108 NGEN(I,J)=0
3109 XSEC(I,J)=0D0
3110 140 CONTINUE
3111 150 CONTINUE
3112
3113C...Find parametrized total cross-sections.
3114 CALL PYXTOT
3115 VINT(318)=VINT(317)
3116
3117C...Maxima of differential cross-sections.
3118 IF(MSTP(121).LE.1) CALL PYMAXI
3119
3120C...Initialize possibility of pileup events.
3121 IF(MINT(121).GT.1) MSTP(131)=0
3122 IF(MSTP(131).NE.0) CALL PYPILE(1)
3123
3124C...Initialize multiple interactions with variable impact parameter.
3125 IF(MINT(50).EQ.1) THEN
3126 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
3127 IF(MOD(MSTP(81),10).EQ.0.AND.(CKIN(3).GT.PTMN.OR.
3128 & ((MSEL.NE.1.AND.MSEL.NE.2)))) MSTP(82)=MIN(1,MSTP(82))
3129 IF((MINT(49).NE.0.OR.MSTP(131).NE.0).AND.MSTP(82).GE.2) THEN
3130 MINT(35)=1
3131 CALL PYMULT(1)
3132 MINT(35)=3
3133 CALL PYMIGN(1)
3134 ENDIF
3135 ENDIF
3136
3137C...Save results for gamma-p and gamma-gamma alternatives.
3138 IF(MINT(121).GT.1) CALL PYSAVE(1,IGA)
3139 160 CONTINUE
3140
3141C...Initialization finished.
3142 IF(MSAV48.EQ.0) THEN
3143 IF(MSTP(127).NE.1) THEN
3144 WRITE(MSTU(11),5500)
3145 CALL PYSTOP(1)
3146 ELSE
3147 WRITE(MSTU(11),5700)
3148 MSTI(53)=1
3149 ENDIF
3150 ENDIF
3151 170 IF(MSTP(122).GE.1) WRITE(MSTU(11),5600)
3152
3153C...Formats for initialization information.
3154 5100 FORMAT('1',18('*'),1X,'PYINIT: initialization of PYTHIA ',
3155 &'routines',1X,17('*'))
3156 5200 FORMAT(1X,'Error: process number ',I3,' not meaningful for ',A6,
3157 &'-',A6,' interactions.'/1X,'Execution stopped!')
3158 5300 FORMAT(1X,'Error: requested subprocess',I4,' not implemented.'/
3159 &1X,'Execution stopped!')
3160 5400 FORMAT(1X,'Error: requested subprocess',I4,' not existing.'/
3161 &1X,'Execution stopped!')
3162 5500 FORMAT(1X,'Error: no subprocess switched on.'/
3163 &1X,'Execution stopped.')
3164 5600 FORMAT(/1X,22('*'),1X,'PYINIT: initialization completed',1X,
3165 &22('*'))
3166 5700 FORMAT(1X,'Error: no subprocess switched on.'/
3167 &1X,'Execution will stop if you try to generate events.')
3168
3169 RETURN
3170 END
3171
3172C*********************************************************************
3173
3174C...PYEVNT
3175C...Administers the generation of a high-pT event via calls to
3176C...a number of subroutines.
3177
3178 SUBROUTINE PYEVNT
3179
3180C...Double precision and integer declarations.
3181 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3182 IMPLICIT INTEGER(I-N)
3183 INTEGER PYK,PYCHGE,PYCOMP
3184 PARAMETER (MAXNUR=1000)
3185C...Commonblocks.
3186 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
3187 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3188 COMMON/PYCTAG/NCT,MCT(4000,2)
3189 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3190 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3191 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3192 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3193 COMMON/PYINT1/MINT(400),VINT(400)
3194 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3195 COMMON/PYINT4/MWID(500),WIDS(500,5)
3196 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3197 SAVE /PYJETS/,/PYDAT1/,/PYCTAG/,/PYDAT2/,/PYDAT3/,/PYPARS/,
3198 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/
3199C...Local array.
3200 DIMENSION VTX(4)
3201
3202C...Optionally let PYEVNW do the whole job.
3203 IF(MSTP(81).GE.20) THEN
3204 CALL PYEVNW
3205 RETURN
3206 ENDIF
3207
3208C...Stop if no subprocesses on.
3209 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3210 WRITE(MSTU(11),5100)
3211 CALL PYSTOP(1)
3212 ENDIF
3213
3214C...Initial values for some counters.
3215 MSTU(1)=0
3216 MSTU(2)=0
3217 N=0
3218 MINT(5)=MINT(5)+1
3219 MINT(7)=0
3220 MINT(8)=0
3221 MINT(30)=0
3222 MINT(83)=0
3223 MINT(84)=MSTP(126)
3224 MSTU(24)=0
3225 MSTU70=0
3226 MSTJ14=MSTJ(14)
3227C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
3228 NCT=0
3229 MINT(33)=0
3230
3231C...Let called routines know call is from PYEVNT (not PYEVNW).
3232 MINT(35)=1
3233 IF (MSTP(81).GE.10) MINT(35)=2
3234
3235C...If variable energies: redo incoming kinematics and cross-section.
3236 MSTI(61)=0
3237 IF(MSTP(171).EQ.1) THEN
3238 CALL PYINKI(1)
3239 IF(MSTI(61).EQ.1) THEN
3240 MINT(5)=MINT(5)-1
3241 RETURN
3242 ENDIF
3243 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3244 CALL PYXTOT
3245 ENDIF
3246
3247C...Loop over number of pileup events; check space left.
3248 IF(MSTP(131).LE.0) THEN
3249 NPILE=1
3250 ELSE
3251 CALL PYPILE(2)
3252 NPILE=MINT(81)
3253 ENDIF
3254 DO 270 IPILE=1,NPILE
3255 IF(MINT(84)+100.GE.MSTU(4)) THEN
3256 CALL PYERRM(11,
3257 & '(PYEVNT:) no more space in PYJETS for pileup events')
3258 IF(MSTU(21).GE.1) GOTO 280
3259 ENDIF
3260 MINT(82)=IPILE
3261
3262C...Generate variables of hard scattering.
3263 MINT(51)=0
3264 MSTI(52)=0
3265 100 CONTINUE
3266 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3267 MINT(31)=0
3268 MINT(39)=0
3269 MINT(51)=0
3270 MINT(57)=0
3271 CALL PYRAND
3272 IF(MSTI(61).EQ.1) THEN
3273 MINT(5)=MINT(5)-1
3274 RETURN
3275 ENDIF
3276 IF(MINT(51).EQ.2) RETURN
3277 ISUB=MINT(1)
3278 IF(MSTP(111).EQ.-1) GOTO 260
3279
3280C...Loopback point if PYPREP fails, especially for junction topologies.
3281 NPREP=0
3282 MNT31S=MINT(31)
3283 110 NPREP=NPREP+1
3284 MINT(31)=MNT31S
3285
3286 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3287C...Hard scattering (including low-pT):
3288C...reconstruct kinematics and colour flow of hard scattering.
3289 MINT31=MINT(31)
3290 120 MINT(31)=MINT31
3291 MINT(51)=0
3292 CALL PYSCAT
3293 IF(MINT(51).EQ.1) GOTO 100
3294 IPU1=MINT(84)+1
3295 IPU2=MINT(84)+2
3296 IF(ISUB.EQ.95) GOTO 140
3297
3298C...Reset statistics on activity in event.
3299 DO 130 J=351,359
3300 MINT(J)=0
3301 VINT(J)=0D0
3302 130 CONTINUE
3303
3304C...Showering of initial state partons (optional).
3305 NFIN=N
3306 ALAMSV=PARJ(81)
3307 PARJ(81)=PARP(72)
3308 IF(MSTP(61).GE.1.AND.MINT(47).GE.2.AND.MINT(111).NE.12)
3309 & CALL PYSSPA(IPU1,IPU2)
3310 PARJ(81)=ALAMSV
3311 IF(MINT(51).EQ.1) GOTO 100
3312
3313C...pT-ordered FSR off ISR (optional, must have at least 2 partons)
3314 IF (NPART.GE.2.AND.(MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12)) THEN
3315 PTMAX=0.5*SQRT(PARP(71))*VINT(55)
3316 CALL PYPTFS(3,PTMAX,0D0,PTGEN)
3317 ENDIF
3318
3319C...Showering of final state partons (optional).
3320 ALAMSV=PARJ(81)
3321 PARJ(81)=PARP(72)
3322 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.2.AND.ISET(ISUB).LE.10)
3323 & THEN
3324 IPU3=MINT(84)+3
3325 IPU4=MINT(84)+4
3326 IF(ISET(ISUB).EQ.5) IPU4=-3
3327 QMAX=VINT(55)
3328 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3329 CALL PYSHOW(IPU3,IPU4,QMAX)
3330 ELSEIF(ISET(ISUB).EQ.11) THEN
3331 CALL PYADSH(NFIN)
3332 ENDIF
3333 PARJ(81)=ALAMSV
3334
3335C...Allow possibility for user to abort event generation.
3336 IVETO=0
3337 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO)
3338 IF(IVETO.EQ.1) GOTO 100
3339
3340C...Decay of final state resonances.
3341 MINT(32)=0
3342 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) CALL PYRESD(0)
3343 IF(MINT(51).EQ.1) GOTO 100
3344 MINT(52)=N
3345
3346
3347C...Multiple interactions - PYTHIA 6.3 intermediate style.
3348 140 IF(MSTP(81).GE.10.AND.MINT(50).EQ.1) THEN
3349 IF(ISUB.EQ.95) MINT(31)=MINT(31)+1
3350 CALL PYMIGN(6)
3351 IF(MINT(51).EQ.1) GOTO 100
3352 MINT(53)=N
3353
3354C...Beam remnant flavour and colour assignments - new scheme.
3355 CALL PYMIHK
3356 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3357 & GOTO 120
3358 IF(MINT(51).EQ.1) GOTO 100
3359
3360C...Primordial kT and beam remnant momentum sharing - new scheme.
3361 CALL PYMIRM
3362 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3363 & GOTO 120
3364 IF(MINT(51).EQ.1) GOTO 100
3365 IF(ISUB.EQ.95) MINT(31)=MINT(31)-1
3366
3367C...Multiple interactions - PYTHIA 6.2 style.
3368 ELSEIF(MINT(111).NE.12) THEN
3369 IF (MSTP(81).GE.1.AND.MINT(50).EQ.1.AND.ISUB.NE.95) THEN
3370 CALL PYMULT(6)
3371 MINT(53)=N
3372 ENDIF
3373
3374C...Hadron remnants and primordial kT.
3375 CALL PYREMN(IPU1,IPU2)
3376 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3377 & 110
3378 IF(MINT(51).EQ.1) GOTO 100
3379 ENDIF
3380
3381 ELSEIF(ISUB.NE.99) THEN
3382C...Diffractive and elastic scattering.
3383 CALL PYDIFF
3384
3385 ELSE
3386C...DIS scattering (photon flux external).
3387 CALL PYDISG
3388 IF(MINT(51).EQ.1) GOTO 100
3389 ENDIF
3390
3391C...Check that no odd resonance left undecayed.
3392 MINT(54)=N
3393 IF(MSTP(111).GE.1) THEN
3394 NFIX=N
3395 DO 150 I=MINT(84)+1,NFIX
3396 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3397 & K(I,2).NE.22) THEN
3398 KCA=PYCOMP(K(I,2))
3399 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3400 CALL PYRESD(I)
3401 IF(MINT(51).EQ.1) GOTO 100
3402 ENDIF
3403 ENDIF
3404 150 CONTINUE
3405 ENDIF
3406
3407C...Boost hadronic subsystem to overall rest frame.
3408C..(Only relevant when photon inside lepton beam.)
3409 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3410
3411C...Recalculate energies from momenta and masses (if desired).
3412 IF(MSTP(113).GE.1) THEN
3413 DO 160 I=MINT(83)+1,N
3414 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3415 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3416 160 CONTINUE
3417 NRECAL=N
3418 ENDIF
3419
3420C...Colour reconnection before string formation
3421 IF (MSTP(95).GE.2) CALL PYFSCR(MINT(84)+1)
3422
3423C...Rearrange partons along strings, check invariant mass cuts.
3424 MSTU(28)=0
3425 IF(MSTP(111).LE.0) MSTJ(14)=-1
3426 CALL PYPREP(MINT(84)+1)
3427 MSTJ(14)=MSTJ14
3428 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3429 MSTU(24)=0
3430 GOTO 100
3431 ENDIF
3432 IF (MINT(51).EQ.1.AND.NPREP.LE.5) GOTO 110
3433 IF (MINT(51).EQ.1) GOTO 100
3434 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3435 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3436 DO 190 I=MINT(84)+1,N
3437 IF(K(I,2).EQ.94) THEN
3438 DO 180 I1=I+1,MIN(N,I+10)
3439 IF(K(I1,3).EQ.I) THEN
3440 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3441 IF(K(I1,3).EQ.0) THEN
3442 DO 170 II=MINT(84)+1,I-1
3443 IF(K(II,2).EQ.K(I1,2)) THEN
3444 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3445 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3446 ENDIF
3447 170 CONTINUE
3448 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3449 ENDIF
3450 ENDIF
3451 180 CONTINUE
3452 ENDIF
3453 190 CONTINUE
3454 CALL PYEDIT(12)
3455 CALL PYEDIT(14)
3456 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3457 IF(MSTP(125).EQ.0) MINT(4)=0
3458 DO 210 I=MINT(83)+1,N
3459 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3460 DO 200 I1=I+1,N
3461 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3462 IF(K(I1,3).EQ.I) K(I,5)=I1
3463 200 CONTINUE
3464 ENDIF
3465 210 CONTINUE
3466 ENDIF
3467
3468C...Introduce separators between sections in PYLIST event listing.
3469 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3470 MSTU70=1
3471 MSTU(71)=N
3472 ELSEIF(IPILE.EQ.1) THEN
3473 MSTU70=3
3474 MSTU(71)=2
3475 MSTU(72)=MINT(4)
3476 MSTU(73)=N
3477 ENDIF
3478
3479C...Go back to lab frame (needed for vertices, also in fragmentation).
3480 CALL PYFRAM(1)
3481
3482C...Set nonvanishing production vertex (optional).
3483 IF(MSTP(151).EQ.1) THEN
3484 DO 220 J=1,4
3485 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3486 & SIN(PARU(2)*PYR(0))
3487 220 CONTINUE
3488 DO 240 I=MINT(83)+1,N
3489 DO 230 J=1,4
3490 V(I,J)=V(I,J)+VTX(J)
3491 230 CONTINUE
3492 240 CONTINUE
3493 ENDIF
3494
3495C...Perform hadronization (if desired).
3496 IF(MSTP(111).GE.1) THEN
3497 CALL PYEXEC
3498 IF(MSTU(24).NE.0) GOTO 100
3499 ENDIF
3500 IF(MSTP(113).GE.1) THEN
3501 DO 250 I=NRECAL,N
3502 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3503 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3504 250 CONTINUE
3505 ENDIF
3506 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3507
3508C...Store event information and calculate Monte Carlo estimates of
3509C...subprocess cross-sections.
3510 260 IF(IPILE.EQ.1) CALL PYDOCU
3511
3512C...Set counters for current pileup event and loop to next one.
3513 MSTI(41)=IPILE
3514 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3515 IF(MSTU70.LT.10) THEN
3516 MSTU70=MSTU70+1
3517 MSTU(70+MSTU70)=N
3518 ENDIF
3519 MINT(83)=N
3520 MINT(84)=N+MSTP(126)
3521 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3522 270 CONTINUE
3523
3524C...Generic information on pileup events. Reconstruct missing history.
3525 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
3526 PARI(91)=VINT(132)
3527 PARI(92)=VINT(133)
3528 PARI(93)=VINT(134)
3529 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
3530 ENDIF
3531 CALL PYEDIT(16)
3532
3533C...Transform to the desired coordinate frame.
3534 280 CALL PYFRAM(MSTP(124))
3535 MSTU(70)=MSTU70
3536 PARU(21)=VINT(1)
3537
3538C...Error messages
3539 5100 FORMAT(1X,'Error: no subprocess switched on.'/
3540 &1X,'Execution stopped.')
3541
3542 RETURN
3543 END
3544
3545C*********************************************************************
3546
3547C...PYEVNW
3548C...Administers the generation of a high-pT event via calls to
3549C...a number of subroutines for the new multiple interactions and
3550C...showering framework.
3551
3552 SUBROUTINE PYEVNW
3553
3554C...Double precision and integer declarations.
3555 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
3556 IMPLICIT INTEGER(I-N)
3557 INTEGER PYK,PYCHGE,PYCOMP
3558 PARAMETER (MAXNUR=1000)
3559C...Commonblocks.
3560 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
3561C...Commonblocks.
3562 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
3563 COMMON/PYCTAG/NCT,MCT(4000,2)
3564 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
3565 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
3566 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
3567 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
3568 COMMON/PYINT1/MINT(400),VINT(400)
3569 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
3570 COMMON/PYINT4/MWID(500),WIDS(500,5)
3571 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
3572 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
3573 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
3574 & XMI(2,240),PT2MI(240),IMISEP(0:240)
3575 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
3576 & /PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYINT5/,/PYINTM/
3577C...Local arrays.
3578 DIMENSION VTX(4)
3579
3580C...Stop if no subprocesses on.
3581 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
3582 WRITE(MSTU(11),5100)
3583 CALL PYSTOP(1)
3584 ENDIF
3585
dd99ceaf 3586 DO 2 I = 1, 4000
3587 DO 1 J = 1, 5
3588 V(I,J) = 0.
3589 1 ENDDO
3590 2 ENDDO
92e27c01 3591C...Initial values for some counters.
3592 MSTU(1)=0
3593 MSTU(2)=0
3594 N=0
3595 MINT(5)=MINT(5)+1
3596 MINT(7)=0
3597 MINT(8)=0
3598 MINT(30)=0
3599 MINT(83)=0
3600 MINT(84)=MSTP(126)
3601 MSTU(24)=0
3602 MSTU70=0
3603 MSTJ14=MSTJ(14)
3604C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3605 NCT=0
3606 MINT(33)=0
3607C...Zero counters for pT-ordered showers (failsafe)
3608 NPART=0
3609 NPARTD=0
3610
3611C...Let called routines know call is from PYEVNW (not PYEVNT).
3612 MINT(35)=3
3613
3614C...If variable energies: redo incoming kinematics and cross-section.
3615 MSTI(61)=0
3616 IF(MSTP(171).EQ.1) THEN
3617 CALL PYINKI(1)
3618 IF(MSTI(61).EQ.1) THEN
3619 MINT(5)=MINT(5)-1
3620 RETURN
3621 ENDIF
3622 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3623 CALL PYXTOT
3624 ENDIF
3625
3626C...Loop over number of pileup events; check space left.
3627 IF(MSTP(131).LE.0) THEN
3628 NPILE=1
3629 ELSE
3630 CALL PYPILE(2)
3631 NPILE=MINT(81)
3632 ENDIF
3633 DO 300 IPILE=1,NPILE
3634 IF(MINT(84)+100.GE.MSTU(4)) THEN
3635 CALL PYERRM(11,
3636 & '(PYEVNW:) no more space in PYJETS for pileup events')
3637 IF(MSTU(21).GE.1) GOTO 310
3638 ENDIF
3639 MINT(82)=IPILE
3640
3641C...Generate variables of hard scattering.
3642 MINT(51)=0
3643 MSTI(52)=0
3644 LOOPHS =0
3645 100 CONTINUE
3646 LOOPHS = LOOPHS + 1
3647 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3648 IF(LOOPHS.GE.10) THEN
3649 CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or '
3650 & //'multiple interactions. Returning.')
3651 MINT(51)=1
3652 RETURN
3653 ENDIF
3654 MINT(31)=0
3655 MINT(39)=0
3656 MINT(36)=0
3657 MINT(51)=0
3658 MINT(57)=0
3659 CALL PYRAND
3660 IF(MSTI(61).EQ.1) THEN
3661 MINT(5)=MINT(5)-1
3662 RETURN
3663 ENDIF
3664 IF(MINT(51).EQ.2) RETURN
3665 ISUB=MINT(1)
3666 IF(MSTP(111).EQ.-1) GOTO 290
3667
3668C...Loopback point if PYPREP fails, especially for junction topologies.
3669 NPREP=0
3670 MNT31S=MINT(31)
3671 110 NPREP=NPREP+1
3672 MINT(31)=MNT31S
3673
3674 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3675C...Hard scattering (including low-pT):
3676C...reconstruct kinematics and colour flow of hard scattering.
3677 MINT31=MINT(31)
3678 120 MINT(31)=MINT31
3679 MINT(51)=0
3680 CALL PYSCAT
3681 IF(MINT(51).EQ.1) GOTO 100
3682 NPARTD=N
3683 NFIN=N
3684
3685C...Intertwined initial state showers and multiple interactions.
3686C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3687C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3688 MSTP61=MSTP(61)
3689 IF (MINT(47).LT.2) MSTP(61)=0
3690 MSTP81=MSTP(81)
3691 IF (MINT(50).EQ.0) MSTP(81)=0
3692 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3693 & MINT(111).NE.12) THEN
3694C...Absolute max pT2 scale for evolution: phase space limit.
3695 PT2MXS=0.25D0*VINT(2)
3696C...Check if more constrained by ISR and MI max scales:
3697 PT2MXS=MIN(PT2MXS,MAX(MAX(1D0,PARP(67))*VINT(56),VINT(62)))
3698C...Loopback point in case of failure in evolution.
3699 LOOP=0
3700 130 LOOP=LOOP+1
3701 MINT(51)=0
3702 IF(LOOP.GT.100) THEN
3703 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3704 & //'multiple interactions. Trying new point.')
3705 MINT(51)=1
3706 RETURN
3707 ENDIF
3708
3709C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3710C...once per event. (E.g. compute constants and save variables to be
3711C...restored later in case of failure.)
3712 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3713
3714C...Initialize interleaved MI/ISR/JI evolution.
3715C...PT2MAX: absolute upper limit for evolution - Initialization may
3716C... return a PT2MAX which is lower than this.
3717C...PT2MIN: absolute lower limit for evolution - Initialization may
3718C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3719 PT2MAX=PT2MXS
3720 PT2MIN=0D0
3721 CALL PYEVOL(0,PT2MAX,PT2MIN)
3722C...If failed to initialize evolution, generate a new hard process
3723 IF (MINT(51).EQ.1) GOTO 100
3724
3725C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3726C...In principle factorized, so can be stopped and restarted.
3727C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3728C PT2MED=MAX(10D0**2,PT2MIN)
3729C CALL PYEVOL(1,PT2MAX,PT2MED)
3730C IF (MINT(51).EQ.1) GOTO 160
3731C PT2MAX=PT2MED
3732 CALL PYEVOL(1,PT2MAX,PT2MIN)
3733C...If fatal error (e.g., massive hard-process initiator, but no available
3734C...phase space for creation), generate a new hard process
3735 IF (MINT(51).EQ.2) GOTO 100
3736C...If smaller error, just try running evolution again
3737 IF (MINT(51).EQ.1) GOTO 130
3738
3739C...Finalize interleaved MI/ISR/JI evolution.
3740 CALL PYEVOL(2,PT2MAX,PT2MIN)
3741 IF (MINT(51).EQ.1) GOTO 130
3742
3743 ENDIF
3744 MSTP(61)=MSTP61
3745 MSTP(81)=MSTP81
3746 IF(MINT(51).EQ.1) GOTO 100
3747C...(MINT(52) is actually obsolete in this routine. Set anyway
3748C...to ensure PYDOCU stable.)
3749 MINT(52)=N
3750 MINT(53)=N
3751
3752C...Beam remnants - new scheme.
3753 140 IF(MINT(50).EQ.1) THEN
3754 IF (ISUB.EQ.95) MINT(31)=1
3755
3756C...Beam remnant flavour and colour assignments - new scheme.
3757 CALL PYMIHK
3758 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3759 & GOTO 120
3760 IF(MINT(51).EQ.1) GOTO 100
3761
3762C...Primordial kT and beam remnant momentum sharing - new scheme.
3763 CALL PYMIRM
3764 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3765 & GOTO 120
3766 IF(MINT(51).EQ.1) GOTO 100
3767 IF (ISUB.EQ.95) MINT(31)=0
3768 ELSEIF(MINT(111).NE.12) THEN
3769C...Hadron remnants and primordial kT - old model.
3770C...Happens e.g. for direct photon on one side.
3771 IPU1=IMI(1,1,1)
3772 IPU2=IMI(2,1,1)
3773 CALL PYREMN(IPU1,IPU2)
3774 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3775 & 110
3776 IF(MINT(51).EQ.1) GOTO 100
3777C...PYREMN does not set colour tags for BRs, so needs to be done now.
3778 DO 160 I=MINT(53)+1,N
3779 DO 150 KCS=4,5
3780 IDA=MOD(K(I,KCS),MSTU(5))
3781 IF (IDA.NE.0) THEN
3782 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3783 ELSE
3784 MCT(I,KCS-3)=0
3785 ENDIF
3786 150 CONTINUE
3787 160 CONTINUE
3788C...Instruct PYPREP to use colour tags
3789 MINT(33)=1
3790
3791 DO 360 MQGST=1,2
3792 DO 350 I=MINT(84)+1,N
3793
3794C...Look for coloured string endpoint, or (later) leftover gluon.
3795 IF (K(I,1).NE.3) GOTO 350
3796 KC=PYCOMP(K(I,2))
3797 IF(KC.EQ.0) GOTO 350
3798 KQ=KCHG(KC,2)
3799 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
3800
3801C... Pick up loose string end with no previous tag.
3802 KCS=4
3803 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
3804 IF(MCT(I,KCS-3).NE.0) GOTO 350
3805
3806 CALL PYCTTR(I,KCS,I)
3807 IF(MINT(51).NE.0) RETURN
3808
3809 350 CONTINUE
3810 360 CONTINUE
3811C...Now delete any colour processing information if set (since partons
3812C...otherwise not FS showered!)
3813 DO 170 I=MINT(84)+1,N
3814 IF (I.LE.N) THEN
3815 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3816 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3817 ENDIF
3818 170 CONTINUE
3819 ENDIF
3820
3821C...Showering of final state partons (optional).
3822 ALAMSV=PARJ(81)
3823 PARJ(81)=PARP(72)
3824 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3825 & THEN
3826 QMAX=VINT(55)
3827 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3828 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3829C...External processes: handle successive showers.
3830 ELSEIF(ISET(ISUB).EQ.11) THEN
3831 CALL PYADSH(NFIN)
3832 ENDIF
3833 PARJ(81)=ALAMSV
3834
3835C...Allow possibility for user to abort event generation.
3836 IVETO=0
3837 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
3838 IF(IVETO.EQ.1) THEN
3839C...........No reason to count this as an error
3840 LOOPHS = LOOPHS-1
3841 GOTO 100
3842 ENDIF
3843
3844
3845C...Decay of final state resonances.
3846 MINT(32)=0
3847 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3848 CALL PYRESD(0)
3849 IF(MINT(51).NE.0) GOTO 100
3850 ENDIF
3851
3852 IF(MINT(51).EQ.1) GOTO 100
3853
3854 ELSEIF(ISUB.NE.99) THEN
3855C...Diffractive and elastic scattering.
3856 CALL PYDIFF
3857
3858 ELSE
3859C...DIS scattering (photon flux external).
3860 CALL PYDISG
3861 IF(MINT(51).EQ.1) GOTO 100
3862 ENDIF
3863
3864C...Check that no odd resonance left undecayed.
3865 MINT(54)=N
3866 IF(MSTP(111).GE.1) THEN
3867 NFIX=N
3868 DO 180 I=MINT(84)+1,NFIX
3869 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3870 & K(I,2).NE.22) THEN
3871 KCA=PYCOMP(K(I,2))
3872 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3873 CALL PYRESD(I)
3874 IF(MINT(51).EQ.1) GOTO 100
3875 ENDIF
3876 ENDIF
3877 180 CONTINUE
3878 ENDIF
3879
3880C...Boost hadronic subsystem to overall rest frame.
3881C..(Only relevant when photon inside lepton beam.)
3882 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3883
3884C...Recalculate energies from momenta and masses (if desired).
3885 IF(MSTP(113).GE.1) THEN
3886 DO 190 I=MINT(83)+1,N
3887 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3888 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3889 190 CONTINUE
3890 NRECAL=N
3891 ENDIF
3892
3893C...Colour reconnection before string formation
3894 CALL PYFSCR(MINT(84)+1)
3895
3896C...Rearrange partons along strings, check invariant mass cuts.
3897 MSTU(28)=0
3898 IF(MSTP(111).LE.0) MSTJ(14)=-1
3899 CALL PYPREP(MINT(84)+1)
3900 MSTJ(14)=MSTJ14
3901 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3902 MSTU(24)=0
3903 GOTO 100
3904 ENDIF
3905 IF(MINT(51).EQ.1) GOTO 110
3906 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3907 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3908 DO 220 I=MINT(84)+1,N
3909 IF(K(I,2).EQ.94) THEN
3910 DO 210 I1=I+1,MIN(N,I+10)
3911 IF(K(I1,3).EQ.I) THEN
3912 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3913 IF(K(I1,3).EQ.0) THEN
3914 DO 200 II=MINT(84)+1,I-1
3915 IF(K(II,2).EQ.K(I1,2)) THEN
3916 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3917 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3918 ENDIF
3919 200 CONTINUE
3920 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3921 ENDIF
3922 ENDIF
3923 210 CONTINUE
3924C...Also collapse particles decaying to themselves (if same KS)
3925C...Sep 22 2009: Commented out by PS following suggestion by TS to fix
3926C...problem with history point-backs in new shower, where a particle is
3927C...copied with a new momentum when it is the recoiler.
3928C ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0
3929C & .AND.K(I,4).LT.N) THEN
3930C IDA=K(I,4)
3931C IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN
3932C K(I,1)=0
3933C ENDIF
3934 ENDIF
3935 220 CONTINUE
3936 CALL PYEDIT(12)
3937 CALL PYEDIT(14)
3938 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3939 IF(MSTP(125).EQ.0) MINT(4)=0
3940 DO 240 I=MINT(83)+1,N
3941 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3942 DO 230 I1=I+1,N
3943 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3944 IF(K(I1,3).EQ.I) K(I,5)=I1
3945 230 CONTINUE
3946 ENDIF
3947 240 CONTINUE
3948 ENDIF
3949
3950C...Introduce separators between sections in PYLIST event listing.
3951 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3952 MSTU70=1
3953 MSTU(71)=N
3954 ELSEIF(IPILE.EQ.1) THEN
3955 MSTU70=3
3956 MSTU(71)=2
3957 MSTU(72)=MINT(4)
3958 MSTU(73)=N
3959 ENDIF
3960
3961C...Go back to lab frame (needed for vertices, also in fragmentation).
3962 CALL PYFRAM(1)
3963
3964C...Set nonvanishing production vertex (optional).
3965 IF(MSTP(151).EQ.1) THEN
3966 DO 250 J=1,4
3967 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3968 & SIN(PARU(2)*PYR(0))
3969 250 CONTINUE
3970 DO 270 I=MINT(83)+1,N
3971 DO 260 J=1,4
3972 V(I,J)=V(I,J)+VTX(J)
3973 260 CONTINUE
3974 270 CONTINUE
3975 ENDIF
3976
3977C...Perform hadronization (if desired).
3978 IF(MSTP(111).GE.1) THEN
3979 CALL PYEXEC
3980 IF(MSTU(24).NE.0) GOTO 100
3981 ENDIF
3982 IF(MSTP(113).GE.1) THEN
3983 DO 280 I=NRECAL,N
3984 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3985 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3986 280 CONTINUE
3987 ENDIF
3988 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3989
3990C...Store event information and calculate Monte Carlo estimates of
3991C...subprocess cross-sections.
3992 290 IF(IPILE.EQ.1) CALL PYDOCU
3993
3994C...Set counters for current pileup event and loop to next one.
3995 MSTI(41)=IPILE
3996 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3997 IF(MSTU70.LT.10) THEN
3998 MSTU70=MSTU70+1
3999 MSTU(70+MSTU70)=N
4000 ENDIF
4001 MINT(83)=N
4002 MINT(84)=N+MSTP(126)
4003 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
4004 300 CONTINUE
4005
4006C...Generic information on pileup events. Reconstruct missing history.
4007 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
4008 PARI(91)=VINT(132)
4009 PARI(92)=VINT(133)
4010 PARI(93)=VINT(134)
4011 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
4012 ENDIF
4013 CALL PYEDIT(16)
4014
4015C...Transform to the desired coordinate frame.
4016 310 CALL PYFRAM(MSTP(124))
4017 MSTU(70)=MSTU70
4018 PARU(21)=VINT(1)
4019
4020C...Error messages
4021 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4022 &1X,'Execution stopped.')
4023
4024 RETURN
4025 END
4026
4027
4028C***********************************************************************
4029
4030C...PYSTAT
4031C...Prints out information about cross-sections, decay widths, branching
4032C...ratios, kinematical limits, status codes and parameter values.
4033
4034 SUBROUTINE PYSTAT(MSTAT)
4035
4036C...Double precision and integer declarations.
4037 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4038 IMPLICIT INTEGER(I-N)
4039 INTEGER PYK,PYCHGE,PYCOMP
4040C...Parameter statement to help give large particle numbers.
4041 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
4042 &KEXCIT=4000000,KDIMEN=5000000)
4043 PARAMETER (EPS=1D-3)
4044C...Commonblocks.
4045 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4046 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4047 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4048 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4049 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4050 COMMON/PYINT1/MINT(400),VINT(400)
4051 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4052 COMMON/PYINT4/MWID(500),WIDS(500,5)
4053 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4054 COMMON/PYINT6/PROC(0:500)
4055 CHARACTER PROC*28, CHTMP*16
4056 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
4057 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
4058 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4059 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
4060C...Local arrays, character variables and data.
4061 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
4062 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
4063 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
4064 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
4065 CHARACTER*24 CHD0, CHDC(10)
4066 CHARACTER*6 DNAME(3)
4067 DATA PROGA/
4068 &'VMD/hadron * VMD ','VMD/hadron * direct ',
4069 &'VMD/hadron * anomalous ','direct * direct ',
4070 &'direct * anomalous ','anomalous * anomalous '/
4071 DATA DISGA/'e * VMD','e * anomalous'/
4072 DATA PROGG9/
4073 &'direct * direct ','direct * VMD ',
4074 &'direct * anomalous ','VMD * direct ',
4075 &'VMD * VMD ','VMD * anomalous ',
4076 &'anomalous * direct ','anomalous * VMD ',
4077 &'anomalous * anomalous ','DIS * VMD ',
4078 &'DIS * anomalous ','VMD * DIS ',
4079 &'anomalous * DIS '/
4080 DATA PROGG4/
4081 &'direct * direct ','direct * resolved ',
4082 &'resolved * direct ','resolved * resolved '/
4083 DATA PROGG2/
4084 &'direct * hadron ','resolved * hadron '/
4085 DATA PROGP4/
4086 &'VMD * hadron ','direct * hadron ',
4087 &'anomalous * hadron ','DIS * hadron '/
4088 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
4089 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
4090 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
4091 &' y*_small ',' eta*_large ',' eta*_small ',
4092 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
4093 &' x_2 ',' x_F ',' cos(theta_hard) ',
4094 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
4095 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
4096 &' tau'' '/
4097 DATA DNAME /'q ','lepton','nu '/
4098
4099C...Cross-sections.
4100 IF(MSTAT.LE.1) THEN
4101 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
4102 WRITE(MSTU(11),5000)
4103 WRITE(MSTU(11),5100)
4104 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
4105 DO 100 I=1,500
4106 IF(MSUB(I).NE.1) GOTO 100
4107 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
4108 100 CONTINUE
4109 IF(MINT(121).GT.1) THEN
4110 WRITE(MSTU(11),5300)
4111 DO 110 IGA=1,MINT(121)
4112 CALL PYSAVE(3,IGA)
4113 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4114 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
4115 & XSEC(0,3)
4116 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4117 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
4118 & XSEC(0,3)
4119 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
4120 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
4121 & XSEC(0,3)
4122 ELSEIF(MINT(121).EQ.4) THEN
4123 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
4124 & XSEC(0,3)
4125 ELSEIF(MINT(121).EQ.2) THEN
4126 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
4127 & XSEC(0,3)
4128 ELSE
4129 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
4130 & XSEC(0,3)
4131 ENDIF
4132 110 CONTINUE
4133 CALL PYSAVE(5,0)
4134 ENDIF
4135 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
4136 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
4137
4138C...Decay widths and branching ratios.
4139 ELSEIF(MSTAT.EQ.2) THEN
4140 WRITE(MSTU(11),5500)
4141 WRITE(MSTU(11),5600)
4142 DO 140 KC=1,500
4143 KF=KCHG(KC,4)
4144 CALL PYNAME(KF,CHKF)
4145 IOFF=0
4146 IF(KC.LE.22) THEN
4147 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
4148 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
4149 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
4150 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
4151 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
4152 ELSE
4153 IF(MWID(KC).LE.0) GOTO 140
4154 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
4155 & KF/KSUSY1.EQ.2)) GOTO 140
4156 ENDIF
4157C...Off-shell branchings.
4158 IF(IOFF.EQ.1) THEN
4159 NGP=0
4160 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
4161 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
4162 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
4163 DO 120 J=1,MDCY(KC,3)
4164 IDC=J+MDCY(KC,2)-1
4165 NGP1=0
4166 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4167 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4168 NGP2=0
4169 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4170 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4171 CALL PYNAME(KFDP(IDC,1),CHD1)
4172 CALL PYNAME(KFDP(IDC,2),CHD2)
4173 IF(KFDP(IDC,3).EQ.0) THEN
4174 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4175 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4176 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4177 ELSE
4178 CALL PYNAME(KFDP(IDC,3),CHD3)
4179 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4180 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4181 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4182 ENDIF
4183 120 CONTINUE
4184C...On-shell decays.
4185 ELSE
4186 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
4187 BRFIN=1D0
4188 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
4189 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
4190 & STATE(MDCY(KC,1)),BRFIN
4191 DO 130 J=1,MDCY(KC,3)
4192 IDC=J+MDCY(KC,2)-1
4193 NGP1=0
4194 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4195 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4196 NGP2=0
4197 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4198 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4199 BRPRI=0D0
4200 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
4201 BRFIN=0D0
4202 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
4203 CALL PYNAME(KFDP(IDC,1),CHD1)
4204 CALL PYNAME(KFDP(IDC,2),CHD2)
4205 IF(KFDP(IDC,3).EQ.0) THEN
4206 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4207 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4208 & CHD2(1:10),WDTP(J),BRPRI,
4209 & STATE(MDME(IDC,1)),BRFIN
4210 ELSE
4211 CALL PYNAME(KFDP(IDC,3),CHD3)
4212 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4213 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4214 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
4215 & STATE(MDME(IDC,1)),BRFIN
4216 ENDIF
4217 130 CONTINUE
4218 ENDIF
4219 140 CONTINUE
4220 WRITE(MSTU(11),6000)
4221
4222C...Allowed incoming partons/particles at hard interaction.
4223 ELSEIF(MSTAT.EQ.3) THEN
4224 WRITE(MSTU(11),6100)
4225 CALL PYNAME(MINT(11),CHAU)
4226 CHIN(1)=CHAU(1:12)
4227 CALL PYNAME(MINT(12),CHAU)
4228 CHIN(2)=CHAU(1:12)
4229 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
4230 DO 150 I=-20,22
4231 IF(I.EQ.0) GOTO 150
4232 IA=IABS(I)
4233 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
4234 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
4235 CALL PYNAME(I,CHAU)
4236 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
4237 & STATE(KFIN(2,I))
4238 150 CONTINUE
4239 WRITE(MSTU(11),6400)
4240
4241C...User-defined limits on kinematical variables.
4242 ELSEIF(MSTAT.EQ.4) THEN
4243 WRITE(MSTU(11),6500)
4244 WRITE(MSTU(11),6600)
4245 SHRMAX=CKIN(2)
4246 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
4247 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
4248 PTHMIN=MAX(CKIN(3),CKIN(5))
4249 PTHMAX=CKIN(4)
4250 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
4251 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
4252 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
4253 DO 160 I=4,14
4254 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
4255 160 CONTINUE
4256 SPRMAX=CKIN(32)
4257 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
4258 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
4259 WRITE(MSTU(11),7000)
4260
4261C...Status codes and parameter values.
4262 ELSEIF(MSTAT.EQ.5) THEN
4263 WRITE(MSTU(11),7100)
4264 WRITE(MSTU(11),7200)
4265 DO 170 I=1,100
4266 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4267 & PARP(100+I)
4268 170 CONTINUE
4269
4270C...List of all processes implemented in the program.
4271 ELSEIF(MSTAT.EQ.6) THEN
4272 WRITE(MSTU(11),7400)
4273 WRITE(MSTU(11),7500)
4274 DO 180 I=1,500
4275 IF(ISET(I).LT.0) GOTO 180
4276 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4277 180 CONTINUE
4278 WRITE(MSTU(11),7700)
4279
4280 ELSEIF(MSTAT.EQ.7) THEN
4281 WRITE (MSTU(11),8000)
4282 NMODES(0)=0
4283 NMODES(10)=0
4284 NMODES(9)=0
4285 DO 290 ILR=1,2
4286 DO 280 KFSM=1,16
4287 KFSUSY=ILR*KSUSY1+KFSM
4288 NRVDC=0
4289C...SDOWN DECAYS
4290 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4291 NRVDC=3
4292 DO 190 I=1,NRVDC
4293 PBRAT(I)=0D0
4294 NMODES(I)=0
4295 190 CONTINUE
4296 CALL PYNAME(KFSUSY,CHTMP)
4297 CHD0=CHTMP//' '
4298 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4299 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4300 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4301 KC=PYCOMP(KFSUSY)
4302 DO 200 J=1,MDCY(KC,3)
4303 IDC=J+MDCY(KC,2)-1
4304 ID1=IABS(KFDP(IDC,1))
4305 ID2=IABS(KFDP(IDC,2))
4306 IF (KFDP(IDC,3).EQ.0) THEN
4307 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4308 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4309 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4310 NMODES(1)=NMODES(1)+1
4311 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4312 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4313 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4314 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4315 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4316 NMODES(2)=NMODES(2)+1
4317 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4318 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4319 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4320 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4321 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4322 NMODES(3)=NMODES(3)+1
4323 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4324 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4325 ENDIF
4326 ENDIF
4327 200 CONTINUE
4328 ENDIF
4329C...SUP DECAYS
4330 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4331 NRVDC=2
4332 DO 210 I=1,NRVDC
4333 NMODES(I)=0
4334 PBRAT(I)=0D0
4335 210 CONTINUE
4336 CALL PYNAME(KFSUSY,CHTMP)
4337 CHD0=CHTMP//' '
4338 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4339 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4340 KC=PYCOMP(KFSUSY)
4341 DO 220 J=1,MDCY(KC,3)
4342 IDC=J+MDCY(KC,2)-1
4343 ID1=IABS(KFDP(IDC,1))
4344 ID2=IABS(KFDP(IDC,2))
4345 IF (KFDP(IDC,3).EQ.0) THEN
4346 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4347 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4348 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4349 NMODES(1)=NMODES(1)+1
4350 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4351 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4352 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4353 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4354 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4355 NMODES(2)=NMODES(2)+1
4356 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4357 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4358 ENDIF
4359 ENDIF
4360 220 CONTINUE
4361 ENDIF
4362C...SLEPTON DECAYS
4363 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4364 NRVDC=2
4365 DO 230 I=1,NRVDC
4366 PBRAT(I)=0D0
4367 NMODES(I)=0
4368 230 CONTINUE
4369 CALL PYNAME(KFSUSY,CHTMP)
4370 CHD0=CHTMP//' '
4371 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4372 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4373 KC=PYCOMP(KFSUSY)
4374 DO 240 J=1,MDCY(KC,3)
4375 IDC=J+MDCY(KC,2)-1
4376 ID1=IABS(KFDP(IDC,1))
4377 ID2=IABS(KFDP(IDC,2))
4378 IF (KFDP(IDC,3).EQ.0) THEN
4379 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4380 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4381 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4382 NMODES(1)=NMODES(1)+1
4383 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4384 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4385 ENDIF
4386 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4387 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4388 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4389 NMODES(2)=NMODES(2)+1
4390 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4391 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4392 ENDIF
4393 ENDIF
4394 240 CONTINUE
4395 ENDIF
4396C...SNEUTRINO DECAYS
4397 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4398 & THEN
4399 NRVDC=2
4400 DO 250 I=1,NRVDC
4401 PBRAT(I)=0D0
4402 NMODES(I)=0
4403 250 CONTINUE
4404 CALL PYNAME(KFSUSY,CHTMP)
4405 CHD0=CHTMP//' '
4406 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4407 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4408 KC=PYCOMP(KFSUSY)
4409 DO 260 J=1,MDCY(KC,3)
4410 IDC=J+MDCY(KC,2)-1
4411 ID1=IABS(KFDP(IDC,1))
4412 ID2=IABS(KFDP(IDC,2))
4413 IF (KFDP(IDC,3).EQ.0) THEN
4414 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4415 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4416 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4417 NMODES(1)=NMODES(1)+1
4418 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4419 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4420 ENDIF
4421 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4422 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4423 NMODES(2)=NMODES(2)+1
4424 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4425 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4426 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4427 ENDIF
4428 ENDIF
4429 260 CONTINUE
4430 ENDIF
4431 IF (NRVDC.NE.0) THEN
4432 DO 270 I=1,NRVDC
4433 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4434 NMODES(0)=NMODES(0)+NMODES(I)
4435 270 CONTINUE
4436 ENDIF
4437 280 CONTINUE
4438 290 CONTINUE
4439 DO 370 KFSM=21,37
4440 KFSUSY=KSUSY1+KFSM
4441 NRVDC=0
4442C...NEUTRALINO DECAYS
4443 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4444 NRVDC=4
4445 DO 300 I=1,NRVDC
4446 PBRAT(I)=0D0
4447 NMODES(I)=0
4448 300 CONTINUE
4449 CALL PYNAME(KFSUSY,CHTMP)
4450 CHD0=CHTMP//' '
4451 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4452 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4453 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4454 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4455 KC=PYCOMP(KFSUSY)
4456 DO 310 J=1,MDCY(KC,3)
4457 IDC=J+MDCY(KC,2)-1
4458 ID1=IABS(KFDP(IDC,1))
4459 ID2=IABS(KFDP(IDC,2))
4460 ID3=IABS(KFDP(IDC,3))
4461 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4462 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4463 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4464 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4465 NMODES(1)=NMODES(1)+1
4466 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4467 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4468 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4469 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4470 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4471 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4472 NMODES(2)=NMODES(2)+1
4473 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4474 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4475 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4476 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4477 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4478 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4479 NMODES(3)=NMODES(3)+1
4480 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4481 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4482 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4483 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4484 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4485 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4486 NMODES(4)=NMODES(4)+1
4487 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4488 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4489 ENDIF
4490 310 CONTINUE
4491 ENDIF
4492C...CHARGINO DECAYS
4493 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4494 NRVDC=5
4495 DO 320 I=1,NRVDC
4496 PBRAT(I)=0D0
4497 NMODES(I)=0
4498 320 CONTINUE
4499 CALL PYNAME(KFSUSY,CHTMP)
4500 CHD0=CHTMP//' '
4501 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4502 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4503 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4504 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4505 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4506 KC=PYCOMP(KFSUSY)
4507 DO 330 J=1,MDCY(KC,3)
4508 IDC=J+MDCY(KC,2)-1
4509 ID1=IABS(KFDP(IDC,1))
4510 ID2=IABS(KFDP(IDC,2))
4511 ID3=IABS(KFDP(IDC,3))
4512 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4513 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4514 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4515 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4516 NMODES(1)=NMODES(1)+1
4517 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4518 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4519 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4520 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4521 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4522 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4523 NMODES(1)=NMODES(1)+1
4524 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4525 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4526 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4527 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4528 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4529 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4530 NMODES(2)=NMODES(2)+1
4531 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4532 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4533 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4534 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4535 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4536 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4537 NMODES(3)=NMODES(3)+1
4538 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4539 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4540 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4541 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4542 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4543 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4544 NMODES(3)=NMODES(3)+1
4545 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4546 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4547 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4548 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4549 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4550 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4551 NMODES(4)=NMODES(4)+1
4552 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4553 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4554 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4555 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4556 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4557 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4558 NMODES(4)=NMODES(4)+1
4559 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4560 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4561 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4562 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4563 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4564 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4565 NMODES(5)=NMODES(5)+1
4566 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4567 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4568 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4569 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4570 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4571 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4572 NMODES(5)=NMODES(5)+1
4573 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4574 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4575 ENDIF
4576 330 CONTINUE
4577 ENDIF
4578C...GLUINO DECAYS
4579 IF (KFSM.EQ.21) THEN
4580 NRVDC=3
4581 DO 340 I=1,NRVDC
4582 PBRAT(I)=0D0
4583 NMODES(I)=0
4584 340 CONTINUE
4585 CALL PYNAME(KFSUSY,CHTMP)
4586 CHD0=CHTMP//' '
4587 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4588 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4589 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4590 KC=PYCOMP(KFSUSY)
4591 DO 350 J=1,MDCY(KC,3)
4592 IDC=J+MDCY(KC,2)-1
4593 ID1=IABS(KFDP(IDC,1))
4594 ID2=IABS(KFDP(IDC,2))
4595 ID3=IABS(KFDP(IDC,3))
4596 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4597 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4598 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4599 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4600 NMODES(1)=NMODES(1)+1
4601 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4602 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4603 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4604 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4605 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4606 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4607 NMODES(2)=NMODES(2)+1
4608 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4609 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4610 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4611 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4612 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4613 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4614 NMODES(3)=NMODES(3)+1
4615 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4616 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4617 ENDIF
4618 350 CONTINUE
4619 ENDIF
4620
4621 IF (NRVDC.NE.0) THEN
4622 DO 360 I=1,NRVDC
4623 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4624 NMODES(0)=NMODES(0)+NMODES(I)
4625 360 CONTINUE
4626 ENDIF
4627 370 CONTINUE
4628 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4629
4630 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4631 WRITE (MSTU(11),8500)
4632 DO 400 IRV=1,3
4633 DO 390 JRV=1,3
4634 DO 380 KRV=1,3
4635 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4636 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4637 380 CONTINUE
4638 390 CONTINUE
4639 400 CONTINUE
4640 WRITE (MSTU(11),8600)
4641 ENDIF
4642 ENDIF
4643
4644C...Formats for printouts.
4645 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4646 &'Events and Cross-sections',1X,9('*'))
4647 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4648 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4649 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4650 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4651 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4652 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4653 &'I',12X,'I')
4654 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4655 &D10.3,1X,'I')
4656 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4657 &1X,'I',34X,'I',28X,'I',12X,'I')
4658 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4659 &1X,'********* Total number of errors, excluding junctions =',
4660 &1X,I8,' *************'/
4661 &1X,'********* Total number of errors, including junctions =',
4662 &1X,I8,' *************'/
4663 &1X,'********* Total number of warnings = ',
4664 &1X,I8,' *************'/
4665 &1X,'********* Fraction of events that fail fragmentation ',
4666 &'cuts =',1X,F8.5,' *********'/)
4667 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4668 &'Ratios',1X,27('*'))
4669 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4670 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4671 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4672 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4673 &1X,98('='))
4674 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4675 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4676 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4677 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4678 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4679 &1P,D10.3,0P,1X,'I')
4680 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4681 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4682 &1P,D10.3,0P,1X,'I')
4683 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4684 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4685 &'Particles at Hard Interaction',1X,7('*'))
4686 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4687 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4688 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4689 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4690 &78('=')/1X,'I',38X,'I',37X,'I')
4691 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4692 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4693 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4694 &'Kinematical Variables',1X,12('*'))
4695 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4696 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4697 &16X,'I')
4698 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4699 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4700 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4701 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4702 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4703 &'Parameter Values',1X,12('*'))
4704 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4705 &'PARP(I)'/)
4706 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4707 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4708 &1X,13('*'))
4709 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4710 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4711 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4712 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4713 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4714 8000 FORMAT(1X/ 1X/
4715 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4716 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4717 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4718 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4719 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4720 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4721 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4722 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4723 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4724 & /1X,70('='))
4725 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4726 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4727 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4728 8500 FORMAT(1X/ 1X/
4729 & 1X,'R-Violating couplings',1X/ 1X /
4730 & 1X,55('=')/
4731 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4732 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4733 & ,'I',15X,'I',15X,'I',15X,'I')
4734 8600 FORMAT(1X,55('='))
4735 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4736 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4737
4738 RETURN
4739 END
4740
4741C*********************************************************************
4742
4743C...PYUPEV
4744C...Administers the hard-process generation required for output to the
4745C...Les Houches event record.
4746
4747 SUBROUTINE PYUPEV
4748
4749C...Double precision and integer declarations.
4750 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4751 IMPLICIT INTEGER(I-N)
4752 INTEGER PYK,PYCHGE,PYCOMP
4753
4754C...Commonblocks.
4755 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4756 COMMON/PYCTAG/NCT,MCT(4000,2)
4757 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4758 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4759 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4760 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4761 COMMON/PYINT1/MINT(400),VINT(400)
4762 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4763 COMMON/PYINT4/MWID(500),WIDS(500,5)
4764 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4765 &/PYINT1/,/PYINT2/,/PYINT4/
4766
4767C...HEPEUP for output.
4768 INTEGER MAXNUP
4769 PARAMETER (MAXNUP=500)
4770 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4771 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4772 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4773 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4774 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4775 SAVE /HEPEUP/
4776
4777C...Stop if no subprocesses on.
4778 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4779 WRITE(MSTU(11),5100)
4780 STOP
4781 ENDIF
4782
4783C...Special flags for hard-process generation only.
4784 MSTP71=MSTP(71)
4785 MSTP(71)=0
4786 MST128=MSTP(128)
4787 MSTP(128)=1
4788
4789C...Initial values for some counters.
4790 N=0
4791 MINT(5)=MINT(5)+1
4792 MINT(7)=0
4793 MINT(8)=0
4794 MINT(30)=0
4795 MINT(83)=0
4796 MINT(84)=MSTP(126)
4797 MSTU(24)=0
4798 MSTU70=0
4799 MSTJ14=MSTJ(14)
4800C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4801 MINT(33)=0
4802
4803C...If variable energies: redo incoming kinematics and cross-section.
4804 MSTI(61)=0
4805 IF(MSTP(171).EQ.1) THEN
4806 CALL PYINKI(1)
4807 IF(MSTI(61).EQ.1) THEN
4808 MINT(5)=MINT(5)-1
4809 RETURN
4810 ENDIF
4811 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4812 CALL PYXTOT
4813 ENDIF
4814
4815C...Do not allow pileup events.
4816 MINT(82)=1
4817
4818C...Generate variables of hard scattering.
4819 MINT(51)=0
4820 MSTI(52)=0
4821 100 CONTINUE
4822 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4823 MINT(31)=0
4824 MINT(51)=0
4825 MINT(57)=0
4826 CALL PYRAND
4827 IF(MSTI(61).EQ.1) THEN
4828 MINT(5)=MINT(5)-1
4829 RETURN
4830 ENDIF
4831 IF(MINT(51).EQ.2) RETURN
4832 ISUB=MINT(1)
4833
4834 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4835C...Hard scattering (including low-pT):
4836C...reconstruct kinematics and colour flow of hard scattering.
4837 MINT31=MINT(31)
4838 110 MINT(31)=MINT31
4839 MINT(51)=0
4840 CALL PYSCAT
4841 IF(MINT(51).EQ.1) GOTO 100
4842 IPU1=MINT(84)+1
4843 IPU2=MINT(84)+2
4844
4845C...Decay of final state resonances.
4846 MINT(32)=0
4847 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4848 & CALL PYRESD(0)
4849 IF(MINT(51).EQ.1) GOTO 100
4850 MINT(52)=N
4851
4852C...Longitudinal boost of hard scattering.
4853 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4854 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4855
4856 ELSEIF(ISUB.NE.99) THEN
4857C...Diffractive and elastic scattering.
4858 CALL PYDIFF
4859
4860 ELSE
4861C...DIS scattering (photon flux external).
4862 CALL PYDISG
4863 IF(MINT(51).EQ.1) GOTO 100
4864 ENDIF
4865
4866C...Check that no odd resonance left undecayed.
4867 MINT(54)=N
4868 NFIX=N
4869 DO 120 I=MINT(84)+1,NFIX
4870 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4871 & K(I,2).NE.22) THEN
4872 KCA=PYCOMP(K(I,2))
4873 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4874 CALL PYRESD(I)
4875 IF(MINT(51).EQ.1) GOTO 100
4876 ENDIF
4877 ENDIF
4878 120 CONTINUE
4879
4880C...Boost hadronic subsystem to overall rest frame.
4881C..(Only relevant when photon inside lepton beam.)
4882 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4883
4884C...Store event information and calculate Monte Carlo estimates of
4885C...subprocess cross-sections.
4886 130 CALL PYDOCU
4887
4888C...Transform to the desired coordinate frame.
4889 140 CALL PYFRAM(MSTP(124))
4890 MSTU(70)=MSTU70
4891 PARU(21)=VINT(1)
4892
4893C...Restore special flags for hard-process generation only.
4894 MSTP(71)=MSTP71
4895 MSTP(128)=MST128
4896
4897C...Trace colour tags; convert to LHA style labels.
4898 NCT=100
4899 DO 150 I=MINT(84)+1,N
4900 MCT(I,1)=0
4901 MCT(I,2)=0
4902 150 CONTINUE
4903 DO 160 I=MINT(84)+1,N
4904 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4905 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4906 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4907 & THEN
4908 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4909 IDA=MOD(K(I,4),MSTU(5))
4910 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4911 & MCT(IMO,2).NE.0) THEN
4912 MCT(I,1)=MCT(IMO,2)
4913 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4914 & MCT(IMO,1).NE.0) THEN
4915 MCT(I,1)=MCT(IMO,1)
4916 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4917 & MCT(IDA,2).NE.0) THEN
4918 MCT(I,1)=MCT(IDA,2)
4919 ELSE
4920 NCT=NCT+1
4921 MCT(I,1)=NCT
4922 ENDIF
4923 ENDIF
4924 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4925 & THEN
4926 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4927 IDA=MOD(K(I,5),MSTU(5))
4928 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4929 & MCT(IMO,1).NE.0) THEN
4930 MCT(I,2)=MCT(IMO,1)
4931 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4932 & MCT(IMO,2).NE.0) THEN
4933 MCT(I,2)=MCT(IMO,2)
4934 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4935 & MCT(IDA,1).NE.0) THEN
4936 MCT(I,2)=MCT(IDA,1)
4937 ELSE
4938 NCT=NCT+1
4939 MCT(I,2)=NCT
4940 ENDIF
4941 ENDIF
4942 ENDIF
4943 160 CONTINUE
4944
4945C...Put event in HEPEUP commonblock.
4946 NUP=N-MINT(84)
4947 IDPRUP=MINT(1)
4948 XWGTUP=1D0
4949 SCALUP=VINT(53)
4950 AQEDUP=VINT(57)
4951 AQCDUP=VINT(58)
4952 DO 180 I=1,NUP
4953 IDUP(I)=K(I+MINT(84),2)
4954 IF(I.LE.2) THEN
4955 ISTUP(I)=-1
4956 MOTHUP(1,I)=0
4957 MOTHUP(2,I)=0
4958 ELSEIF(K(I+4,3).EQ.0) THEN
4959 ISTUP(I)=1
4960 MOTHUP(1,I)=1
4961 MOTHUP(2,I)=2
4962 ELSE
4963 ISTUP(I)=1
4964 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4965 MOTHUP(2,I)=0
4966 ENDIF
4967 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4968 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4969 ICOLUP(1,I)=MCT(I+MINT(84),1)
4970 ICOLUP(2,I)=MCT(I+MINT(84),2)
4971 DO 170 J=1,5
4972 PUP(J,I)=P(I+MINT(84),J)
4973 170 CONTINUE
4974 VTIMUP(I)=V(I,5)
4975 SPINUP(I)=9D0
4976 180 CONTINUE
4977
4978C...Optionally write out event to disk. Minimal size for time/spin fields.
4979 IF(MSTP(162).GT.0) THEN
4980 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4981 DO 190 I=1,NUP
4982 IF(VTIMUP(I).EQ.0D0) THEN
4983 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4984 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4985 & ' 0. 9.'
4986 ELSE
4987 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4988 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4989 & VTIMUP(I),' 9.'
4990 ENDIF
4991 190 CONTINUE
4992
4993C...Optional extra line with parton-density information.
4994 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4995 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4996 ENDIF
4997
4998C...Error messages and other print formats.
4999 5100 FORMAT(1X,'Error: no subprocess switched on.'/
5000 &1X,'Execution stopped.')
5001 5200 FORMAT(1P,2I6,4E14.6)
5002 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
5003 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
5004 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
5005
5006 RETURN
5007 END
5008
5009C*********************************************************************
5010
5011C...PYUPIN
5012C...Fills the HEPRUP commonblock with info on incoming beams and allowed
5013C...processes, and optionally stores that information on file.
5014
5015 SUBROUTINE PYUPIN
5016
5017C...Double precision and integer declarations.
5018 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5019 IMPLICIT INTEGER(I-N)
5020
5021C...Commonblocks.
5022 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5023 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5024 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5025 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5026 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
5027
5028C...User process initialization commonblock.
5029 INTEGER MAXPUP
5030 PARAMETER (MAXPUP=100)
5031 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5032 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5033 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5034 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5035 &LPRUP(MAXPUP)
5036 SAVE /HEPRUP/
5037
5038C...Store info on incoming beams.
5039 IDBMUP(1)=K(1,2)
5040 IDBMUP(2)=K(2,2)
5041 EBMUP(1)=P(1,4)
5042 EBMUP(2)=P(2,4)
5043 PDFGUP(1)=0
5044 PDFGUP(2)=0
5045 PDFSUP(1)=MSTP(51)
5046 PDFSUP(2)=MSTP(51)
5047
5048C...Event weighting strategy.
5049 IDWTUP=3
5050
5051C...Info on individual processes.
5052 NPRUP=0
5053 DO 100 ISUB=1,500
5054 IF(MSUB(ISUB).EQ.1) THEN
5055 NPRUP=NPRUP+1
5056 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
5057 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
5058 XMAXUP(NPRUP)=1D0
5059 LPRUP(NPRUP)=ISUB
5060 ENDIF
5061 100 CONTINUE
5062
5063C...Write info to file.
5064 IF(MSTP(161).GT.0) THEN
5065 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
5066 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5067 DO 110 IPR=1,NPRUP
5068 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
5069 & LPRUP(IPR)
5070 110 CONTINUE
5071 ENDIF
5072
5073C...Formats for printout.
5074 5100 FORMAT(1P,2I8,2E14.6,6I6)
5075 5200 FORMAT(1P,3E14.6,I6)
5076
5077 RETURN
5078 END
5079
5080
5081C*********************************************************************
5082
5083C...Combine the two old-style Pythia initialization and event files
5084C...into a single Les Houches Event File.
5085
5086 SUBROUTINE PYLHEF
5087
5088C...Double precision and integer declarations.
5089 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5090 IMPLICIT INTEGER(I-N)
5091
5092C...PYTHIA commonblock: only used to provide read/write units and version.
5093 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5094 SAVE /PYPARS/
5095
5096C...User process initialization commonblock.
5097 INTEGER MAXPUP
5098 PARAMETER (MAXPUP=100)
5099 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5100 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5101 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5102 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5103 &LPRUP(MAXPUP)
5104 SAVE /HEPRUP/
5105
5106C...User process event common block.
5107 INTEGER MAXNUP
5108 PARAMETER (MAXNUP=500)
5109 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
5110 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
5111 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
5112 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
5113 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
5114 SAVE /HEPEUP/
5115
5116C...Lines to read in assumed never longer than 200 characters.
5117 PARAMETER (MAXLEN=200)
5118 CHARACTER*(MAXLEN) STRING
5119
5120C...Format for reading lines.
5121 CHARACTER*6 STRFMT
5122 STRFMT='(A000)'
5123 WRITE(STRFMT(3:5),'(I3)') MAXLEN
5124
5125C...Rewind initialization and event files.
5126 REWIND MSTP(161)
5127 REWIND MSTP(162)
5128
5129C...Write header info.
5130 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
5131 WRITE(MSTP(163),'(A)') '<!--'
5132 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
5133 &MSTP(181),'.',MSTP(182)
5134 WRITE(MSTP(163),'(A)') '-->'
5135
5136C...Read first line of initialization info and get number of processes.
5137 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5138 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
5139 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5140
5141C...Copy initialization lines, omitting trailing blanks.
5142C...Embed in <init> ... </init> block.
5143 WRITE(MSTP(163),'(A)') '<init>'
5144 DO 140 IPR=0,NPRUP
5145 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5146 LEN=MAXLEN+1
5147 120 LEN=LEN-1
5148 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
5149 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5150 140 CONTINUE
5151 WRITE(MSTP(163),'(A)') '</init>'
5152
5153C...Begin event loop. Read first line of event info or already done.
5154 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
5155 200 CONTINUE
5156
5157C...Look at first line to know number of particles in event.
5158 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
5159
5160C...Begin an <event> block. Copy event lines, omitting trailing blanks.
5161 WRITE(MSTP(163),'(A)') '<event>'
5162 DO 240 I=0,NUP
5163 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
5164 LEN=MAXLEN+1
5165 220 LEN=LEN-1
5166 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
5167 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5168 240 CONTINUE
5169
5170C...Copy trailing comment lines - with a # in the first column - as is.
5171 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
5172 IF(STRING(1:1).EQ.'#') THEN
5173 LEN=MAXLEN+1
5174 280 LEN=LEN-1
5175 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
5176 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5177 GOTO 260
5178 ENDIF
5179
5180C..End the <event> block. Loop back to look for next event.
5181 WRITE(MSTP(163),'(A)') '</event>'
5182 GOTO 200
5183
5184C...Successfully reached end of event loop: write closing tag
5185C...and remove temporary intermediate files (unless asked not to).
5186 300 WRITE(MSTP(163),'(A)') '</event>'
5187 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
5188 IF(MSTP(164).EQ.1) RETURN
5189 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
5190 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
5191 RETURN
5192
5193C...Error exit.
5194 400 WRITE(*,*) ' PYLHEF file joining failed!'
5195
5196 RETURN
5197 END
5198
5199C*********************************************************************
5200
5201C...PYINRE
5202C...Calculates full and effective widths of gauge bosons, stores
5203C...masses and widths, rescales coefficients to be used for
5204C...resonance production generation.
5205
5206 SUBROUTINE PYINRE
5207
5208C...Double precision and integer declarations.
5209 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5210 IMPLICIT INTEGER(I-N)
5211 INTEGER PYK,PYCHGE,PYCOMP
5212C...Parameter statement to help give large particle numbers.
5213 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5214 &KEXCIT=4000000,KDIMEN=5000000)
5215C...Commonblocks.
5216 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5217 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5218 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5219 COMMON/PYDAT4/CHAF(500,2)
5220 CHARACTER CHAF*16
5221 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5222 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5223 COMMON/PYINT1/MINT(400),VINT(400)
5224 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5225 COMMON/PYINT4/MWID(500),WIDS(500,5)
5226 COMMON/PYINT6/PROC(0:500)
5227 CHARACTER PROC*28
5228 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5229 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
5230 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
5231C...Local arrays and data.
5232 CHARACTER PRTMP*9
5233 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
5234 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
5235
5236C...Born level couplings in MSSM Higgs doublet sector.
5237 XW=PARU(102)
5238 XWV=XW
5239 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
5240 XW1=1D0-XW
5241 IF(MSTP(4).EQ.2) THEN
5242 TANBE=PARU(141)
5243 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
5244 SQMZ=PMAS(23,1)**2
5245 SQMW=PMAS(24,1)**2
5246 SQMH=PMAS(25,1)**2
5247 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
5248 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
5249 SQMHC=SQMA+SQMW
5250 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
5251 WRITE(MSTU(11),5000)
5252 CALL PYSTOP(101)
5253 ENDIF
5254 PMAS(35,1)=SQRT(SQMHP)
5255 PMAS(36,1)=SQRT(SQMA)
5256 PMAS(37,1)=SQRT(SQMHC)
5257 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5258 & (SQMA-SQMZ)))
5259 BESU=ATAN(TANBE)
5260 PARU(142)=1D0
5261 PARU(143)=1D0
5262 PARU(161)=-SIN(ALSU)/COS(BESU)
5263 PARU(162)=COS(ALSU)/SIN(BESU)
5264 PARU(163)=PARU(161)
5265 PARU(164)=SIN(BESU-ALSU)
5266 PARU(165)=PARU(164)
5267 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5268 PARU(171)=COS(ALSU)/COS(BESU)
5269 PARU(172)=SIN(ALSU)/SIN(BESU)
5270 PARU(173)=PARU(171)
5271 PARU(174)=COS(BESU-ALSU)
5272 PARU(175)=PARU(174)
5273 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5274 & SIN(BESU+ALSU)
5275 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5276 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5277 PARU(181)=TANBE
5278 PARU(182)=1D0/TANBE
5279 PARU(183)=PARU(181)
5280 PARU(184)=0D0
5281 PARU(185)=PARU(184)
5282 PARU(186)=COS(BESU-ALSU)
5283 PARU(187)=SIN(BESU-ALSU)
5284 PARU(188)=PARU(186)
5285 PARU(189)=PARU(187)
5286 PARU(190)=0D0
5287 PARU(195)=COS(BESU-ALSU)
5288 ENDIF
5289
5290C...Reset effective widths of gauge bosons.
5291 DO 110 I=1,500
5292 DO 100 J=1,5
5293 WIDS(I,J)=1D0
5294 100 CONTINUE
5295 110 CONTINUE
5296
5297C...Order resonances by increasing mass (except Z0 and W+/-).
5298 NRES=0
5299 DO 140 KC=1,500
5300 KF=KCHG(KC,4)
5301 IF(KF.EQ.0) GOTO 140
5302 IF(MWID(KC).EQ.0) GOTO 140
5303 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5304 IF(MSTP(1).LE.3) GOTO 140
5305 ENDIF
5306 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5307 IF(IMSS(1).LE.0) GOTO 140
5308 ENDIF
5309 NRES=NRES+1
5310 PMRES=PMAS(KC,1)
5311 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5312 DO 120 I1=NRES-1,1,-1
5313 IF(PMRES.GE.PMORD(I1)) GOTO 130
5314 KCORD(I1+1)=KCORD(I1)
5315 PMORD(I1+1)=PMORD(I1)
5316 120 CONTINUE
5317 130 KCORD(I1+1)=KC
5318 PMORD(I1+1)=PMRES
5319 140 CONTINUE
5320
5321C...Loop over possible resonances.
5322 DO 180 I=1,NRES
5323 KC=KCORD(I)
5324 KF=KCHG(KC,4)
5325
5326C...Check that no fourth generation channels on by mistake.
5327 IF(MSTP(1).LE.3) THEN
5328 DO 150 J=1,MDCY(KC,3)
5329 IDC=J+MDCY(KC,2)-1
5330 KFA1=IABS(KFDP(IDC,1))
5331 KFA2=IABS(KFDP(IDC,2))
5332 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5333 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5334 & MDME(IDC,1)=-1
5335 150 CONTINUE
5336 ENDIF
5337
5338C...Check that no supersymmetric channels on by mistake.
5339 IF(IMSS(1).LE.0) THEN
5340 DO 160 J=1,MDCY(KC,3)
5341 IDC=J+MDCY(KC,2)-1
5342 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5343 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5344 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5345 & MDME(IDC,1)=-1
5346 160 CONTINUE
5347 ENDIF
5348
5349C...Find mass and evaluate width.
5350 PMR=PMAS(KC,1)
5351 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5352 IF(MWID(KC).EQ.3) MINT(63)=1
5353 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5354 MINT(51)=0
5355
5356C...Evaluate suppression factors due to non-simulated channels.
5357 IF(KCHG(KC,3).EQ.0) THEN
5358 WDTP0I=0D0
5359 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5360 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5361 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5362 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5363 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5364 WIDS(KC,3)=0D0
5365 WIDS(KC,4)=0D0
5366 WIDS(KC,5)=0D0
5367 ELSE
5368 IF(MWID(KC).EQ.3) MINT(63)=1
5369 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5370 MINT(51)=0
5371 WDTP0I=0D0
5372 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5373 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5374 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5375 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5376 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5377 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5378 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5379 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5380 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5381 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5382 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5383 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5384 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5385 ENDIF
5386
5387C...Set resonance widths and branching ratios;
5388C...also on/off switch for decays.
5389 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5390 PMAS(KC,2)=WDTP(0)
5391 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5392 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5393 DO 170 J=1,MDCY(KC,3)
5394 IDC=J+MDCY(KC,2)-1
5395 BRAT(IDC)=0D0
5396 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5397 170 CONTINUE
5398 ENDIF
5399 180 CONTINUE
5400
5401C...Flavours of leptoquark: redefine charge and name.
5402 KFLQQ=KFDP(MDCY(42,2),1)
5403 KFLQL=KFDP(MDCY(42,2),2)
5404 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5405 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5406 LL=1
5407 IF(IABS(KFLQL).EQ.13) LL=2
5408 IF(IABS(KFLQL).EQ.15) LL=3
5409 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5410 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5411 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5412
5413C...Special cases in treatment of gamma*/Z0: redefine process name.
5414 IF(MSTP(43).EQ.1) THEN
5415 PROC(1)='f + fbar -> gamma*'
5416 PROC(15)='f + fbar -> g + gamma*'
5417 PROC(19)='f + fbar -> gamma + gamma*'
5418 PROC(30)='f + g -> f + gamma*'
5419 PROC(35)='f + gamma -> f + gamma*'
5420 ELSEIF(MSTP(43).EQ.2) THEN
5421 PROC(1)='f + fbar -> Z0'
5422 PROC(15)='f + fbar -> g + Z0'
5423 PROC(19)='f + fbar -> gamma + Z0'
5424 PROC(30)='f + g -> f + Z0'
5425 PROC(35)='f + gamma -> f + Z0'
5426 ELSEIF(MSTP(43).EQ.3) THEN
5427 PROC(1)='f + fbar -> gamma*/Z0'
5428 PROC(15)='f + fbar -> g + gamma*/Z0'
5429 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5430 PROC(30)='f + g -> f + gamma*/Z0'
5431 PROC(35)='f + gamma -> f + gamma*/Z0'
5432 ENDIF
5433
5434C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5435 IF(MSTP(44).EQ.1) THEN
5436 PROC(141)='f + fbar -> gamma*'
5437 ELSEIF(MSTP(44).EQ.2) THEN
5438 PROC(141)='f + fbar -> Z0'
5439 ELSEIF(MSTP(44).EQ.3) THEN
5440 PROC(141)='f + fbar -> Z''0'
5441 ELSEIF(MSTP(44).EQ.4) THEN
5442 PROC(141)='f + fbar -> gamma*/Z0'
5443 ELSEIF(MSTP(44).EQ.5) THEN
5444 PROC(141)='f + fbar -> gamma*/Z''0'
5445 ELSEIF(MSTP(44).EQ.6) THEN
5446 PROC(141)='f + fbar -> Z0/Z''0'
5447 ELSEIF(MSTP(44).EQ.7) THEN
5448 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5449 ENDIF
5450
5451C...Special cases in treatment of WW -> WW: redefine process name.
5452 IF(MSTP(45).EQ.1) THEN
5453 PROC(77)='W+ + W+ -> W+ + W+'
5454 ELSEIF(MSTP(45).EQ.2) THEN
5455 PROC(77)='W+ + W- -> W+ + W-'
5456 ELSEIF(MSTP(45).EQ.3) THEN
5457 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5458 ENDIF
5459
5460C...Initialize Generic Processes
5461 KFGEN=9900001
5462 KCGEN=PYCOMP(KFGEN)
5463 IF(KCGEN.GT.0) THEN
5464 IDCY=MDCY(KCGEN,2)
5465 IF(IDCY.GT.0) THEN
5466 KFF1=KFDP(IDCY+1,1)
5467 KFF2=KFDP(IDCY+1,2)
5468 KCF1=PYCOMP(KFF1)
5469 KCF2=PYCOMP(KFF2)
5470 IJ1=1
5471 IJ2=1
5472 KCI1=PYCOMP(KFDP(IDCY,1))
5473 IF(KFDP(IDCY,1).LT.0) IJ1=2
5474 KCI2=PYCOMP(KFDP(IDCY,2))
5475 IF(KFDP(IDCY,2).LT.0) IJ2=2
5476 ITMP1=0
5477 190 ITMP1=ITMP1+1
5478 IF(CHAF(KCI1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.4)
5479 & GOTO 190
5480 ITMP2=0
5481 200 ITMP2=ITMP2+1
5482 IF(CHAF(KCI2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.4)
5483 & GOTO 200
5484 PRTMP=CHAF(KCI1,IJ1)(1:ITMP1)//'+'//CHAF(KCI2,IJ2)(1:ITMP2)
5485 ITMP3=0
5486 205 ITMP3=ITMP3+1
5487 IF(PRTMP(ITMP3+1:ITMP3+1).NE.' '.AND.ITMP3.LT.9)
5488 & GOTO 205
5489 PROC(481)=PRTMP(1:ITMP3)//' -> '//CHAF(KCGEN,1)
5490 IJ1=1
5491 IJ2=1
5492 IF(KFF1.LT.0) IJ1=2
5493 IF(KFF2.LT.0) IJ2=2
5494 ITMP1=0
5495 210 ITMP1=ITMP1+1
5496 IF(CHAF(KCF1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.8)
5497 & GOTO 210
5498 ITMP2=0
5499 220 ITMP2=ITMP2+1
5500 IF(CHAF(KCF2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.8)
5501 & GOTO 220
5502 PROC(482)=PRTMP(1:ITMP3)//' -> '//CHAF(KCF1,IJ1)(1:ITMP1)//
5503 & '+'//CHAF(KCF2,IJ2)(1:ITMP2)
5504 ENDIF
5505 ENDIF
5506
5507
5508
5509C...Format for error information.
5510 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5511 &'combination'/1X,'Execution stopped!')
5512
5513 RETURN
5514 END
5515
5516C*********************************************************************
5517
5518C...PYINBM
5519C...Identifies the two incoming particles and the choice of frame.
5520
5521 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5522
5523C...Double precision and integer declarations.
5524 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5525 IMPLICIT INTEGER(I-N)
5526 INTEGER PYK,PYCHGE,PYCOMP
5527
5528C...User process initialization commonblock.
5529 INTEGER MAXPUP
5530 PARAMETER (MAXPUP=100)
5531 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5532 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5533 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5534 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5535 &LPRUP(MAXPUP)
5536 SAVE /HEPRUP/
5537
5538C...Commonblocks.
5539 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5540 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5541 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5542 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5543 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5544 COMMON/PYINT1/MINT(400),VINT(400)
5545 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5546
5547C...Local arrays, character variables and data.
5548 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5549 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5550 DIMENSION LEN(3),KCDE(39),PM(2)
5551 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5552 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5553 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5554 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5555 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5556 &'nu_taubar ','pi+ ','pi- ','n0 ',
5557 &'nbar0 ','p+ ','pbar- ','gamma ',
5558 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5559 &'xi- ','xi0 ','omega- ','pi0 ',
5560 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5561 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5562 &'k+ ','k- ','ks0 ','kl0 '/
5563 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5564 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5565 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5566
5567C...Store initial energy. Default frame.
5568 VINT(290)=WIN
5569 MINT(111)=0
5570
5571C...Special user process initialization; convert to normal input.
5572 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5573 MINT(111)=11
5574 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5575 CALL PYNAME(IDBMUP(1),CHNAME)
5576 CHBEAM=CHNAME(1:12)
5577 CALL PYNAME(IDBMUP(2),CHNAME)
5578 CHTARG=CHNAME(1:12)
5579 ENDIF
5580
5581C...Convert character variables to lowercase and find their length.
5582 CHCOM(1)=CHFRAM
5583 CHCOM(2)=CHBEAM
5584 CHCOM(3)=CHTARG
5585 DO 130 I=1,3
5586 LEN(I)=12
5587 DO 110 LL=12,1,-1
5588 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5589 DO 100 LA=1,26
5590 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5591 & CHALP(1)(LA:LA)
5592 100 CONTINUE
5593 110 CONTINUE
5594 CHIDNT(I)=CHCOM(I)
5595
5596C...Fix up bar, underscore and charge in particle name (if needed).
5597 DO 120 LL=1,10
5598 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5599 CHTEMP=CHIDNT(I)
5600 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5601 ENDIF
5602 120 CONTINUE
5603 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5604 CHTEMP=CHIDNT(I)
5605 CHIDNT(I)='nu_'//CHTEMP(3:7)
5606 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5607 CHIDNT(I)(1:3)='n0 '
5608 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5609 CHIDNT(I)(1:5)='nbar0'
5610 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5611 CHIDNT(I)(1:3)='p+ '
5612 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5613 & CHIDNT(I)(1:2).EQ.'p-') THEN
5614 CHIDNT(I)(1:5)='pbar-'
5615 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5616 CHIDNT(I)(7:7)='0'
5617 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5618 CHIDNT(I)(1:7)='reggeon'
5619 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5620 CHIDNT(I)(1:7)='pomeron'
5621 ENDIF
5622 130 CONTINUE
5623
5624C...Identify free initialization.
5625 IF(CHCOM(1)(1:2).EQ.'no') THEN
5626 MINT(65)=1
5627 RETURN
5628 ENDIF
5629
5630C...Identify incoming beam and target particles.
5631 DO 160 I=1,2
5632 DO 140 J=1,39
5633 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5634 140 CONTINUE
5635 PM(I)=PYMASS(MINT(10+I))
5636 VINT(2+I)=PM(I)
5637 MINT(140+I)=0
5638 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5639 CHTEMP=CHIDNT(I+1)(7:12)//' '
5640 DO 150 J=1,12
5641 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5642 150 CONTINUE
5643 PM(I)=PYMASS(MINT(140+I))
5644 VINT(302+I)=PM(I)
5645 ENDIF
5646 160 CONTINUE
5647 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5648 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5649 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
5650
5651C...Identify choice of frame and input energies.
5652 CHINIT=' '
5653
5654C...Events defined in the CM frame.
5655 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5656 MINT(111)=1
5657 S=WIN**2
5658 IF(MSTP(122).GE.1) THEN
5659 IF(CHCOM(2)(1:1).NE.'e') THEN
5660 LOFFS=(31-(LEN(2)+LEN(3)))/2
5661 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5662 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5663 & ' collider'//' '
5664 ELSE
5665 LOFFS=(30-(LEN(2)+LEN(3)))/2
5666 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5667 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5668 & ' collider'//' '
5669 ENDIF
5670 WRITE(MSTU(11),5200) CHINIT
5671 WRITE(MSTU(11),5300) WIN
5672 ENDIF
5673
5674C...Events defined in fixed target frame.
5675 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5676 MINT(111)=2
5677 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5678 IF(MSTP(122).GE.1) THEN
5679 LOFFS=(29-(LEN(2)+LEN(3)))/2
5680 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5681 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5682 & ' fixed target'//' '
5683 WRITE(MSTU(11),5200) CHINIT
5684 WRITE(MSTU(11),5400) WIN
5685 WRITE(MSTU(11),5500) SQRT(S)
5686 ENDIF
5687
5688C...Frame defined by user three-vectors.
5689 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5690 MINT(111)=3
5691 P(1,5)=PM(1)
5692 P(2,5)=PM(2)
5693 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5694 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5695 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5696 & (P(1,3)+P(2,3))**2
5697 IF(MSTP(122).GE.1) THEN
5698 LOFFS=(22-(LEN(2)+LEN(3)))/2
5699 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5700 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5701 & ' user configuration'//' '
5702 WRITE(MSTU(11),5200) CHINIT
5703 WRITE(MSTU(11),5600)
5704 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5705 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5706 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5707 ENDIF
5708
5709C...Frame defined by user four-vectors.
5710 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5711 MINT(111)=4
5712 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5713 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5714 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5715 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5716 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5717 & (P(1,3)+P(2,3))**2
5718 IF(MSTP(122).GE.1) THEN
5719 LOFFS=(22-(LEN(2)+LEN(3)))/2
5720 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5721 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5722 & ' user configuration'//' '
5723 WRITE(MSTU(11),5200) CHINIT
5724 WRITE(MSTU(11),5600)
5725 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5726 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5727 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5728 ENDIF
5729
5730C...Frame defined by user five-vectors.
5731 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5732 MINT(111)=5
5733 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5734 & (P(1,3)+P(2,3))**2
5735 IF(MSTP(122).GE.1) THEN
5736 LOFFS=(22-(LEN(2)+LEN(3)))/2
5737 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5738 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5739 & ' user configuration'//' '
5740 WRITE(MSTU(11),5200) CHINIT
5741 WRITE(MSTU(11),5600)
5742 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5743 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5744 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5745 ENDIF
5746
5747C...Frame defined by HEPRUP common block.
5748 ELSEIF(MINT(111).GE.11) THEN
5749 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5750 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5751 IF(MSTP(122).GE.1) THEN
5752 LOFFS=(22-(LEN(2)+LEN(3)))/2
5753 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5754 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5755 & ' user configuration'//' '
5756 WRITE(MSTU(11),5200) CHINIT
5757 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5758 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5759 ENDIF
5760
5761C...Unknown frame. Error for too low CM energy.
5762 ELSE
5763 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5764 CALL PYSTOP(7)
5765 ENDIF
5766 IF(S.LT.PARP(2)**2) THEN
5767 WRITE(MSTU(11),5900) SQRT(S)
5768 CALL PYSTOP(7)
5769 ENDIF
5770
5771C...Formats for initialization and error information.
5772 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5773 &1X,'Execution stopped!')
5774 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5775 &1X,'Execution stopped!')
5776 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5777 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5778 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5779 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5780 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5781 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5782 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5783 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5784 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5785 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5786 &1X,'Execution stopped!')
5787 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5788 &'generation.'/1X,'Execution stopped!')
5789 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5790 &'GeV beam energies',13X,'I')
5791
5792 RETURN
5793 END
5794
5795C*********************************************************************
5796
5797C...PYINKI
5798C...Sets up kinematics, including rotations and boosts to/from CM frame.
5799
5800 SUBROUTINE PYINKI(MODKI)
5801
5802C...Double precision and integer declarations.
5803 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5804 IMPLICIT INTEGER(I-N)
5805 INTEGER PYK,PYCHGE,PYCOMP
5806
5807C...User process initialization commonblock.
5808 INTEGER MAXPUP
5809 PARAMETER (MAXPUP=100)
5810 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5811 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5812 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5813 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5814 &LPRUP(MAXPUP)
5815 SAVE /HEPRUP/
5816
5817C...Commonblocks.
5818 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5819 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5820 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5821 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5822 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5823 COMMON/PYINT1/MINT(400),VINT(400)
5824 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5825
5826C...Set initial flavour state.
5827 N=2
5828 DO 100 I=1,2
5829 K(I,1)=1
5830 K(I,2)=MINT(10+I)
5831 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5832 100 CONTINUE
5833
5834C...Reset boost. Do kinematics for various cases.
5835 DO 110 J=6,10
5836 VINT(J)=0D0
5837 110 CONTINUE
5838
5839C...Set up kinematics for events defined in CM frame.
5840 IF(MINT(111).EQ.1) THEN
5841 WIN=VINT(290)
5842 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5843 S=WIN**2
5844 P(1,5)=VINT(3)
5845 P(2,5)=VINT(4)
5846 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5847 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5848 P(1,1)=0D0
5849 P(1,2)=0D0
5850 P(2,1)=0D0
5851 P(2,2)=0D0
5852 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5853 & (4D0*S))
5854 P(2,3)=-P(1,3)
5855 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5856 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5857
5858C...Set up kinematics for fixed target events.
5859 ELSEIF(MINT(111).EQ.2) THEN
5860 WIN=VINT(290)
5861 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5862 P(1,5)=VINT(3)
5863 P(2,5)=VINT(4)
5864 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5865 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5866 P(1,1)=0D0
5867 P(1,2)=0D0
5868 P(2,1)=0D0
5869 P(2,2)=0D0
5870 P(1,3)=WIN
5871 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5872 P(2,3)=0D0
5873 P(2,4)=P(2,5)
5874 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5875 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5876 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5877
5878C...Set up kinematics for events in user-defined frame.
5879 ELSEIF(MINT(111).EQ.3) THEN
5880 P(1,5)=VINT(3)
5881 P(2,5)=VINT(4)
5882 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5883 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5884 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5885 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5886 DO 120 J=1,3
5887 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5888 120 CONTINUE
5889 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5890 VINT(7)=PYANGL(P(1,1),P(1,2))
5891 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5892 VINT(6)=PYANGL(P(1,3),P(1,1))
5893 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5894 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5895
5896C...Set up kinematics for events with user-defined four-vectors.
5897 ELSEIF(MINT(111).EQ.4) THEN
5898 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5899 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5900 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5901 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5902 DO 130 J=1,3
5903 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5904 130 CONTINUE
5905 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5906 VINT(7)=PYANGL(P(1,1),P(1,2))
5907 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5908 VINT(6)=PYANGL(P(1,3),P(1,1))
5909 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5910 S=(P(1,4)+P(2,4))**2
5911
5912C...Set up kinematics for events with user-defined five-vectors.
5913 ELSEIF(MINT(111).EQ.5) THEN
5914 DO 140 J=1,3
5915 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5916 140 CONTINUE
5917 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5918 VINT(7)=PYANGL(P(1,1),P(1,2))
5919 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5920 VINT(6)=PYANGL(P(1,3),P(1,1))
5921 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5922 S=(P(1,4)+P(2,4))**2
5923
5924C...Set up kinematics for events with external user processes.
5925 ELSEIF(MINT(111).GE.11) THEN
5926 P(1,5)=VINT(3)
5927 P(2,5)=VINT(4)
5928 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5929 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5930 P(1,1)=0D0
5931 P(1,2)=0D0
5932 P(2,1)=0D0
5933 P(2,2)=0D0
5934 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5935 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5936 P(1,4)=EBMUP(1)
5937 P(2,4)=EBMUP(2)
5938 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5939 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5940 S=(P(1,4)+P(2,4))**2
5941 ENDIF
5942
5943C...Return or error for too low CM energy.
5944 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5945 IF(MSTP(172).LE.1) THEN
5946 CALL PYERRM(23,
5947 & '(PYINKI:) too low invariant mass in this event')
5948 ELSE
5949 MSTI(61)=1
5950 RETURN
5951 ENDIF
5952 ENDIF
5953
5954C...Save information on incoming particles.
5955 VINT(1)=SQRT(S)
5956 VINT(2)=S
5957 IF(MINT(111).GE.4) THEN
5958 IF(MINT(141).EQ.0) THEN
5959 VINT(3)=P(1,5)
5960 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5961 ELSE
5962 VINT(303)=P(1,5)
5963 ENDIF
5964 IF(MINT(142).EQ.0) THEN
5965 VINT(4)=P(2,5)
5966 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5967 ELSE
5968 VINT(304)=P(2,5)
5969 ENDIF
5970 ENDIF
5971 VINT(5)=P(1,3)
5972 IF(MODKI.EQ.0) VINT(289)=S
5973 DO 150 J=1,5
5974 V(1,J)=0D0
5975 V(2,J)=0D0
5976 VINT(290+J)=P(1,J)
5977 VINT(295+J)=P(2,J)
5978 150 CONTINUE
5979
5980C...Store pT cut-off and related constants to be used in generation.
5981 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5982 IF(MSTP(82).LE.1) THEN
5983 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5984 ELSE
5985 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5986 ENDIF
5987 VINT(149)=4D0*PTMN**2/S
5988 VINT(154)=PTMN
5989
5990 RETURN
5991 END
5992
5993C*********************************************************************
5994
5995C...PYINPR
5996C...Selects partonic subprocesses to be included in the simulation.
5997
5998 SUBROUTINE PYINPR
5999
6000C...Double precision and integer declarations.
6001 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6002 IMPLICIT INTEGER(I-N)
6003 INTEGER PYK,PYCHGE,PYCOMP
6004
6005C...User process initialization commonblock.
6006 INTEGER MAXPUP
6007 PARAMETER (MAXPUP=100)
6008 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
6009 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
6010 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
6011 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
6012 &LPRUP(MAXPUP)
6013 SAVE /HEPRUP/
6014
6015C...Commonblocks and character variables.
6016 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6017 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6018 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
6019 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6020 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6021 COMMON/PYINT1/MINT(400),VINT(400)
6022 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6023 COMMON/PYINT6/PROC(0:500)
6024 CHARACTER PROC*28
6025 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
6026 &/PYINT2/,/PYINT6/
6027 CHARACTER CHIPR*10
6028
6029
6030C...Reset processes to be included.
6031 IF(MSEL.NE.0) THEN
6032 DO 100 I=1,500
6033 MSUB(I)=0
6034 100 CONTINUE
6035 ENDIF
6036
6037C...Set running pTmin scale.
6038 IF(MSTP(82).LE.1) THEN
6039 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6040 ELSE
6041 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6042 ENDIF
6043
6044C...Begin by assuming incoming photon to enter subprocess.
6045 IF(MINT(11).EQ.22) MINT(15)=22
6046 IF(MINT(12).EQ.22) MINT(16)=22
6047
6048C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
6049 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
6050 MSUB(10)=1
6051 MINT(123)=MINT(122)+1
6052
6053C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
6054C...allow mixture.
6055C...Here also set a few parameters otherwise normally not touched.
6056 ELSEIF(MINT(121).GT.1) THEN
6057
6058C...Parton distributions dampened at small Q2; go to low energies,
6059C...alpha_s <1; no minimum pT cut-off a priori.
6060 IF(MSTP(18).EQ.2) THEN
6061 MSTP(57)=3
6062 PARP(2)=2D0
6063 PARU(115)=1D0
6064 CKIN(5)=0.2D0
6065 CKIN(6)=0.2D0
6066 ENDIF
6067
6068C...Define pT cut-off parameters and whether run involves low-pT.
6069 PTMVMD=PTMRUN
6070 VINT(154)=PTMVMD
6071 PTMDIR=PTMVMD
6072 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6073 PTMANO=PTMVMD
6074 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
6075 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
6076 IPTL=1
6077 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
6078 IF(MSEL.EQ.2) IPTL=1
6079
6080C...Set up for p/gamma * gamma; real or virtual photons.
6081 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
6082 & MSTP(14).EQ.30)) THEN
6083
6084C...Set up for p/VMD * VMD.
6085 IF(MINT(122).EQ.1) THEN
6086 MINT(123)=2
6087 MSUB(11)=1
6088 MSUB(12)=1
6089 MSUB(13)=1
6090 MSUB(28)=1
6091 MSUB(53)=1
6092 MSUB(68)=1
6093 IF(IPTL.EQ.1) MSUB(95)=1
6094 IF(MSEL.EQ.2) THEN
6095 MSUB(91)=1
6096 MSUB(92)=1
6097 MSUB(93)=1
6098 MSUB(94)=1
6099 ENDIF
6100 IF(IPTL.EQ.1) CKIN(3)=0D0
6101
6102C...Set up for p/VMD * direct gamma.
6103 ELSEIF(MINT(122).EQ.2) THEN
6104 MINT(123)=0
6105 IF(MINT(121).EQ.6) MINT(123)=5
6106 MSUB(131)=1
6107 MSUB(132)=1
6108 MSUB(135)=1
6109 MSUB(136)=1
6110 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6111
6112C...Set up for p/VMD * anomalous gamma.
6113 ELSEIF(MINT(122).EQ.3) THEN
6114 MINT(123)=3
6115 IF(MINT(121).EQ.6) MINT(123)=7
6116 MSUB(11)=1
6117 MSUB(12)=1
6118 MSUB(13)=1
6119 MSUB(28)=1
6120 MSUB(53)=1
6121 MSUB(68)=1
6122 IF(IPTL.EQ.1) MSUB(95)=1
6123 IF(MSEL.EQ.2) THEN
6124 MSUB(91)=1
6125 MSUB(92)=1
6126 MSUB(93)=1
6127 MSUB(94)=1
6128 ENDIF
6129 IF(IPTL.EQ.1) CKIN(3)=0D0
6130
6131C...Set up for DIS * p.
6132 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
6133 & IABS(MINT(12)).GT.100)) THEN
6134 MINT(123)=8
6135 IF(IPTL.EQ.1) MSUB(99)=1
6136
6137C...Set up for direct * direct gamma (switch off leptons).
6138 ELSEIF(MINT(122).EQ.4) THEN
6139 MINT(123)=0
6140 MSUB(137)=1
6141 MSUB(138)=1
6142 MSUB(139)=1
6143 MSUB(140)=1
6144 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6145 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6146 110 CONTINUE
6147 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6148
6149C...Set up for direct * anomalous gamma.
6150 ELSEIF(MINT(122).EQ.5) THEN
6151 MINT(123)=6
6152 MSUB(131)=1
6153 MSUB(132)=1
6154 MSUB(135)=1
6155 MSUB(136)=1
6156 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6157
6158C...Set up for anomalous * anomalous gamma.
6159 ELSEIF(MINT(122).EQ.6) THEN
6160 MINT(123)=3
6161 MSUB(11)=1
6162 MSUB(12)=1
6163 MSUB(13)=1
6164 MSUB(28)=1
6165 MSUB(53)=1
6166 MSUB(68)=1
6167 IF(IPTL.EQ.1) MSUB(95)=1
6168 IF(MSEL.EQ.2) THEN
6169 MSUB(91)=1
6170 MSUB(92)=1
6171 MSUB(93)=1
6172 MSUB(94)=1
6173 ENDIF
6174 IF(IPTL.EQ.1) CKIN(3)=0D0
6175 ENDIF
6176
6177C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
6178 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6179
6180C...Set up for direct * direct gamma (switch off leptons).
6181 IF(MINT(122).EQ.1) THEN
6182 MINT(123)=0
6183 MSUB(137)=1
6184 MSUB(138)=1
6185 MSUB(139)=1
6186 MSUB(140)=1
6187 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6188 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6189 120 CONTINUE
6190 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6191
6192C...Set up for direct * VMD and VMD * direct gamma.
6193 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
6194 MINT(123)=5
6195 MSUB(131)=1
6196 MSUB(132)=1
6197 MSUB(135)=1
6198 MSUB(136)=1
6199 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6200
6201C...Set up for direct * anomalous and anomalous * direct gamma.
6202 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
6203 MINT(123)=6
6204 MSUB(131)=1
6205 MSUB(132)=1
6206 MSUB(135)=1
6207 MSUB(136)=1
6208 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6209
6210C...Set up for VMD*VMD.
6211 ELSEIF(MINT(122).EQ.5) THEN
6212 MINT(123)=2
6213 MSUB(11)=1
6214 MSUB(12)=1
6215 MSUB(13)=1
6216 MSUB(28)=1
6217 MSUB(53)=1
6218 MSUB(68)=1
6219 IF(IPTL.EQ.1) MSUB(95)=1
6220 IF(MSEL.EQ.2) THEN
6221 MSUB(91)=1
6222 MSUB(92)=1
6223 MSUB(93)=1
6224 MSUB(94)=1
6225 ENDIF
6226 IF(IPTL.EQ.1) CKIN(3)=0D0
6227
6228C...Set up for VMD * anomalous and anomalous * VMD gamma.
6229 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
6230 MINT(123)=7
6231 MSUB(11)=1
6232 MSUB(12)=1
6233 MSUB(13)=1
6234 MSUB(28)=1
6235 MSUB(53)=1
6236 MSUB(68)=1
6237 IF(IPTL.EQ.1) MSUB(95)=1
6238 IF(MSEL.EQ.2) THEN
6239 MSUB(91)=1
6240 MSUB(92)=1
6241 MSUB(93)=1
6242 MSUB(94)=1
6243 ENDIF
6244 IF(IPTL.EQ.1) CKIN(3)=0D0
6245
6246C...Set up for anomalous * anomalous gamma.
6247 ELSEIF(MINT(122).EQ.9) THEN
6248 MINT(123)=3
6249 MSUB(11)=1
6250 MSUB(12)=1
6251 MSUB(13)=1
6252 MSUB(28)=1
6253 MSUB(53)=1
6254 MSUB(68)=1
6255 IF(IPTL.EQ.1) MSUB(95)=1
6256 IF(MSEL.EQ.2) THEN
6257 MSUB(91)=1
6258 MSUB(92)=1
6259 MSUB(93)=1
6260 MSUB(94)=1
6261 ENDIF
6262 IF(IPTL.EQ.1) CKIN(3)=0D0
6263
6264C...Set up for DIS * VMD and VMD * DIS gamma.
6265 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
6266 MINT(123)=8
6267 IF(IPTL.EQ.1) MSUB(99)=1
6268
6269C...Set up for DIS * anomalous and anomalous * DIS gamma.
6270 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
6271 MINT(123)=9
6272 IF(IPTL.EQ.1) MSUB(99)=1
6273 ENDIF
6274
6275C...Set up for gamma* * p; virtual photons = dir, res.
6276 ELSEIF(MINT(121).EQ.2) THEN
6277
6278C...Set up for direct * p.
6279 IF(MINT(122).EQ.1) THEN
6280 MINT(123)=0
6281 MSUB(131)=1
6282 MSUB(132)=1
6283 MSUB(135)=1
6284 MSUB(136)=1
6285 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6286
6287C...Set up for resolved * p.
6288 ELSEIF(MINT(122).EQ.2) THEN
6289 MINT(123)=1
6290 MSUB(11)=1
6291 MSUB(12)=1
6292 MSUB(13)=1
6293 MSUB(28)=1
6294 MSUB(53)=1
6295 MSUB(68)=1
6296 IF(IPTL.EQ.1) MSUB(95)=1
6297 IF(MSEL.EQ.2) THEN
6298 MSUB(91)=1
6299 MSUB(92)=1
6300 MSUB(93)=1
6301 MSUB(94)=1
6302 ENDIF
6303 IF(IPTL.EQ.1) CKIN(3)=0D0
6304 ENDIF
6305
6306C...Set up for gamma* * gamma*; virtual photons = dir, res.
6307 ELSEIF(MINT(121).EQ.4) THEN
6308
6309C...Set up for direct * direct gamma (switch off leptons).
6310 IF(MINT(122).EQ.1) THEN
6311 MINT(123)=0
6312 MSUB(137)=1
6313 MSUB(138)=1
6314 MSUB(139)=1
6315 MSUB(140)=1
6316 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6317 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6318 130 CONTINUE
6319 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6320
6321C...Set up for direct * resolved and resolved * direct gamma.
6322 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6323 MINT(123)=5
6324 MSUB(131)=1
6325 MSUB(132)=1
6326 MSUB(135)=1
6327 MSUB(136)=1
6328 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6329
6330C...Set up for resolved * resolved gamma.
6331 ELSEIF(MINT(122).EQ.4) THEN
6332 MINT(123)=2
6333 MSUB(11)=1
6334 MSUB(12)=1
6335 MSUB(13)=1
6336 MSUB(28)=1
6337 MSUB(53)=1
6338 MSUB(68)=1
6339 IF(IPTL.EQ.1) MSUB(95)=1
6340 IF(MSEL.EQ.2) THEN
6341 MSUB(91)=1
6342 MSUB(92)=1
6343 MSUB(93)=1
6344 MSUB(94)=1
6345 ENDIF
6346 IF(IPTL.EQ.1) CKIN(3)=0D0
6347 ENDIF
6348
6349C...End of special set up for gamma-p and gamma-gamma.
6350 ENDIF
6351 CKIN(1)=2D0*CKIN(3)
6352 ENDIF
6353
6354C...Flavour information for individual beams.
6355 DO 140 I=1,2
6356 MINT(40+I)=1
6357 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6358 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6359 MINT(44+I)=MINT(40+I)
6360 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6361 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6362 140 CONTINUE
6363
6364C...If two real gammas, whereof one direct, pick the first.
6365C...For two virtual photons, keep requested order.
6366 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6367 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6368 MINT(41)=1
6369 MINT(45)=1
6370 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6371 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6372 MINT(41)=1
6373 MINT(45)=1
6374 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6375 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6376 MINT(42)=1
6377 MINT(46)=1
6378 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6379 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6380 MINT(41)=1
6381 MINT(45)=1
6382 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6383 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6384 MINT(42)=1
6385 MINT(46)=1
6386 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6387 MINT(41)=1
6388 MINT(45)=1
6389 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6390 MINT(42)=1
6391 MINT(46)=1
6392 ENDIF
6393 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6394 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6395 IF(MINT(11).EQ.22) THEN
6396 MINT(41)=1
6397 MINT(45)=1
6398 ELSE
6399 MINT(42)=1
6400 MINT(46)=1
6401 ENDIF
6402 ENDIF
6403 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6404 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6405 ENDIF
6406
6407C...Flavour information on combination of incoming particles.
6408 MINT(43)=2*MINT(41)+MINT(42)-2
6409 MINT(44)=MINT(43)
6410 IF(MINT(123).LE.0) THEN
6411 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6412 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6413 ELSEIF(MINT(123).LE.3) THEN
6414 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6415 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6416 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6417 MINT(43)=4
6418 MINT(44)=1
6419 ENDIF
6420 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6421 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6422 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6423 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6424 MINT(50)=0
6425 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6426 MINT(107)=0
6427 MINT(108)=0
6428 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6429 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6430 & MINT(107)=2
6431 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6432 & MINT(107)=3
6433 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6434 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6435 & MINT(122).EQ.10) MINT(108)=2
6436 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6437 & MINT(122).EQ.11) MINT(108)=3
6438 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6439 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6440 IF(MINT(122).GE.3) MINT(107)=1
6441 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6442 ELSEIF(MINT(121).EQ.2) THEN
6443 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6444 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6445 ELSE
6446 IF(MINT(11).EQ.22) THEN
6447 MINT(107)=MINT(123)
6448 IF(MINT(123).GE.4) MINT(107)=0
6449 IF(MINT(123).EQ.7) MINT(107)=2
6450 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6451 IF(MSTP(14).EQ.28) MINT(107)=2
6452 IF(MSTP(14).EQ.29) MINT(107)=3
6453 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6454 & MINT(107)=4
6455 ENDIF
6456 IF(MINT(12).EQ.22) THEN
6457 MINT(108)=MINT(123)
6458 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6459 IF(MINT(123).EQ.7) MINT(108)=3
6460 IF(MSTP(14).EQ.26) MINT(108)=2
6461 IF(MSTP(14).EQ.27) MINT(108)=3
6462 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6463 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6464 & MINT(108)=4
6465 ENDIF
6466 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6467 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6468 MINTTP=MINT(107)
6469 MINT(107)=MINT(108)
6470 MINT(108)=MINTTP
6471 ENDIF
6472 ENDIF
6473 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6474 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6475
6476C...Select default processes according to incoming beams
6477C...(already done for gamma-p and gamma-gamma with
6478C...MSTP(14) = 10, 20, 25 or 30).
6479 IF(MINT(121).GT.1) THEN
6480 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6481
6482 IF(MINT(43).EQ.1) THEN
6483C...Lepton + lepton -> gamma/Z0 or W.
6484 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6485 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6486
6487 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6488 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6489C...Unresolved photon + lepton: Compton scattering.
6490 MSUB(133)=1
6491 MSUB(134)=1
6492
6493 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6494 & .OR.MINT(12).EQ.22)) THEN
6495C...DIS as pure gamma* + f -> f process.
6496 MSUB(99)=1
6497
6498 ELSEIF(MINT(43).LE.3) THEN
6499C...Lepton + hadron: deep inelastic scattering.
6500 MSUB(10)=1
6501
6502 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6503 & MINT(12).EQ.22) THEN
6504C...Two unresolved photons: fermion pair production,
6505C...exclude lepton pairs.
6506 DO 150 ISUB=137,140
6507 MSUB(ISUB)=1
6508 150 CONTINUE
6509 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6510 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6511 160 CONTINUE
6512 PTMDIR=PTMRUN
6513 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6514 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6515 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6516
6517 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6518 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6519 & MINT(12).EQ.22)) THEN
6520C...Unresolved photon + hadron: photon-parton scattering.
6521 DO 170 ISUB=131,136
6522 MSUB(ISUB)=1
6523 170 CONTINUE
6524
6525 ELSEIF(MSEL.EQ.1) THEN
6526C...High-pT QCD processes:
6527 MSUB(11)=1
6528 MSUB(12)=1
6529 MSUB(13)=1
6530 MSUB(28)=1
6531 MSUB(53)=1
6532 MSUB(68)=1
6533 PTMN=PTMRUN
6534 VINT(154)=PTMN
6535 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6536 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6537
6538 ELSE
6539C...All QCD processes:
6540 MSUB(11)=1
6541 MSUB(12)=1
6542 MSUB(13)=1
6543 MSUB(28)=1
6544 MSUB(53)=1
6545 MSUB(68)=1
6546 MSUB(91)=1
6547 MSUB(92)=1
6548 MSUB(93)=1
6549 MSUB(94)=1
6550 MSUB(95)=1
6551 ENDIF
6552
6553 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6554C...Heavy quark production.
6555 MSUB(81)=1
6556 MSUB(82)=1
6557 MSUB(84)=1
6558 DO 180 J=1,MIN(8,MDCY(21,3))
6559 MDME(MDCY(21,2)+J-1,1)=0
6560 180 CONTINUE
6561 MDME(MDCY(21,2)+MSEL-1,1)=1
6562 MSUB(85)=1
6563 DO 190 J=1,MIN(12,MDCY(22,3))
6564 MDME(MDCY(22,2)+J-1,1)=0
6565 190 CONTINUE
6566 MDME(MDCY(22,2)+MSEL-1,1)=1
6567
6568 ELSEIF(MSEL.EQ.10) THEN
6569C...Prompt photon production:
6570 MSUB(14)=1
6571 MSUB(18)=1
6572 MSUB(29)=1
6573
6574 ELSEIF(MSEL.EQ.11) THEN
6575C...Z0/gamma* production:
6576 MSUB(1)=1
6577
6578 ELSEIF(MSEL.EQ.12) THEN
6579C...W+/- production:
6580 MSUB(2)=1
6581
6582 ELSEIF(MSEL.EQ.13) THEN
6583C...Z0 + jet:
6584 MSUB(15)=1
6585 MSUB(30)=1
6586
6587 ELSEIF(MSEL.EQ.14) THEN
6588C...W+/- + jet:
6589 MSUB(16)=1
6590 MSUB(31)=1
6591
6592 ELSEIF(MSEL.EQ.15) THEN
6593C...Z0 & W+/- pair production:
6594 MSUB(19)=1
6595 MSUB(20)=1
6596 MSUB(22)=1
6597 MSUB(23)=1
6598 MSUB(25)=1
6599
6600 ELSEIF(MSEL.EQ.16) THEN
6601C...h0 production:
6602 MSUB(3)=1
6603 MSUB(102)=1
6604 MSUB(103)=1
6605 MSUB(123)=1
6606 MSUB(124)=1
6607
6608 ELSEIF(MSEL.EQ.17) THEN
6609C...h0 & Z0 or W+/- pair production:
6610 MSUB(24)=1
6611 MSUB(26)=1
6612
6613 ELSEIF(MSEL.EQ.18) THEN
6614C...h0 production; interesting processes in e+e-.
6615 MSUB(24)=1
6616 MSUB(103)=1
6617 MSUB(123)=1
6618 MSUB(124)=1
6619
6620 ELSEIF(MSEL.EQ.19) THEN
6621C...h0, H0 and A0 production; interesting processes in e+e-.
6622 MSUB(24)=1
6623 MSUB(103)=1
6624 MSUB(123)=1
6625 MSUB(124)=1
6626 MSUB(153)=1
6627 MSUB(171)=1
6628 MSUB(173)=1
6629 MSUB(174)=1
6630 MSUB(158)=1
6631 MSUB(176)=1
6632 MSUB(178)=1
6633 MSUB(179)=1
6634
6635 ELSEIF(MSEL.EQ.21) THEN
6636C...Z'0 production:
6637 MSUB(141)=1
6638
6639 ELSEIF(MSEL.EQ.22) THEN
6640C...W'+/- production:
6641 MSUB(142)=1
6642
6643 ELSEIF(MSEL.EQ.23) THEN
6644C...H+/- production:
6645 MSUB(143)=1
6646
6647 ELSEIF(MSEL.EQ.24) THEN
6648C...R production:
6649 MSUB(144)=1
6650
6651 ELSEIF(MSEL.EQ.25) THEN
6652C...LQ (leptoquark) production.
6653 MSUB(145)=1
6654 MSUB(162)=1
6655 MSUB(163)=1
6656 MSUB(164)=1
6657
6658 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6659C...Production of one heavy quark (W exchange):
6660 MSUB(83)=1
6661 DO 200 J=1,MIN(8,MDCY(21,3))
6662 MDME(MDCY(21,2)+J-1,1)=0
6663 200 CONTINUE
6664 MDME(MDCY(21,2)+MSEL-31,1)=1
6665
6666CMRENNA++Define SUSY alternatives.
6667 ELSEIF(MSEL.EQ.39) THEN
6668C...Turn on all SUSY processes.
6669 IF(MINT(43).EQ.4) THEN
6670C...Hadron-hadron processes.
6671 DO 210 I=201,296
6672 IF(ISET(I).GE.0) MSUB(I)=1
6673 210 CONTINUE
6674 ELSEIF(MINT(43).EQ.1) THEN
6675C...Lepton-lepton processes: QED production of squarks.
6676 DO 220 I=201,214
6677 MSUB(I)=1
6678 220 CONTINUE
6679 MSUB(210)=0
6680 MSUB(211)=0
6681 MSUB(212)=0
6682 DO 230 I=216,228
6683 MSUB(I)=1
6684 230 CONTINUE
6685 DO 240 I=261,263
6686 MSUB(I)=1
6687 240 CONTINUE
6688 MSUB(277)=1
6689 MSUB(278)=1
6690 ENDIF
6691
6692 ELSEIF(MSEL.EQ.40) THEN
6693C...Gluinos and squarks.
6694 IF(MINT(43).EQ.4) THEN
6695 MSUB(243)=1
6696 MSUB(244)=1
6697 MSUB(258)=1
6698 MSUB(259)=1
6699 MSUB(261)=1
6700 MSUB(262)=1
6701 MSUB(264)=1
6702 MSUB(265)=1
6703 DO 250 I=271,296
6704 MSUB(I)=1
6705 250 CONTINUE
6706 ELSEIF(MINT(43).EQ.1) THEN
6707 MSUB(277)=1
6708 MSUB(278)=1
6709 ENDIF
6710
6711 ELSEIF(MSEL.EQ.41) THEN
6712C...Stop production.
6713 MSUB(261)=1
6714 MSUB(262)=1
6715 MSUB(263)=1
6716 IF(MINT(43).EQ.4) THEN
6717 MSUB(264)=1
6718 MSUB(265)=1
6719 ENDIF
6720
6721 ELSEIF(MSEL.EQ.42) THEN
6722C...Slepton production.
6723 DO 260 I=201,214
6724 MSUB(I)=1
6725 260 CONTINUE
6726 IF(MINT(43).NE.4) THEN
6727 MSUB(210)=0
6728 MSUB(211)=0
6729 MSUB(212)=0
6730 ENDIF
6731
6732 ELSEIF(MSEL.EQ.43) THEN
6733C...Neutralino/Chargino + Gluino/Squark.
6734 IF(MINT(43).EQ.4) THEN
6735 DO 270 I=237,242
6736 MSUB(I)=1
6737 270 CONTINUE
6738 DO 280 I=246,254
6739 MSUB(I)=1
6740 280 CONTINUE
6741 MSUB(256)=1
6742 ENDIF
6743
6744 ELSEIF(MSEL.EQ.44) THEN
6745C...Neutralino/Chargino pair production.
6746 IF(MINT(43).EQ.4) THEN
6747 DO 290 I=216,236
6748 MSUB(I)=1
6749 290 CONTINUE
6750 ELSEIF(MINT(43).EQ.1) THEN
6751 DO 300 I=216,228
6752 MSUB(I)=1
6753 300 CONTINUE
6754 ENDIF
6755
6756 ELSEIF(MSEL.EQ.45) THEN
6757C...Sbottom production.
6758 MSUB(287)=1
6759 MSUB(288)=1
6760 IF(MINT(43).EQ.4) THEN
6761 DO 310 I=281,296
6762 MSUB(I)=1
6763 310 CONTINUE
6764 ENDIF
6765
6766 ELSEIF(MSEL.EQ.50) THEN
6767C...Pair production of technipions and gauge bosons.
6768 DO 320 I=361,368
6769 MSUB(I)=1
6770 320 CONTINUE
6771 IF(MINT(43).EQ.4) THEN
6772 DO 330 I=370,377
6773 MSUB(I)=1
6774 330 CONTINUE
6775 ENDIF
6776
6777 ELSEIF(MSEL.EQ.51) THEN
6778C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6779 DO 340 I=381,386
6780 MSUB(I)=1
6781 340 CONTINUE
6782
6783 ELSEIF(MSEL.EQ.61) THEN
6784C...Charmonium production in colour octet model, with recoiling parton.
6785 DO 342 I=421,439
6786 MSUB(I)=1
6787 342 CONTINUE
6788
6789 ELSEIF(MSEL.EQ.62) THEN
6790C...Bottomonium production in colour octet model, with recoiling parton.
6791 DO 344 I=461,479
6792 MSUB(I)=1
6793 344 CONTINUE
6794
6795 ELSEIF(MSEL.EQ.63) THEN
6796C...Charmonium and bottomonium production in colour octet model.
6797 DO 346 I=421,439
6798 MSUB(I)=1
6799 MSUB(I+40)=1
6800 346 CONTINUE
6801 ENDIF
6802
6803C...Find heaviest new quark flavour allowed in processes 81-84.
6804 KFLQM=1
6805 DO 350 I=1,MIN(8,MDCY(21,3))
6806 IDC=I+MDCY(21,2)-1
6807 IF(MDME(IDC,1).LE.0) GOTO 350
6808 KFLQM=I
6809 350 CONTINUE
6810 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6811 &KFLQM=MSTP(7)
6812 MINT(55)=KFLQM
6813 KFPR(81,1)=KFLQM
6814 KFPR(81,2)=KFLQM
6815 KFPR(82,1)=KFLQM
6816 KFPR(82,2)=KFLQM
6817 KFPR(83,1)=KFLQM
6818 KFPR(84,1)=KFLQM
6819 KFPR(84,2)=KFLQM
6820
6821C...Find heaviest new fermion flavour allowed in process 85.
6822 KFLFM=1
6823 DO 360 I=1,MIN(12,MDCY(22,3))
6824 IDC=I+MDCY(22,2)-1
6825 IF(MDME(IDC,1).LE.0) GOTO 360
6826 KFLFM=KFDP(IDC,1)
6827 360 CONTINUE
6828 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6829 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6830 MINT(56)=KFLFM
6831 KFPR(85,1)=KFLFM
6832 KFPR(85,2)=KFLFM
6833
6834C...Initialize Generic Processes
6835 KFGEN=9900001
6836 KCGEN=PYCOMP(KFGEN)
6837 IF(KCGEN.GT.0) THEN
6838 IDCY=MDCY(KCGEN,2)
6839 IF(IDCY.GT.0) THEN
6840 KFF1=KFDP(IDCY+1,1)
6841 KFF2=KFDP(IDCY+1,2)
6842 KCF1=PYCOMP(KFF1)
6843 KCF2=PYCOMP(KFF2)
6844 JCOL1=IABS(KCHG(KCF1,2))
6845 IF(JCOL1.EQ.1) THEN
6846 KF1=KFF1
6847 KF2=KFF2
6848 ELSE
6849 KF1=KFF2
6850 KF2=KFF1
6851 ENDIF
6852 KFPR(481,1)=KF1
6853 KFPR(481,2)=KF2
6854 KFPR(482,1)=KF1
6855 KFPR(482,2)=KF2
6856 ENDIF
6857 IF(KFDP(IDCY,1).EQ.21.OR.KFDP(IDCY,2).EQ.21) THEN
6858 KFIN(1,0)=1
6859 KFIN(2,0)=1
6860 ENDIF
6861 ENDIF
6862
6863C...Import relevant information on external user processes.
6864 IF(MINT(111).GE.11) THEN
6865 IPYPR=0
6866 DO 390 IUP=1,NPRUP
6867C...Find next empty PYTHIA process number slot and enable it.
6868 370 IPYPR=IPYPR+1
6869 IF(IPYPR.GT.500) CALL PYERRM(26,
6870 & '(PYINPR.) no more empty slots for user processes')
6871 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6872 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6873 ISET(IPYPR)=11
6874C...Overwrite KFPR with references back to process number and ID.
6875 KFPR(IPYPR,1)=IUP
6876 KFPR(IPYPR,2)=LPRUP(IUP)
6877C...Process title.
6878 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6879 ICHIN=1
6880 DO 380 ICH=1,9
6881 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6882 380 CONTINUE
6883 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6884C...Switch on process.
6885 MSUB(IPYPR)=1
6886 390 CONTINUE
6887 ENDIF
6888
6889 RETURN
6890 END
6891
6892C*********************************************************************
6893
6894C...PYXTOT
6895C...Parametrizes total, elastic and diffractive cross-sections
6896C...for different energies and beams. Donnachie-Landshoff for
6897C...total and Schuler-Sjostrand for elastic and diffractive.
6898C...Process code IPROC:
6899C...= 1 : p + p;
6900C...= 2 : pbar + p;
6901C...= 3 : pi+ + p;
6902C...= 4 : pi- + p;
6903C...= 5 : pi0 + p;
6904C...= 6 : phi + p;
6905C...= 7 : J/psi + p;
6906C...= 11 : rho + rho;
6907C...= 12 : rho + phi;
6908C...= 13 : rho + J/psi;
6909C...= 14 : phi + phi;
6910C...= 15 : phi + J/psi;
6911C...= 16 : J/psi + J/psi;
6912C...= 21 : gamma + p (DL);
6913C...= 22 : gamma + p (VDM).
6914C...= 23 : gamma + pi (DL);
6915C...= 24 : gamma + pi (VDM);
6916C...= 25 : gamma + gamma (DL);
6917C...= 26 : gamma + gamma (VDM).
6918
6919 SUBROUTINE PYXTOT
6920
6921C...Double precision and integer declarations.
6922 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6923 IMPLICIT INTEGER(I-N)
6924 INTEGER PYK,PYCHGE,PYCOMP
6925C...Commonblocks.
6926 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6927 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6928 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6929 COMMON/PYINT1/MINT(400),VINT(400)
6930 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6931 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6932 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6933C...Local arrays.
6934 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6935 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6936 &CEFFD(10,9),SIGTMP(6,0:5)
6937
6938C...Common constants.
6939 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6940 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6941 &FACDD/0.0084D0/
6942
6943C...Number of multiple processes to be evaluated (= 0 : undefined).
6944 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6945C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6946 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6947 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6948 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6949 DATA YPAR/
6950 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6951 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6952 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6953
6954C...Beam and target hadron class:
6955C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6956 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6957 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6958C...Characteristic class masses, slope parameters, beta = sqrt(X).
6959 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6960 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6961 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6962
6963C...Fitting constants used in parametrizations of diffractive results.
6964 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6965 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6966 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6967 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6968 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6969 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6970 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6971 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6972 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6973 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6974 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6975 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6976 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6977 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6978 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6979 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6980 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6981 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6982 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6983 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6984 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6985 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6986 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6987 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6988 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6989 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6990 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6991 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6992 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6993
6994C...Parameters. Combinations of the energy.
6995 AEM=PARU(101)
6996 PMTH=PARP(102)
6997 S=VINT(2)
6998 SRT=VINT(1)
6999 SEPS=S**EPS
7000 SETA=S**ETA
7001 SLOG=LOG(S)
7002
7003C...Ratio of gamma/pi (for rescaling in parton distributions).
7004 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
7005 &(XPAR(5)*SEPS+YPAR(5)*SETA)
7006 VINT(317)=1D0
7007 IF(MINT(50).NE.1) RETURN
7008
7009C...Order flavours of incoming particles: KF1 < KF2.
7010 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
7011 KF1=IABS(MINT(11))
7012 KF2=IABS(MINT(12))
7013 IORD=1
7014 ELSE
7015 KF1=IABS(MINT(12))
7016 KF2=IABS(MINT(11))
7017 IORD=2
7018 ENDIF
7019 ISGN12=ISIGN(1,MINT(11)*MINT(12))
7020
7021C...Find process number (for lookup tables).
7022 IF(KF1.GT.1000) THEN
7023 IPROC=1
7024 IF(ISGN12.LT.0) IPROC=2
7025 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
7026 IPROC=3
7027 IF(ISGN12.LT.0) IPROC=4
7028 IF(KF1.EQ.111) IPROC=5
7029 ELSEIF(KF1.GT.100) THEN
7030 IPROC=11
7031 ELSEIF(KF2.GT.1000) THEN
7032 IPROC=21
7033 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
7034 ELSEIF(KF2.GT.100) THEN
7035 IPROC=23
7036 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
7037 ELSE
7038 IPROC=25
7039 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
7040 ENDIF
7041
7042C... Number of multiple processes to be stored; beam/target side.
7043 NPR=NPROC(IPROC)
7044 MINT(101)=1
7045 MINT(102)=1
7046 IF(NPR.EQ.3) THEN
7047 MINT(100+IORD)=4
7048 ELSEIF(NPR.EQ.6) THEN
7049 MINT(101)=4
7050 MINT(102)=4
7051 ENDIF
7052 N1=0
7053 IF(MINT(101).EQ.4) N1=4
7054 N2=0
7055 IF(MINT(102).EQ.4) N2=4
7056
7057C...Do not do any more for user-set or undefined cross-sections.
7058 IF(MSTP(31).LE.0) RETURN
7059 IF(NPR.EQ.0) CALL PYERRM(26,
7060 &'(PYXTOT:) cross section for this process not yet implemented')
7061
7062C...Parameters. Combinations of the energy.
7063 AEM=PARU(101)
7064 PMTH=PARP(102)
7065 S=VINT(2)
7066 SRT=VINT(1)
7067 SEPS=S**EPS
7068 SETA=S**ETA
7069 SLOG=LOG(S)
7070
7071C...Loop over multiple processes (for VDM).
7072 DO 110 I=1,NPR
7073 IF(NPR.EQ.1) THEN
7074 IPR=IPROC
7075 ELSEIF(NPR.EQ.3) THEN
7076 IPR=I+4
7077 IF(KF2.LT.1000) IPR=I+10
7078 ELSEIF(NPR.EQ.6) THEN
7079 IPR=I+10
7080 ENDIF
7081
7082C...Evaluate hadron species, mass, slope contribution and fit number.
7083 IHA=IHADA(IPR)
7084 IHB=IHADB(IPR)
7085 PMA=PMHAD(IHA)
7086 PMB=PMHAD(IHB)
7087 BHA=BHAD(IHA)
7088 BHB=BHAD(IHB)
7089 ISD=IFITSD(IPR)
7090 IDD=IFITDD(IPR)
7091
7092C...Skip if energy too low relative to masses.
7093 DO 100 J=0,5
7094 SIGTMP(I,J)=0D0
7095 100 CONTINUE
7096 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
7097
7098C...Total cross-section. Elastic slope parameter and cross-section.
7099 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
7100 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
7101 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
7102
7103C...Diffractive scattering A + B -> X + B.
7104 BSD=2D0*BHB
7105 SQML=(PMA+PMTH)**2
7106 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
7107 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7108 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7109 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
7110 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
7111 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
7112 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
7113
7114C...Diffractive scattering A + B -> A + X.
7115 BSD=2D0*BHA
7116 SQML=(PMB+PMTH)**2
7117 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
7118 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7119 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7120 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
7121 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
7122 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
7123 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
7124
7125C...Order single diffractive correctly.
7126 IF(IORD.EQ.2) THEN
7127 SIGSAV=SIGTMP(I,2)
7128 SIGTMP(I,2)=SIGTMP(I,3)
7129 SIGTMP(I,3)=SIGSAV
7130 ENDIF
7131
7132C...Double diffractive scattering A + B -> X1 + X2.
7133 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
7134 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
7135 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
7136 IF(YEFF.LE.0) SUM1=0D0
7137 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
7138 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
7139 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
7140 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
7141 & (2D0*ALP)
7142 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
7143 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
7144 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
7145 & (2D0*ALP)
7146 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
7147 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
7148 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
7149 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
7150 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
7151
7152C...Non-diffractive by unitarity.
7153 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
7154 & SIGTMP(I,4)
7155 110 CONTINUE
7156
7157C...Put temporary results in output array: only one process.
7158 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
7159 DO 120 J=0,5
7160 SIGT(0,0,J)=SIGTMP(1,J)
7161 120 CONTINUE
7162
7163C...Beam multiple processes.
7164 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
7165 IF(MINT(107).EQ.2) THEN
7166 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7167 ELSE
7168 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7169 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7170 ENDIF
7171 IF(MSTP(20).GT.0) THEN
7172 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
7173 ENDIF
7174 DO 140 I=1,4
7175 IF(MINT(107).EQ.2) THEN
7176 CONV=(AEM/PARP(160+I))*VINT(317)
7177 ELSEIF(VINT(154).GT.PARP(15)) THEN
7178 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7179 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7180 ELSE
7181 CONV=0D0
7182 ENDIF
7183 I1=MAX(1,I-1)
7184 DO 130 J=0,5
7185 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
7186 130 CONTINUE
7187 140 CONTINUE
7188 DO 150 J=0,5
7189 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7190 150 CONTINUE
7191
7192C...Target multiple processes.
7193 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
7194 IF(MINT(108).EQ.2) THEN
7195 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7196 ELSE
7197 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7198 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7199 ENDIF
7200 IF(MSTP(20).GT.0) THEN
7201 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
7202 ENDIF
7203 DO 170 I=1,4
7204 IF(MINT(108).EQ.2) THEN
7205 CONV=(AEM/PARP(160+I))*VINT(317)
7206 ELSEIF(VINT(154).GT.PARP(15)) THEN
7207 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7208 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7209 ELSE
7210 CONV=0D0
7211 ENDIF
7212 IV=MAX(1,I-1)
7213 DO 160 J=0,5
7214 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
7215 160 CONTINUE
7216 170 CONTINUE
7217 DO 180 J=0,5
7218 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
7219 180 CONTINUE
7220
7221C...Both beam and target multiple processes.
7222 ELSE
7223 IF(MINT(107).EQ.2) THEN
7224 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7225 ELSE
7226 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7227 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7228 ENDIF
7229 IF(MINT(108).EQ.2) THEN
7230 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7231 ELSE
7232 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
7233 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7234 ENDIF
7235 IF(MSTP(20).GT.0) THEN
7236 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
7237 & VINT(308)))**MSTP(20)
7238 ENDIF
7239 DO 210 I1=1,4
7240 DO 200 I2=1,4
7241 IF(MINT(107).EQ.2) THEN
7242 CONV=(AEM/PARP(160+I1))*VINT(317)
7243 ELSEIF(VINT(154).GT.PARP(15)) THEN
7244 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
7245 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7246 ELSE
7247 CONV=0D0
7248 ENDIF
7249 IF(MINT(108).EQ.2) THEN
7250 CONV=CONV*(AEM/PARP(160+I2))
7251 ELSEIF(VINT(154).GT.PARP(15)) THEN
7252 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
7253 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
7254 ELSE
7255 CONV=0D0
7256 ENDIF
7257 IF(I1.LE.2) THEN
7258 IV=MAX(1,I2-1)
7259 ELSEIF(I2.LE.2) THEN
7260 IV=MAX(1,I1-1)
7261 ELSEIF(I1.EQ.I2) THEN
7262 IV=2*I1-2
7263 ELSE
7264 IV=5
7265 ENDIF
7266 DO 190 J=0,5
7267 JV=J
7268 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
7269 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
7270 190 CONTINUE
7271 200 CONTINUE
7272 210 CONTINUE
7273 DO 230 J=0,5
7274 DO 220 I=1,4
7275 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
7276 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
7277 220 CONTINUE
7278 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7279 230 CONTINUE
7280 ENDIF
7281
7282C...Scale up uniformly for Donnachie-Landshoff parametrization.
7283 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
7284 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
7285 DO 260 I1=0,N1
7286 DO 250 I2=0,N2
7287 DO 240 J=0,5
7288 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
7289 240 CONTINUE
7290 250 CONTINUE
7291 260 CONTINUE
7292 ENDIF
7293
7294 RETURN
7295 END
7296
7297C*********************************************************************
7298
7299C...PYMAXI
7300C...Finds optimal set of coefficients for kinematical variable selection
7301C...and the maximum of the part of the differential cross-section used
7302C...in the event weighting.
7303
7304 SUBROUTINE PYMAXI
7305
7306C...Double precision and integer declarations.
7307 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7308 IMPLICIT INTEGER(I-N)
7309 INTEGER PYK,PYCHGE,PYCOMP
7310C...Parameter statement to help give large particle numbers.
7311 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7312 &KEXCIT=4000000,KDIMEN=5000000)
7313
7314C...User process initialization commonblock.
7315 INTEGER MAXPUP
7316 PARAMETER (MAXPUP=100)
7317 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7318 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7319 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7320 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7321 &LPRUP(MAXPUP)
7322 SAVE /HEPRUP/
7323
7324C...Commonblocks.
7325 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7326 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7327 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7328 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7329 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7330 COMMON/PYINT1/MINT(400),VINT(400)
7331 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7332 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7333 COMMON/PYINT4/MWID(500),WIDS(500,5)
7334 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7335 COMMON/PYINT6/PROC(0:500)
7336 CHARACTER PROC*28
7337 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7338 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
7339 COMMON/PYTCCO/COEFX(194:380,2)
7340 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
7341 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7342 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
7343 &/PYTCSM/,/TCPARA/
7344C...Local arrays, character variables and data.
7345 LOGICAL IOK
7346 CHARACTER CVAR(4)*4
7347 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7348 &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
7349 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2),WTRSAV(9),TEMPC(9),
7350 &IQ(9),IP(9)
7351 DATA CVAR/'tau ','tau''','y* ','cth '/
7352 DATA SIGSSM/3*0D0/
7353
7354C...Initial values and loop over subprocesses.
7355 NPOSI=0
7356 VINT(143)=1D0
7357 VINT(144)=1D0
7358 XSEC(0,1)=0D0
7359 ITECH=0
7360 DO 460 ISUB=1,500
7361 MINT(1)=ISUB
7362 MINT(51)=0
7363
7364C...Find maximum weight factors for photon flux.
7365 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7366 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7367 ENDIF
7368
7369C...Select subprocess to study: skip cases not applicable.
7370 IF(ISET(ISUB).EQ.11) THEN
7371 IF(MSUB(ISUB).NE.1) GOTO 460
7372C...User process intialization: cross section model dependent.
7373 IF(IABS(IDWTUP).EQ.1) THEN
7374 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7375 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7376 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7377 ELSE
7378 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7379 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7380 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7381 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7382 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7383 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7384 ENDIF
7385 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7386 & WTGAGA*XSEC(ISUB,1)
7387 NPOSI=NPOSI+1
7388 GOTO 450
7389 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7390 CALL PYSIGH(NCHN,SIGS)
7391 XSEC(ISUB,1)=SIGS
7392 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7393 & WTGAGA*XSEC(ISUB,1)
7394 IF(MSUB(ISUB).NE.1) GOTO 460
7395 NPOSI=NPOSI+1
7396 GOTO 450
7397 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7398 CALL PYSIGH(NCHN,SIGS)
7399 XSEC(ISUB,1)=SIGS
7400 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7401 & WTGAGA*XSEC(ISUB,1)
7402 IF(XSEC(ISUB,1).EQ.0D0) THEN
7403 MSUB(ISUB)=0
7404 ELSE
7405 NPOSI=NPOSI+1
7406 ENDIF
7407 GOTO 450
7408 ELSEIF(ISUB.EQ.96) THEN
7409 IF(MINT(50).EQ.0) GOTO 460
7410 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7411 & GOTO 460
7412 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7413 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7414 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7415 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7416 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7417 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7418 ELSE
7419 IF(MSUB(ISUB).NE.1) GOTO 460
7420 ENDIF
7421 ISTSB=ISET(ISUB)
7422 IF(ISUB.EQ.96) ISTSB=2
7423 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7424 MWTXS=0
7425 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7426 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7427
7428C...Find resonances (explicit or implicit in cross-section).
7429 MINT(72)=0
7430 KFR1=0
7431 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7432 KFR1=KFPR(ISUB,1)
7433 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7434 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7435 KFR1=23
7436 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7437 & .OR.ISUB.EQ.177) THEN
7438 KFR1=24
7439 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7440 KFR1=25
7441 IF(MSTP(46).EQ.5) THEN
7442 KFR1=89
7443 PMAS(89,1)=PARP(45)
7444 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7445 ENDIF
7446 ELSEIF(ISUB.EQ.481) THEN
7447 KFR1=9900001
7448 ENDIF
7449 CKMX=CKIN(2)
7450 IF(CKMX.LE.0D0) CKMX=VINT(1)
7451 KCR1=PYCOMP(KFR1)
7452 IF(KCR1.EQ.0) KFR1=0
7453 IF(KFR1.NE.0) THEN
7454 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7455 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7456 ENDIF
7457 IF(KFR1.NE.0) THEN
7458 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7459 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7460 MINT(72)=1
7461 MINT(73)=KFR1
7462 VINT(73)=TAUR1
7463 VINT(74)=GAMR1
7464 ENDIF
7465 KFR2=0
7466 KFR3=0
7467 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
7468 $ (ISUB.GE.361.AND.ISUB.LE.380))
7469 $ THEN
7470 KFR2=23
7471 IF(ISUB.EQ.141) THEN
7472 KCR2=PYCOMP(KFR2)
7473 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7474 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
7475 KFR2=0
7476 ELSE
7477 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7478 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7479 MINT(72)=2
7480 MINT(74)=KFR2
7481 VINT(75)=TAUR2
7482 VINT(76)=GAMR2
7483 ENDIF
7484 ELSEIF(ITECH.EQ.0) THEN
7485 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
7486 ITECH=1
7487 KFR1=KTECHN+113
7488 KCR1=PYCOMP(KFR1)
7489 KFR2=KTECHN+223
7490 KCR2=PYCOMP(KFR2)
7491 KFR3=KTECHN+115
7492 KCR3=PYCOMP(KFR3)
7493 IRES=0
7494C...Order the resonances
7495 IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
7496 KCT=KCR3
7497 KCR3=KCR2
7498 KCR2=KCT
7499 ENDIF
7500 IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
7501 KCT=KCR3
7502 KCR3=KCR1
7503 KCR1=KCT
7504 ENDIF
7505 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7506 KCT=KCR2
7507 KCR2=KCR1
7508 KCR1=KCT
7509 ENDIF
7510 DO 101 I=1,3
7511 IF(I.EQ.1) THEN
7512 SHN0=PMAS(KCR1,1)**2
7513 ELSEIF(I.EQ.2) THEN
7514 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
7515 SHN0=PMAS(KCR2,1)**2
7516 ELSEIF(I.EQ.3) THEN
7517 IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
7518 SHN0=PMAS(KCR3,1)**2
7519 ENDIF
7520 AEM=PYALEM(SHN0)
7521 FAR=SQRT(AEM/ALPRHT)
7522 SHN=SHN0*(1D0-FAR)
7523 CALL PYTECM(SHN,S1,WIDO,1)
7524 RES=SHN-S1
7525 SHN=S1*.99D0
7526 SHSTEP=2D0
7527 102 SHN=SHN+SHSTEP
7528 CALL PYTECM(SHN,S1,WIDO,1)
7529 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7530 IOK=.FALSE.
7531 IF(IRES.GT.0) THEN
7532 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7533 ELSEIF(IRES.EQ.0) THEN
7534 IOK=.TRUE.
7535 ENDIF
7536 IF(IOK) THEN
7537 IRES=IRES+1
7538 XMAS(IRES)=SQRT(S1)
7539 XWID(IRES)=WIDO
7540 ENDIF
7541 ENDIF
7542 RES=SHN-S1
7543 IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
7544 101 CONTINUE
7545 JRES=0
7546 KFR1=KTECHN+213
7547 KCR1=PYCOMP(KFR1)
7548 KFR2=KTECHN+215
7549 KCR2=PYCOMP(KFR2)
7550 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7551 KCT=KCR2
7552 KCR2=KCR1
7553 KCR1=KCT
7554 ENDIF
7555 DO 103 I=1,2
7556 IF(I.EQ.1) THEN
7557 SHN0=PMAS(KCR1,1)**2
7558 ELSEIF(I.EQ.2) THEN
7559 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
7560 SHN0=PMAS(KCR2,1)**2
7561 ENDIF
7562 AEM=PYALEM(SHN0)
7563 FAR=SQRT(AEM/ALPRHT)
7564 SHN=SHN0*(1D0-FAR)
7565 CALL PYTECM(SHN,S1,WIDO,2)
7566 RES=SHN-S1
7567 SHN=S1*.99D0
7568 SHSTEP=2D0
7569 104 SHN=SHN+SHSTEP
7570 CALL PYTECM(SHN,S1,WIDO,2)
7571 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7572 IOK=.FALSE.
7573 IF(JRES.GT.0) THEN
7574 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7575 ELSEIF(JRES.EQ.0) THEN
7576 IOK=.TRUE.
7577 ENDIF
7578 IF(IOK) THEN
7579 JRES=JRES+1
7580 YMAS(JRES)=SQRT(S1)
7581 YWID(JRES)=WIDO
7582 ENDIF
7583 ENDIF
7584 RES=SHN-S1
7585 IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
7586 103 CONTINUE
7587 ENDIF
7588 IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
7589 & ISUB.EQ.379.OR.ISUB.EQ.380) THEN
7590 MINT(72)=IRES
7591 IF(IRES.GE.1) THEN
7592 VINT(73)=XMAS(1)**2/VINT(2)
7593 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
7594 TAUR1=VINT(73)
7595 GAMR1=VINT(74)
7596 XM1=XMAS(1)
7597 XG1=XWID(1)
7598 KFR1=1
7599 ENDIF
7600 IF(IRES.GE.2) THEN
7601 VINT(75)=XMAS(2)**2/VINT(2)
7602 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
7603 TAUR2=VINT(75)
7604 GAMR2=VINT(76)
7605 XM2=XMAS(2)
7606 XG2=XWID(2)
7607 KFR2=2
7608 ENDIF
7609 IF(IRES.EQ.3) THEN
7610 VINT(77)=XMAS(3)**2/VINT(2)
7611 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
7612 TAUR3=VINT(77)
7613 GAMR3=VINT(78)
7614 XM3=XMAS(3)
7615 XG3=XWID(3)
7616 KFR3=3
7617 ENDIF
7618C...Charged current: rho+- and a+-
7619 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
7620 MINT(72)=IRES
7621 IF(JRES.GE.1) THEN
7622 VINT(73)=YMAS(1)**2/VINT(2)
7623 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
7624 KFR1=1
7625 TAUR1=VINT(73)
7626 GAMR1=VINT(74)
7627 XM1=YMAS(1)
7628 XG1=YWID(1)
7629 ENDIF
7630 IF(JRES.GE.2) THEN
7631 VINT(75)=YMAS(2)**2/VINT(2)
7632 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
7633 KFR2=2
7634 TAUR2=VINT(73)
7635 GAMR2=VINT(74)
7636 XM2=YMAS(2)
7637 XG2=YWID(2)
7638 ENDIF
7639 KFR3=0
7640 ENDIF
7641 IF(ISUB.NE.141) THEN
7642 IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
7643 & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
7644 IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
7645 & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
7646 IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
7647 & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
7648 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
7649
7650 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
7651 MINT(72)=2
7652 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
7653 MINT(72)=2
7654 MINT(74)=KFR3
7655 VINT(75)=TAUR3
7656 VINT(76)=GAMR3
7657 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
7658 MINT(72)=2
7659 MINT(73)=KFR2
7660 VINT(73)=TAUR2
7661 VINT(74)=GAMR2
7662 MINT(74)=KFR3
7663 VINT(75)=TAUR3
7664 VINT(76)=GAMR3
7665 ELSEIF(KFR1.NE.0) THEN
7666 MINT(72)=1
7667 ELSEIF(KFR2.NE.0) THEN
7668 MINT(72)=1
7669 MINT(73)=KFR2
7670 VINT(73)=TAUR2
7671 VINT(74)=GAMR2
7672 ELSEIF(KFR3.NE.0) THEN
7673 MINT(72)=1
7674 MINT(73)=KFR3
7675 VINT(73)=TAUR3
7676 VINT(74)=GAMR3
7677 ELSE
7678 MINT(72)=0
7679 ENDIF
7680 ELSE
7681 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7682
7683 ELSEIF(KFR2.NE.0) THEN
7684 KFR1=KFR2
7685 TAUR1=TAUR2
7686 GAMR1=GAMR2
7687 MINT(72)=1
7688 MINT(73)=KFR1
7689 VINT(73)=TAUR1
7690 VINT(74)=GAMR1
7691 KFR2=0
7692 ELSE
7693 MINT(72)=0
7694 ENDIF
7695 ENDIF
7696 ENDIF
7697
7698C...Find product masses and minimum pT of process.
7699 SQM3=0D0
7700 SQM4=0D0
7701 MINT(71)=0
7702 VINT(71)=CKIN(3)
7703 VINT(80)=1D0
7704 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7705 NBW=0
7706 DO 110 I=1,2
7707 PMMN(I)=0D0
7708 IF(KFPR(ISUB,I).EQ.0) THEN
7709 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7710 & PARP(41)) THEN
7711 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7712 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7713 ELSE
7714 NBW=NBW+1
7715C...This prevents SUSY/t particles from becoming too light.
7716 KFLW=KFPR(ISUB,I)
7717 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7718 KCW=PYCOMP(KFLW)
7719 PMMN(I)=PMAS(KCW,1)
7720 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7721 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7722 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7723 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7724 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7725 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7726 PMMN(I)=MIN(PMMN(I),PMSUM)
7727 ENDIF
7728 100 CONTINUE
7729 ELSEIF(KFLW.EQ.6) THEN
7730 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7731 ENDIF
7732 ENDIF
7733 110 CONTINUE
7734 IF(NBW.GE.1) THEN
7735 CKIN41=CKIN(41)
7736 CKIN43=CKIN(43)
7737 CKIN(41)=MAX(PMMN(1),CKIN(41))
7738 CKIN(43)=MAX(PMMN(2),CKIN(43))
7739 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7740 CKIN(41)=CKIN41
7741 CKIN(43)=CKIN43
7742 IF(MINT(51).EQ.1) THEN
7743 WRITE(MSTU(11),5100) ISUB
7744 MSUB(ISUB)=0
7745 GOTO 460
7746 ENDIF
7747 SQM3=PQM3**2
7748 SQM4=PQM4**2
7749 ENDIF
7750 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7751 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7752 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7753 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7754 ELSEIF(ISUB.EQ.96) THEN
7755 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7756 ENDIF
7757 ENDIF
7758 VINT(63)=SQM3
7759 VINT(64)=SQM4
7760
7761C...Prepare for additional variable choices in 2 -> 3.
7762 IF(ISTSB.EQ.5) THEN
7763 VINT(201)=0D0
7764 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7765 VINT(206)=VINT(201)
7766 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7767 VINT(204)=PMAS(23,1)
7768 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7769 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7770 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7771 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7772 & VINT(204)=VINT(201)
7773 VINT(209)=VINT(204)
7774 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7775 ENDIF
7776
7777C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7778 IPEAK7=0
7779 NPTS(1)=2+2*MINT(72)
7780 IF(MINT(47).EQ.1) THEN
7781 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7782 ELSEIF(MINT(47).GE.5) THEN
7783 IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
7784 NPTS(1)=NPTS(1)+1
7785 IPEAK7=1
7786 ENDIF
7787 ENDIF
7788 NPTS(2)=1
7789 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7790 IF(MINT(47).GE.2) NPTS(2)=2
7791 IF(MINT(47).GE.5) NPTS(2)=3
7792 ENDIF
7793 NPTS(3)=1
7794 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7795 NPTS(3)=3
7796 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7797 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7798 ENDIF
7799 NPTS(4)=1
7800 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7801 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7802
7803C...Reset coefficients of cross-section weighting.
7804 DO 120 J=1,20
7805 COEF(ISUB,J)=0D0
7806 120 CONTINUE
7807 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
7808 & .AND.ISUB.LE.380)) THEN
7809 DO 125 J=1,2
7810 COEFX(ISUB,J)=0D0
7811 125 CONTINUE
7812 ENDIF
7813 COEF(ISUB,1)=1D0
7814 COEF(ISUB,8)=0.5D0
7815 COEF(ISUB,9)=0.5D0
7816 COEF(ISUB,13)=1D0
7817 COEF(ISUB,18)=1D0
7818 MCTH=0
7819 MTAUP=0
7820 METAUP=0
7821 VINT(23)=0D0
7822 VINT(26)=0D0
7823 SIGSAM=0D0
7824
7825C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7826C...in grid of phase space points.
7827 CALL PYKLIM(1)
7828 METAU=MINT(51)
7829 NACC=0
7830 DO 150 ITRY=1,NTRY
7831 MINT(51)=0
7832 IF(METAU.EQ.1) GOTO 150
7833 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7834 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7835 IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
7836 MTAU=7
7837 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
7838 MTAU=MTAU+1
7839 ENDIF
7840 RTAU=0.5D0
7841C...Special case when both resonances have same mass,
7842C...as is often the case in process 194.
7843c IF(MINT(72).GE.2) THEN
7844c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7845c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7846c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7847c RTAU=0.4D0
7848c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7849c RTAU=0.6D0
7850c ENDIF
7851c ENDIF
7852c ENDIF
7853 CALL PYKMAP(1,MTAU,RTAU)
7854 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7855 METAUP=MINT(51)
7856 ENDIF
7857 IF(METAUP.EQ.1) GOTO 150
7858 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7859 & .EQ.0) THEN
7860 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7861 CALL PYKMAP(4,MTAUP,0.5D0)
7862 ENDIF
7863 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7864 CALL PYKLIM(2)
7865 MEYST=MINT(51)
7866 ENDIF
7867 IF(MEYST.EQ.1) GOTO 150
7868 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7869 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7870 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7871 CALL PYKMAP(2,MYST,0.5D0)
7872 CALL PYKLIM(3)
7873 MECTH=MINT(51)
7874 ENDIF
7875 IF(MECTH.EQ.1) GOTO 150
7876 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7877 MCTH=1+MOD(ITRY-1,NPTS(4))
7878 CALL PYKMAP(3,MCTH,0.5D0)
7879 ENDIF
7880 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7881
7882C...Store position and limits.
7883 MINT(51)=0
7884 CALL PYKLIM(0)
7885 IF(MINT(51).EQ.1) GOTO 150
7886 NACC=NACC+1
7887 MVARPT(NACC,1)=MTAU
7888 MVARPT(NACC,2)=MTAUP
7889 MVARPT(NACC,3)=MYST
7890 MVARPT(NACC,4)=MCTH
7891 DO 130 J=1,30
7892 VINTPT(NACC,J)=VINT(10+J)
7893 130 CONTINUE
7894
7895C...Normal case: calculate cross-section.
7896 IF(ISTSB.NE.5) THEN
7897 CALL PYSIGH(NCHN,SIGS)
7898 IF(MWTXS.EQ.1) THEN
7899 CALL PYEVWT(WTXS)
7900 SIGS=WTXS*SIGS
7901 ENDIF
7902
7903C..2 -> 3: find highest value out of a number of tries.
7904 ELSE
7905 SIGS=0D0
7906 DO 140 IKIN3=1,MSTP(129)
7907 CALL PYKMAP(5,0,0D0)
7908 IF(MINT(51).EQ.1) GOTO 140
7909 CALL PYSIGH(NCHN,SIGTMP)
7910 IF(MWTXS.EQ.1) THEN
7911 CALL PYEVWT(WTXS)
7912 SIGTMP=WTXS*SIGTMP
7913 ENDIF
7914 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7915 140 CONTINUE
7916 ENDIF
7917
7918C...Store cross-section.
7919 SIGSPT(NACC)=SIGS
7920 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7921 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7922 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7923 150 CONTINUE
7924 IF(NACC.EQ.0) THEN
7925 WRITE(MSTU(11),5100) ISUB
7926 MSUB(ISUB)=0
7927 GOTO 460
7928 ELSEIF(SIGSAM.EQ.0D0) THEN
7929 WRITE(MSTU(11),5300) ISUB
7930 MSUB(ISUB)=0
7931 GOTO 460
7932 ENDIF
7933 IF(ISUB.NE.96) NPOSI=NPOSI+1
7934
7935C...Calculate integrals in tau over maximal phase space limits.
7936 TAUMIN=VINT(11)
7937 TAUMAX=VINT(31)
7938 ATAU1=LOG(TAUMAX/TAUMIN)
7939 IF(NPTS(1).GE.2) THEN
7940 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7941 ENDIF
7942 IF(NPTS(1).GE.4) THEN
7943 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7944 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7945 & GAMR1
7946 ENDIF
7947 IF(NPTS(1).GE.6) THEN
7948 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7949 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7950 & GAMR2
7951 ENDIF
7952 IF(NPTS(1).GE.8) THEN
7953 ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
7954 ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
7955 & GAMR3
7956 ENDIF
7957 IF(IPEAK7.EQ.1) THEN
7958 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7959 ENDIF
7960
7961C...Reset. Sum up cross-sections in points calculated.
7962 DO 320 IVAR=1,4
7963 IF(NPTS(IVAR).EQ.1) GOTO 320
7964 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7965 NBIN=NPTS(IVAR)
7966 DO 170 J1=1,NBIN
7967 NAREL(J1)=0
7968 WTREL(J1)=0D0
7969 COEFU(J1)=0D0
7970 DO 160 J2=1,NBIN
7971 WTMAT(J1,J2)=0D0
7972 160 CONTINUE
7973 170 CONTINUE
7974 DO 180 IACC=1,NACC
7975 IBIN=MVARPT(IACC,IVAR)
7976 IF(IVAR.EQ.1) THEN
7977 IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
7978 IBIN=IBIN-1
7979 ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
7980 IBIN=3+2*MINT(72)
7981 ENDIF
7982 ENDIF
7983 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7984 NAREL(IBIN)=NAREL(IBIN)+1
7985 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7986
7987C...Sum up tau cross-section pieces in points used.
7988 IF(IVAR.EQ.1) THEN
7989 TAU=VINTPT(IACC,11)
7990 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7991 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7992 IF(NBIN.GE.4) THEN
7993 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7994 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7995 & ((TAU-TAUR1)**2+GAMR1**2)
7996 ENDIF
7997 IF(NBIN.GE.6) THEN
7998 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7999 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
8000 & ((TAU-TAUR2)**2+GAMR2**2)
8001 ENDIF
8002 IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
8003 WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
8004 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
8005 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
8006 WTMAT(IBIN,7)=WTMAT(IBIN,7)
8007 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
8008 ENDIF
8009 IF(MINT(72).EQ.3) THEN
8010 WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
8011 & +(ATAU1/ATAU8)/(TAU+TAUR3)
8012 WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
8013 & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
8014 ENDIF
8015C...Sum up tau' cross-section pieces in points used.
8016 ELSEIF(IVAR.EQ.2) THEN
8017 TAU=VINTPT(IACC,11)
8018 TAUP=VINTPT(IACC,16)
8019 TAUPMN=VINTPT(IACC,6)
8020 TAUPMX=VINTPT(IACC,26)
8021 ATAUP1=LOG(TAUPMX/TAUPMN)
8022 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
8023 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
8024 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
8025 & (1D0-TAU/TAUP)**3/TAUP
8026 IF(NBIN.GE.3) THEN
8027 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
8028 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
8029 & TAUP/MAX(2D-10,1D0-TAUP)
8030 ENDIF
8031
8032C...Sum up y* cross-section pieces in points used.
8033 ELSEIF(IVAR.EQ.3) THEN
8034 YST=VINTPT(IACC,12)
8035 YSTMIN=VINTPT(IACC,2)
8036 YSTMAX=VINTPT(IACC,22)
8037 AYST0=YSTMAX-YSTMIN
8038 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
8039 AYST2=AYST1
8040 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
8041 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
8042 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
8043 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
8044 IF(MINT(45).EQ.3) THEN
8045 TAUE=VINTPT(IACC,11)
8046 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
8047 YST0=-0.5D0*LOG(TAUE)
8048 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
8049 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
8050 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
8051 & MAX(1D-10,1D0-EXP(YST-YST0))
8052 ENDIF
8053 IF(MINT(46).EQ.3) THEN
8054 TAUE=VINTPT(IACC,11)
8055 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
8056 YST0=-0.5D0*LOG(TAUE)
8057 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
8058 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
8059 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
8060 & MAX(1D-10,1D0-EXP(-YST-YST0))
8061 ENDIF
8062
8063C...Sum up cos(theta-hat) cross-section pieces in points used.
8064 ELSE
8065 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
8066 RSQM=1D0+RM34
8067 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
8068 CTHMIN=-CTHMAX
8069 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
8070 & (TAUMAX*VINT(2)))
8071 ACTH1=CTHMAX-CTHMIN
8072 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
8073 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
8074 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
8075 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
8076 CTH=VINTPT(IACC,13)
8077 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
8078 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
8079 & MAX(RM34,RSQM-CTH)
8080 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
8081 & MAX(RM34,RSQM+CTH)
8082 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
8083 & MAX(RM34,RSQM-CTH)**2
8084 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
8085 & MAX(RM34,RSQM+CTH)**2
8086 ENDIF
8087 180 CONTINUE
8088
8089C...Check that equation system solvable.
8090 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
8091 MSOLV=1
8092 WTRELS=0D0
8093 DO 190 IBIN=1,NBIN
8094 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
8095 & IRED=1,NBIN),WTREL(IBIN)
8096 IF(NAREL(IBIN).EQ.0) MSOLV=0
8097 WTRELS=WTRELS+WTREL(IBIN)
8098 190 CONTINUE
8099 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
8100
8101C...Solve to find relative importance of cross-section pieces.
8102 IF(MSOLV.EQ.1) THEN
8103 DO 200 IBIN=1,NBIN
8104 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
8105 WTRSAV(IBIN)=WTREL(IBIN)
8106 200 CONTINUE
8107C...Auxiliary vectors to record order of permutations
8108 DO I=1,NBIN
8109 IP(I) = I
8110 IQ(I) = I
8111 ENDDO
8112 DO 230 IRED=1,NBIN-1
8113 MROW=IRED
8114 RESMAX=ABS(WTREL(MROW))
8115C...Find row with largest residual
8116 DO JBIN=IRED+1,NBIN
8117 IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN
8118 MROW=JBIN
8119 RESMAX=ABS(WTREL(MROW))
8120 ENDIF
8121 ENDDO
8122 IF(RESMAX.LT.1D-20) THEN
8123 MSOLV=0
8124 GOTO 260
8125 ENDIF
8126 MCOL = IRED
8127 AMAX = ABS(WTMAT(MROW,MCOL))
8128C...Find column with largest entry
8129 DO JBIN=IRED+1,NBIN
8130 IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN
8131 MCOL = JBIN
8132 AMAX = ABS(WTMAT(MROW,MCOL))
8133 ENDIF
8134 ENDDO
8135C...Swap rows if necessary
8136 IF(MROW.NE.IRED) THEN
8137 DO JBIN=1,NBIN
8138 TMPE=WTMAT(IRED,JBIN)
8139 WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN)
8140 WTMAT(MROW,JBIN)=TMPE
8141 ENDDO
8142 TMPE=WTREL(IRED)
8143 WTREL(IRED)=WTREL(MROW)
8144 WTREL(MROW)=TMPE
8145 MTMP=IQ(IRED)
8146 IQ(IRED)=IQ(MROW)
8147 IQ(MROW)=MTMP
8148 ENDIF
8149C...Swap columns if necessary
8150 IF(MCOL.NE.IRED) THEN
8151 DO JBIN=1,NBIN
8152 TMPE=WTMAT(JBIN,IRED)
8153 WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL)
8154 WTMAT(JBIN,MCOL)=TMPE
8155 ENDDO
8156 MTMP=IP(IRED)
8157 IP(IRED)=IP(MCOL)
8158 IP(MCOL)=MTMP
8159 ENDIF
8160C...Begin eliminating equations
8161 DO 220 IBIN=IRED+1,NBIN
8162 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8163 MSOLV=0
8164 GOTO 260
8165 ENDIF
8166C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
8167 RQTU=WTMAT(IBIN,IRED)
8168 RQTL=WTMAT(IRED,IRED)
8169C...Switch order of operations
8170 WTREL(IBIN)=WTREL(IBIN)-RQTU*
8171 $ (WTREL(IRED)/RQTL)
8172 DO 210 ICOE=IRED,NBIN
8173 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-
8174 $ RQTU*(WTMAT(IRED,ICOE)/RQTL)
8175 210 CONTINUE
8176 220 CONTINUE
8177 230 CONTINUE
8178 DO 250 IRED=NBIN,1,-1
8179 DO 240 ICOE=IRED+1,NBIN
8180 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
8181 240 CONTINUE
8182 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8183 MSOLV=0
8184 GOTO 260
8185 ENDIF
8186 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
8187 TEMPC(IRED)=COEFU(IRED)
8188 250 CONTINUE
8189C...Return to original order
8190 DO IBIN=1,NBIN
8191 MTMP=IP(IBIN)
8192 COEFU(MTMP)=TEMPC(IBIN)
8193 ENDDO
8194 ENDIF
8195
8196C...Share evenly if failure.
8197 260 IF(MSOLV.EQ.0) THEN
8198 DO 270 IBIN=1,NBIN
8199 COEFU(IBIN)=1D0
8200 WTRELN(IBIN)=0.1D0
8201 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
8202 & WTRSAV(IBIN)/WTRELS)
8203 270 CONTINUE
8204 ENDIF
8205
8206C...Normalize coefficients, with piece shared democratically.
8207 COEFSU=0D0
8208 WTRELS=0D0
8209 DO 280 IBIN=1,NBIN
8210 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
8211 COEFSU=COEFSU+COEFU(IBIN)
8212 WTRELS=WTRELS+WTRELN(IBIN)
8213 280 CONTINUE
8214 IF(COEFSU.GT.0D0) THEN
8215 DO 290 IBIN=1,NBIN
8216 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
8217 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
8218 290 CONTINUE
8219 ELSE
8220 DO 300 IBIN=1,NBIN
8221 COEFO(IBIN)=1D0/NBIN
8222 300 CONTINUE
8223 ENDIF
8224 IF(IVAR.EQ.1) IOFF=0
8225 IF(IVAR.EQ.2) IOFF=17
8226 IF(IVAR.EQ.3) IOFF=7
8227 IF(IVAR.EQ.4) IOFF=12
8228 DO 310 IBIN=1,NBIN
8229 ICOF=IOFF+IBIN
8230 IF(IVAR.EQ.1) THEN
8231 IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
8232 ICOF=7
8233 ENDIF
8234 ENDIF
8235 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
8236 IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
8237 COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
8238 ELSE
8239 COEF(ISUB,ICOF)=COEFO(IBIN)
8240 ENDIF
8241 310 CONTINUE
8242
8243 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
8244 & (COEFO(IBIN),IBIN=1,NBIN)
8245
8246 320 CONTINUE
8247
8248C...Find two most promising maxima among points previously determined.
8249 DO 330 J=1,4
8250 IACCMX(J)=0
8251 SIGSMX(J)=0D0
8252 330 CONTINUE
8253 NMAX=0
8254 DO 390 IACC=1,NACC
8255 DO 340 J=1,30
8256 VINT(10+J)=VINTPT(IACC,J)
8257 340 CONTINUE
8258 IF(ISTSB.NE.5) THEN
8259 CALL PYSIGH(NCHN,SIGS)
8260 IF(MWTXS.EQ.1) THEN
8261 CALL PYEVWT(WTXS)
8262 SIGS=WTXS*SIGS
8263 ENDIF
8264 ELSE
8265 SIGS=0D0
8266 DO 350 IKIN3=1,MSTP(129)
8267 CALL PYKMAP(5,0,0D0)
8268 IF(MINT(51).EQ.1) GOTO 350
8269 CALL PYSIGH(NCHN,SIGTMP)
8270 IF(MWTXS.EQ.1) THEN
8271 CALL PYEVWT(WTXS)
8272 SIGTMP=WTXS*SIGTMP
8273 ENDIF
8274 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8275 350 CONTINUE
8276 ENDIF
8277 IEQ=0
8278 DO 360 IMV=1,NMAX
8279 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
8280 360 CONTINUE
8281 IF(IEQ.EQ.0) THEN
8282 DO 370 IMV=NMAX,1,-1
8283 IIN=IMV+1
8284 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
8285 IACCMX(IMV+1)=IACCMX(IMV)
8286 SIGSMX(IMV+1)=SIGSMX(IMV)
8287 370 CONTINUE
8288 IIN=1
8289 380 IACCMX(IIN)=IACC
8290 SIGSMX(IIN)=SIGS
8291 IF(NMAX.LE.1) NMAX=NMAX+1
8292 ENDIF
8293 390 CONTINUE
8294
8295C...Read out starting position for search.
8296 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
8297 SIGSAM=SIGSMX(1)
8298 DO 440 IMAX=1,NMAX
8299 IACC=IACCMX(IMAX)
8300 MTAU=MVARPT(IACC,1)
8301 MTAUP=MVARPT(IACC,2)
8302 MYST=MVARPT(IACC,3)
8303 MCTH=MVARPT(IACC,4)
8304 VTAU=0.5D0
8305 VYST=0.5D0
8306 VCTH=0.5D0
8307 VTAUP=0.5D0
8308
8309C...Starting point and step size in parameter space.
8310 DO 430 IRPT=1,2
8311 DO 420 IVAR=1,4
8312 IF(NPTS(IVAR).EQ.1) GOTO 420
8313 IF(IVAR.EQ.1) VVAR=VTAU
8314 IF(IVAR.EQ.2) VVAR=VTAUP
8315 IF(IVAR.EQ.3) VVAR=VYST
8316 IF(IVAR.EQ.4) VVAR=VCTH
8317 IF(IVAR.EQ.1) MVAR=MTAU
8318 IF(IVAR.EQ.2) MVAR=MTAUP
8319 IF(IVAR.EQ.3) MVAR=MYST
8320 IF(IVAR.EQ.4) MVAR=MCTH
8321 IF(IRPT.EQ.1) VDEL=0.1D0
8322 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
8323 & 0.98D0-VVAR))
8324 IF(IRPT.EQ.1) VMAR=0.02D0
8325 IF(IRPT.EQ.2) VMAR=0.002D0
8326 IMOV0=1
8327 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
8328 DO 410 IMOV=IMOV0,8
8329
8330C...Define new point in parameter space.
8331 IF(IMOV.EQ.0) THEN
8332 INEW=2
8333 VNEW=VVAR
8334 ELSEIF(IMOV.EQ.1) THEN
8335 INEW=3
8336 VNEW=VVAR+VDEL
8337 ELSEIF(IMOV.EQ.2) THEN
8338 INEW=1
8339 VNEW=VVAR-VDEL
8340 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
8341 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
8342 VVAR=VVAR+VDEL
8343 SIGSSM(1)=SIGSSM(2)
8344 SIGSSM(2)=SIGSSM(3)
8345 INEW=3
8346 VNEW=VVAR+VDEL
8347 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
8348 & VVAR-2D0*VDEL.GT.VMAR) THEN
8349 VVAR=VVAR-VDEL
8350 SIGSSM(3)=SIGSSM(2)
8351 SIGSSM(2)=SIGSSM(1)
8352 INEW=1
8353 VNEW=VVAR-VDEL
8354 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
8355 VDEL=0.5D0*VDEL
8356 VVAR=VVAR+VDEL
8357 SIGSSM(1)=SIGSSM(2)
8358 INEW=2
8359 VNEW=VVAR
8360 ELSE
8361 VDEL=0.5D0*VDEL
8362 VVAR=VVAR-VDEL
8363 SIGSSM(3)=SIGSSM(2)
8364 INEW=2
8365 VNEW=VVAR
8366 ENDIF
8367
8368C...Convert to relevant variables and find derived new limits.
8369 ILERR=0
8370 IF(IVAR.EQ.1) THEN
8371 VTAU=VNEW
8372 CALL PYKMAP(1,MTAU,VTAU)
8373 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8374 CALL PYKLIM(4)
8375 IF(MINT(51).EQ.1) ILERR=1
8376 ENDIF
8377 ENDIF
8378 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
8379 & ILERR.EQ.0) THEN
8380 IF(IVAR.EQ.2) VTAUP=VNEW
8381 CALL PYKMAP(4,MTAUP,VTAUP)
8382 ENDIF
8383 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
8384 CALL PYKLIM(2)
8385 IF(MINT(51).EQ.1) ILERR=1
8386 ENDIF
8387 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
8388 IF(IVAR.EQ.3) VYST=VNEW
8389 CALL PYKMAP(2,MYST,VYST)
8390 CALL PYKLIM(3)
8391 IF(MINT(51).EQ.1) ILERR=1
8392 ENDIF
8393 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
8394 & ILERR.EQ.0) THEN
8395 IF(IVAR.EQ.4) VCTH=VNEW
8396 CALL PYKMAP(3,MCTH,VCTH)
8397 ENDIF
8398 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
8399
8400C...Evaluate cross-section. Save new maximum. Final maximum.
8401 IF(ILERR.NE.0) THEN
8402 SIGS=0.
8403 ELSEIF(ISTSB.NE.5) THEN
8404 CALL PYSIGH(NCHN,SIGS)
8405 IF(MWTXS.EQ.1) THEN
8406 CALL PYEVWT(WTXS)
8407 SIGS=WTXS*SIGS
8408 ENDIF
8409 ELSE
8410 SIGS=0D0
8411 DO 400 IKIN3=1,MSTP(129)
8412 CALL PYKMAP(5,0,0D0)
8413 IF(MINT(51).EQ.1) GOTO 400
8414 CALL PYSIGH(NCHN,SIGTMP)
8415 IF(MWTXS.EQ.1) THEN
8416 CALL PYEVWT(WTXS)
8417 SIGTMP=WTXS*SIGTMP
8418 ENDIF
8419 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8420 400 CONTINUE
8421 ENDIF
8422 SIGSSM(INEW)=SIGS
8423 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
8424 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
8425 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
8426 410 CONTINUE
8427 420 CONTINUE
8428 430 CONTINUE
8429 440 CONTINUE
8430 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
8431 XSEC(ISUB,1)=1.05D0*SIGSAM
8432C...Add extra headroom for UED
8433 IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0
8434 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
8435 & WTGAGA*XSEC(ISUB,1)
8436 450 CONTINUE
8437 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
8438 & PARP(174)*XSEC(ISUB,1)
8439 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
8440 460 CONTINUE
8441 MINT(51)=0
8442
8443C...Print summary table.
8444 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
8445 IF(MSTP(127).NE.1) THEN
8446 WRITE(MSTU(11),5900)
8447 CALL PYSTOP(1)
8448 ELSE
8449 WRITE(MSTU(11),6400)
8450 MSTI(53)=1
8451 ENDIF
8452 ENDIF
8453 IF(MSTP(122).GE.1) THEN
8454 WRITE(MSTU(11),6000)
8455 WRITE(MSTU(11),6100)
8456 DO 470 ISUB=1,500
8457 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
8458 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
8459 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
8460 & GOTO 470
8461 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
8462 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
8463 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
8464 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
8465 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
8466 470 CONTINUE
8467 WRITE(MSTU(11),6300)
8468 ENDIF
8469
8470C...Format statements for maximization results.
8471 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
8472 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
8473 &'cth',9X,'tau''',7X,'sigma')
8474 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
8475 &'phase space.'/1X,'Process switched off!')
8476 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
8477 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
8478 &'cross-section.'/1X,'Process switched off!')
8479 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
8480 5500 FORMAT(1X,1P,10D11.3)
8481 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
8482 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
8483 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
8484 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
8485 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
8486 &'cross-section.'/1X,'Execution stopped!')
8487 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
8488 &'cross-section maximum search',1X,8('*'))
8489 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
8490 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
8491 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
8492 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
8493 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
8494 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
8495 &'cross-section.'/
8496 &1X,'Execution will stop if you try to generate events.')
8497
8498 RETURN
8499 END
8500
8501C*********************************************************************
8502
8503C...PYPILE
8504C...Initializes multiplicity distribution and selects mutliplicity
8505C...of pileup events, i.e. several events occuring at the same
8506C...beam crossing.
8507
8508 SUBROUTINE PYPILE(MPILE)
8509
8510C...Double precision and integer declarations.
8511 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8512 IMPLICIT INTEGER(I-N)
8513 INTEGER PYK,PYCHGE,PYCOMP
8514C...Commonblocks.
8515 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8516 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8517 COMMON/PYINT1/MINT(400),VINT(400)
8518 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8519 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
8520C...Local arrays and saved variables.
8521 DIMENSION WTI(0:200)
8522 SAVE IMIN,IMAX,WTI,WTS
8523
8524C...Sum of allowed cross-sections for pileup events.
8525 IF(MPILE.EQ.1) THEN
8526 VINT(131)=SIGT(0,0,5)
8527 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
8528 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
8529 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
8530 IF(MSTP(133).LE.0) RETURN
8531
8532C...Initialize multiplicity distribution at maximum.
8533 XNAVE=VINT(131)*PARP(131)
8534 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
8535 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
8536 WTI(INAVE)=1D0
8537 WTS=WTI(INAVE)
8538 WTN=WTI(INAVE)*INAVE
8539
8540C...Find shape of multiplicity distribution below maximum.
8541 IMIN=INAVE
8542 DO 100 I=INAVE-1,1,-1
8543 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
8544 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
8545 IF(WTI(I).LT.1D-6) GOTO 110
8546 WTS=WTS+WTI(I)
8547 WTN=WTN+WTI(I)*I
8548 IMIN=I
8549 100 CONTINUE
8550
8551C...Find shape of multiplicity distribution above maximum.
8552 110 IMAX=INAVE
8553 DO 120 I=INAVE+1,200
8554 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
8555 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
8556 IF(WTI(I).LT.1D-6) GOTO 130
8557 WTS=WTS+WTI(I)
8558 WTN=WTN+WTI(I)*I
8559 IMAX=I
8560 120 CONTINUE
8561 130 VINT(132)=XNAVE
8562 VINT(133)=WTN/WTS
8563 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
8564 & WTS/(WTS+WTI(1)/XNAVE)
8565 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
8566 IF(MSTP(133).GE.2) VINT(134)=XNAVE
8567
8568C...Pick multiplicity of pileup events.
8569 ELSE
8570 IF(MSTP(133).LE.0) THEN
8571 MINT(81)=MAX(1,MSTP(134))
8572 ELSE
8573 WTR=WTS*PYR(0)
8574 DO 140 I=IMIN,IMAX
8575 MINT(81)=I
8576 WTR=WTR-WTI(I)
8577 IF(WTR.LE.0D0) GOTO 150
8578 140 CONTINUE
8579 150 CONTINUE
8580 ENDIF
8581 ENDIF
8582
8583C...Format statement for error message.
8584 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
8585 &'crossing too large, ',1P,D12.4)
8586
8587 RETURN
8588 END
8589
8590C*********************************************************************
8591
8592C...PYSAVE
8593C...Saves and restores parameter and cross section values for the
8594C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8595C...Also makes random choice between alternatives.
8596
8597 SUBROUTINE PYSAVE(ISAVE,IGA)
8598
8599C...Double precision and integer declarations.
8600 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8601 IMPLICIT INTEGER(I-N)
8602 INTEGER PYK,PYCHGE,PYCOMP
8603C...Commonblocks.
8604 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8605 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8606 COMMON/PYINT1/MINT(400),VINT(400)
8607 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8608 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8609 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8610 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
8611C...Local arrays and saved variables.
8612 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
8613 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
8614 &INTCP(15,20),RECP(15,20)
8615 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
8616
8617C...Save list of subprocesses and cross-section information.
8618 IF(ISAVE.EQ.1) THEN
8619 ICP=0
8620 DO 120 I=1,500
8621 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
8622 ICP=ICP+1
8623 NSUBCP(IGA,ICP)=I
8624 MSUBCP(IGA,ICP)=MSUB(I)
8625 DO 100 J=1,20
8626 COEFCP(IGA,ICP,J)=COEF(I,J)
8627 100 CONTINUE
8628 DO 110 J=1,3
8629 NGENCP(IGA,ICP,J)=NGEN(I,J)
8630 XSECCP(IGA,ICP,J)=XSEC(I,J)
8631 110 CONTINUE
8632 120 CONTINUE
8633 NCP(IGA)=ICP
8634 DO 130 J=1,3
8635 NGENCP(IGA,0,J)=NGEN(0,J)
8636 XSECCP(IGA,0,J)=XSEC(0,J)
8637 130 CONTINUE
8638 DO 160 I1=0,6
8639 DO 150 I2=0,6
8640 DO 140 J=0,5
8641 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
8642 140 CONTINUE
8643 150 CONTINUE
8644 160 CONTINUE
8645
8646C...Save various common process variables.
8647 DO 170 J=1,10
8648 INTCP(IGA,J)=MINT(40+J)
8649 170 CONTINUE
8650 INTCP(IGA,11)=MINT(101)
8651 INTCP(IGA,12)=MINT(102)
8652 INTCP(IGA,13)=MINT(107)
8653 INTCP(IGA,14)=MINT(108)
8654 INTCP(IGA,15)=MINT(123)
8655 RECP(IGA,1)=CKIN(3)
8656 RECP(IGA,2)=VINT(318)
8657
8658C...Save cross-section information only.
8659 ELSEIF(ISAVE.EQ.2) THEN
8660 DO 190 ICP=1,NCP(IGA)
8661 I=NSUBCP(IGA,ICP)
8662 DO 180 J=1,3
8663 NGENCP(IGA,ICP,J)=NGEN(I,J)
8664 XSECCP(IGA,ICP,J)=XSEC(I,J)
8665 180 CONTINUE
8666 190 CONTINUE
8667 DO 200 J=1,3
8668 NGENCP(IGA,0,J)=NGEN(0,J)
8669 XSECCP(IGA,0,J)=XSEC(0,J)
8670 200 CONTINUE
8671
8672C...Choose between allowed alternatives.
8673 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8674 IF(ISAVE.EQ.4) THEN
8675 XSUMCP=0D0
8676 DO 210 IG=1,MINT(121)
8677 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8678 210 CONTINUE
8679 XSUMCP=XSUMCP*PYR(0)
8680 DO 220 IG=1,MINT(121)
8681 IGA=IG
8682 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8683 IF(XSUMCP.LE.0D0) GOTO 230
8684 220 CONTINUE
8685 230 CONTINUE
8686 ENDIF
8687
8688C...Restore cross-section information.
8689 DO 240 I=1,500
8690 MSUB(I)=0
8691 240 CONTINUE
8692 DO 270 ICP=1,NCP(IGA)
8693 I=NSUBCP(IGA,ICP)
8694 MSUB(I)=MSUBCP(IGA,ICP)
8695 DO 250 J=1,20
8696 COEF(I,J)=COEFCP(IGA,ICP,J)
8697 250 CONTINUE
8698 DO 260 J=1,3
8699 NGEN(I,J)=NGENCP(IGA,ICP,J)
8700 XSEC(I,J)=XSECCP(IGA,ICP,J)
8701 260 CONTINUE
8702 270 CONTINUE
8703 DO 280 J=1,3
8704 NGEN(0,J)=NGENCP(IGA,0,J)
8705 XSEC(0,J)=XSECCP(IGA,0,J)
8706 280 CONTINUE
8707 DO 310 I1=0,6
8708 DO 300 I2=0,6
8709 DO 290 J=0,5
8710 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8711 290 CONTINUE
8712 300 CONTINUE
8713 310 CONTINUE
8714
8715C...Restore various common process variables.
8716 DO 320 J=1,10
8717 MINT(40+J)=INTCP(IGA,J)
8718 320 CONTINUE
8719 MINT(101)=INTCP(IGA,11)
8720 MINT(102)=INTCP(IGA,12)
8721 MINT(107)=INTCP(IGA,13)
8722 MINT(108)=INTCP(IGA,14)
8723 MINT(123)=INTCP(IGA,15)
8724 CKIN(3)=RECP(IGA,1)
8725 CKIN(1)=2D0*CKIN(3)
8726 VINT(318)=RECP(IGA,2)
8727
8728C...Sum up cross-section info (for PYSTAT).
8729 ELSEIF(ISAVE.EQ.5) THEN
8730 DO 330 I=1,500
8731 MSUB(I)=0
8732 NGEN(I,1)=0
8733 NGEN(I,3)=0
8734 XSEC(I,3)=0D0
8735 330 CONTINUE
8736 NGEN(0,1)=0
8737 NGEN(0,2)=0
8738 NGEN(0,3)=0
8739 XSEC(0,3)=0
8740 DO 350 IG=1,MINT(121)
8741 DO 340 ICP=1,NCP(IG)
8742 I=NSUBCP(IG,ICP)
8743 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8744 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8745 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8746 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8747 340 CONTINUE
8748 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8749 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8750 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8751 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8752 350 CONTINUE
8753 ENDIF
8754
8755 RETURN
8756 END
8757
8758C*********************************************************************
8759
8760C...PYGAGA
8761C...For lepton beams it gives photon-hadron or photon-photon systems
8762C...to be treated with the ordinary machinery and combines this with a
8763C...description of the lepton -> lepton + photon branching.
8764
8765 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8766
8767C...Double precision and integer declarations.
8768 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8769 IMPLICIT INTEGER(I-N)
8770 INTEGER PYK,PYCHGE,PYCOMP
8771C...Commonblocks.
8772 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8773 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8774 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8775 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8776 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8777 COMMON/PYINT1/MINT(400),VINT(400)
8778 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8779 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8780 &/PYINT5/
8781C...Local variables and data statement.
8782 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8783 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8784 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8785 DATA EPS/1D-4/
8786
8787C...Initialize generation of photons inside leptons.
8788 IF(IGAGA.EQ.1) THEN
8789
8790C...Save quantities on incoming lepton system.
8791 VINT(301)=VINT(1)
8792 VINT(302)=VINT(2)
8793 PMS(1)=VINT(303)**2
8794 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8795 PMS(2)=VINT(304)**2
8796 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8797 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8798 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8799
8800C...Calculate range of x and Q2 values allowed in generation.
8801 DO 100 I=1,2
8802 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8803 IF(MINT(140+I).NE.0) THEN
8804 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8805 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8806 & PMC(I),1D0-EPS)
8807 YMIN=MAX(CKIN(71+2*I),EPS)
8808 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8809 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8810 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8811 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8812 THEMIN=MAX(CKIN(67+2*I),0D0)
8813 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8814 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8815 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8816 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8817 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8818 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8819 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8820 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8821 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8822C...W limits when lepton on one side only.
8823 IF(MINT(143-I).EQ.0) THEN
8824 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8825 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8826 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8827 ENDIF
8828 ENDIF
8829 100 CONTINUE
8830
8831C...W limits when lepton on both sides.
8832 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8833 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8834 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8835 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8836 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8837 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8838 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8839 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8840 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8841 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8842 ELSE
8843 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8844 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8845 ENDIF
8846 ENDIF
8847
8848C...Q2 and W values and photon flux weight factors for initialization.
8849 ELSEIF(IGAGA.EQ.2) THEN
8850 ISUB=MINT(1)
8851 MINT(15)=0
8852 MINT(16)=0
8853
8854C...W value for photon on one or both sides, and for processes
8855C...with gamma-gamma cross section peaked at small shat.
8856 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8857 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8858 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8859 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8860 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8861 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8862 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8863 ELSE
8864 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8865 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8866 ENDIF
8867 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8868
8869C...Upper estimate of photon flux weight factor.
8870C...Initialization Q2 scale. Flag incoming unresolved photon.
8871 WTGAGA=1D0
8872 DO 110 I=1,2
8873 IF(MINT(140+I).NE.0) THEN
8874 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8875 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8876 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8877 & THEN
8878 Q2INIT=5D0+Q2MIN(3-I)
8879 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8880 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8881 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8882 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8883 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8884 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8885 Q2INIT=VINT(2)/3D0
8886 ELSEIF(ISUB.EQ.140) THEN
8887 Q2INIT=VINT(2)/2D0
8888 ELSE
8889 Q2INIT=Q2MIN(I)
8890 ENDIF
8891 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8892 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8893 & MINT(14+I)=22
8894 VINT(306+I)=VINT(2+I)**2
8895 ENDIF
8896 110 CONTINUE
8897 VINT(320)=WTGAGA
8898
8899C...Update pTmin and cross section information.
8900 IF(MSTP(82).LE.1) THEN
8901 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8902 ELSE
8903 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8904 ENDIF
8905 VINT(149)=4D0*PTMN**2/VINT(2)
8906 VINT(154)=PTMN
8907 CALL PYXTOT
8908 VINT(318)=VINT(317)
8909
8910C...Generate photons inside leptons and
8911C...calculate photon flux weight factors.
8912 ELSEIF(IGAGA.EQ.3) THEN
8913 ISUB=MINT(1)
8914 MINT(15)=0
8915 MINT(16)=0
8916
8917C...Generate phase space point and check against cuts.
8918 LOOP=0
8919 120 LOOP=LOOP+1
8920 DO 130 I=1,2
8921 IF(MINT(140+I).NE.0) THEN
8922C...Pick x and Q2
8923 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8924 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8925C...Cuts on internal consistency in x and Q2.
8926 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8927 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8928 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8929C...Cuts on y and theta.
8930 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8931 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8932 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8933 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8934 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8935 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8936 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8937 & GOTO 120
8938
8939C...Phi angle isotropic. Reconstruct pT.
8940 PHI(I)=PARU(2)*PYR(0)
8941 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8942 & PMS(I))*SIN(THETA(I))
8943
8944C...Store info on variables selected, for documentation purposes.
8945 VINT(2+I)=-SQRT(Q2(I))
8946 VINT(304+I)=X(I)
8947 VINT(306+I)=Q2(I)
8948 VINT(308+I)=Y(I)
8949 VINT(310+I)=THETA(I)
8950 VINT(312+I)=PHI(I)
8951 ELSE
8952 VINT(304+I)=1D0
8953 VINT(306+I)=0D0
8954 VINT(308+I)=1D0
8955 VINT(310+I)=0D0
8956 VINT(312+I)=0D0
8957 ENDIF
8958 130 CONTINUE
8959
8960C...Cut on W combines info from two sides.
8961 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8962 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8963 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8964 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8965 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8966 IF(W2.LT.W2MIN) GOTO 120
8967 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8968 PMS1=-Q2(1)
8969 PMS2=-Q2(2)
8970 ELSEIF(MINT(141).NE.0) THEN
8971 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8972 PMS1=-Q2(1)
8973 PMS2=PMS(2)
8974 ELSEIF(MINT(142).NE.0) THEN
8975 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8976 PMS1=PMS(1)
8977 PMS2=-Q2(2)
8978 ENDIF
8979
8980C...Store kinematics info for photon(s) in subsystem cm frame.
8981 VINT(2)=W2
8982 VINT(1)=SQRT(W2)
8983 VINT(291)=0D0
8984 VINT(292)=0D0
8985 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8986 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8987 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8988 VINT(296)=0D0
8989 VINT(297)=0D0
8990 VINT(298)=-VINT(293)
8991 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8992 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8993
8994C...Assign weight for photon flux; different for transverse and
8995C...longitudinal photons. Flag incoming unresolved photon.
8996 WTGAGA=1D0
8997 DO 140 I=1,2
8998 IF(MINT(140+I).NE.0) THEN
8999 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
9000 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
9001 IF(MSTP(16).EQ.0) THEN
9002 XY=X(I)
9003 ELSE
9004 WTGAGA=WTGAGA*X(I)/Y(I)
9005 XY=Y(I)
9006 ENDIF
9007 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
9008 WTGAGA=WTGAGA*(1D0-XY)
9009 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
9010 WTGAGA=WTGAGA*(1D0-XY)
9011 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
9012 WTGAGA=WTGAGA*(1D0-XY)
9013 ELSE
9014 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
9015 & PMS(I)*XY**2/Q2(I))
9016 ENDIF
9017 IF(MINT(106+I).EQ.0) MINT(14+I)=22
9018 ENDIF
9019 140 CONTINUE
9020 VINT(319)=WTGAGA
9021 MINT(143)=LOOP
9022
9023C...Update pTmin and cross section information.
9024 IF(MSTP(82).LE.1) THEN
9025 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
9026 ELSE
9027 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
9028 ENDIF
9029 VINT(149)=4D0*PTMN**2/VINT(2)
9030 VINT(154)=PTMN
9031 CALL PYXTOT
9032
9033C...Reconstruct kinematics of photons inside leptons.
9034 ELSEIF(IGAGA.EQ.4) THEN
9035
9036C...Make place for incoming particles and scattered leptons.
9037 MOVE=3
9038 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
9039 MINT(4)=MINT(4)+MOVE
9040 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
9041 IF(K(I,1).EQ.21) THEN
9042 DO 150 J=1,5
9043 K(I+MOVE,J)=K(I,J)
9044 P(I+MOVE,J)=P(I,J)
9045 V(I+MOVE,J)=V(I,J)
9046 150 CONTINUE
9047 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
9048 & K(I+MOVE,3)=K(I,3)+MOVE
9049 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
9050 & K(I+MOVE,4)=K(I,4)+MOVE
9051 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
9052 & K(I+MOVE,5)=K(I,5)+MOVE
9053 ENDIF
9054 160 CONTINUE
9055 DO 170 I=MINT(84)+1,N
9056 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
9057 & K(I,3)=K(I,3)+MOVE
9058 170 CONTINUE
9059
9060C...Fill in incoming particles.
9061 DO 190 I=MINT(83)+1,MINT(83)+MOVE
9062 DO 180 J=1,5
9063 K(I,J)=0
9064 P(I,J)=0D0
9065 V(I,J)=0D0
9066 180 CONTINUE
9067 190 CONTINUE
9068 DO 200 I=1,2
9069 K(MINT(83)+I,1)=21
9070 IF(MINT(140+I).NE.0) THEN
9071 K(MINT(83)+I,2)=MINT(140+I)
9072 P(MINT(83)+I,5)=VINT(302+I)
9073 ELSE
9074 K(MINT(83)+I,2)=MINT(10+I)
9075 P(MINT(83)+I,5)=VINT(2+I)
9076 ENDIF
9077 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
9078 & VINT(302))*(-1D0)**(I+1)
9079 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
9080 200 CONTINUE
9081
9082C...New mother-daughter relations in documentation section.
9083 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
9084 K(MINT(83)+1,4)=MINT(83)+3
9085 K(MINT(83)+1,5)=MINT(83)+5
9086 K(MINT(83)+2,4)=MINT(83)+4
9087 K(MINT(83)+2,5)=MINT(83)+6
9088 K(MINT(83)+3,3)=MINT(83)+1
9089 K(MINT(83)+5,3)=MINT(83)+1
9090 K(MINT(83)+4,3)=MINT(83)+2
9091 K(MINT(83)+6,3)=MINT(83)+2
9092 ELSEIF(MINT(141).NE.0) THEN
9093 K(MINT(83)+1,4)=MINT(83)+3
9094 K(MINT(83)+1,5)=MINT(83)+4
9095 K(MINT(83)+2,4)=MINT(83)+5
9096 K(MINT(83)+3,3)=MINT(83)+1
9097 K(MINT(83)+4,3)=MINT(83)+1
9098 K(MINT(83)+5,3)=MINT(83)+2
9099 ELSEIF(MINT(142).NE.0) THEN
9100 K(MINT(83)+1,4)=MINT(83)+4
9101 K(MINT(83)+2,4)=MINT(83)+3
9102 K(MINT(83)+2,5)=MINT(83)+5
9103 K(MINT(83)+3,3)=MINT(83)+2
9104 K(MINT(83)+4,3)=MINT(83)+1
9105 K(MINT(83)+5,3)=MINT(83)+2
9106 ENDIF
9107
9108C...Fill scattered lepton(s).
9109 DO 210 I=1,2
9110 IF(MINT(140+I).NE.0) THEN
9111 LSC=MINT(83)+MIN(I+2,MOVE)
9112 K(LSC,1)=21
9113 K(LSC,2)=MINT(140+I)
9114 P(LSC,1)=PT(I)*COS(PHI(I))
9115 P(LSC,2)=PT(I)*SIN(PHI(I))
9116 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
9117 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
9118 & (-1D0)**(I-1)
9119 P(LSC,5)=VINT(302+I)
9120 ENDIF
9121 210 CONTINUE
9122
9123C...Find incoming four-vectors to subprocess.
9124 K(N+1,1)=21
9125 IF(MINT(141).NE.0) THEN
9126 DO 220 J=1,4
9127 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
9128 220 CONTINUE
9129 ELSE
9130 DO 230 J=1,4
9131 P(N+1,J)=P(MINT(83)+1,J)
9132 230 CONTINUE
9133 ENDIF
9134 K(N+2,1)=21
9135 IF(MINT(142).NE.0) THEN
9136 DO 240 J=1,4
9137 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
9138 240 CONTINUE
9139 ELSE
9140 DO 250 J=1,4
9141 P(N+2,J)=P(MINT(83)+2,J)
9142 250 CONTINUE
9143 ENDIF
9144
9145C...Define boost and rotation between hadronic subsystem and
9146C...collision rest frame; boost hadronic subsystem to this frame.
9147 DO 260 J=1,3
9148 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
9149 260 CONTINUE
9150 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
9151 BPHI=PYANGL(P(N+1,1),P(N+1,2))
9152 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
9153 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
9154 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
9155 & BETA(3))
9156
9157C...Add on scattered leptons to final state.
9158 DO 280 I=1,2
9159 IF(MINT(140+I).NE.0) THEN
9160 LSC=MINT(83)+MIN(I+2,MOVE)
9161 N=N+1
9162 DO 270 J=1,5
9163 K(N,J)=K(LSC,J)
9164 P(N,J)=P(LSC,J)
9165 V(N,J)=V(LSC,J)
9166 270 CONTINUE
9167 K(N,1)=1
9168 K(N,3)=LSC
9169 ENDIF
9170 280 CONTINUE
9171 ENDIF
9172
9173 RETURN
9174 END
9175
9176C*********************************************************************
9177
9178C...PYRAND
9179C...Generates quantities characterizing the high-pT scattering at the
9180C...parton level according to the matrix elements. Chooses incoming,
9181C...reacting partons, their momentum fractions and one of the possible
9182C...subprocesses.
9183
9184 SUBROUTINE PYRAND
9185
9186C...Double precision and integer declarations.
9187 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9188 IMPLICIT INTEGER(I-N)
9189 INTEGER PYK,PYCHGE,PYCOMP
9190C...Parameter statement to help give large particle numbers.
9191 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
9192 &KEXCIT=4000000,KDIMEN=5000000)
9193
9194C...User process initialization and event commonblocks.
9195 INTEGER MAXPUP
9196 PARAMETER (MAXPUP=100)
9197 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
9198 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
9199 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
9200 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
9201 &LPRUP(MAXPUP)
9202 INTEGER MAXNUP
9203 PARAMETER (MAXNUP=500)
9204 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
9205 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
9206 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
9207 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
9208 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
9209 SAVE /HEPRUP/,/HEPEUP/
9210
9211C...Commonblocks.
9212 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9213 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9214 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9215 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9216 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9217 COMMON/PYINT1/MINT(400),VINT(400)
9218 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9219 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9220 COMMON/PYINT4/MWID(500),WIDS(500,5)
9221 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
9222 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
9223 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
9224 COMMON/PYTCCO/COEFX(194:380,2)
9225 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
9226 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
9227 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
9228 &/TCPARA/
9229C...Local arrays.
9230 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
9231
9232C...Parameters and data used in elastic/diffractive treatment.
9233 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
9234 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
9235
9236C...Initial values, specifically for (first) semihard interaction.
9237 MINT(10)=0
9238 MINT(17)=0
9239 MINT(18)=0
9240 VINT(143)=1D0
9241 VINT(144)=1D0
9242 VINT(157)=0D0
9243 VINT(158)=0D0
9244 MFAIL=0
9245 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
9246 ISUB=0
9247 ISTSB=0
9248 LOOP=0
9249 100 LOOP=LOOP+1
9250 MINT(51)=0
9251 MINT(143)=1
9252 VINT(97)=1D0
9253
9254C...Start by assuming incoming photon is entering subprocess.
9255 IF(MINT(11).EQ.22) THEN
9256 MINT(15)=22
9257 VINT(307)=VINT(3)**2
9258 ENDIF
9259 IF(MINT(12).EQ.22) THEN
9260 MINT(16)=22
9261 VINT(308)=VINT(4)**2
9262 ENDIF
9263 MINT(103)=MINT(11)
9264 MINT(104)=MINT(12)
9265
9266C...Choice of process type - first event of pileup.
9267 INMULT=0
9268 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
9269 ELSEIF(MINT(82).EQ.1) THEN
9270
9271C...For gamma-p or gamma-gamma first pick between alternatives.
9272 IGA=0
9273 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
9274 MINT(122)=IGA
9275
9276C...For real gamma + gamma with different nature, flip at random.
9277 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
9278 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
9279 MINTSV=MINT(41)
9280 MINT(41)=MINT(42)
9281 MINT(42)=MINTSV
9282 MINTSV=MINT(45)
9283 MINT(45)=MINT(46)
9284 MINT(46)=MINTSV
9285 MINTSV=MINT(107)
9286 MINT(107)=MINT(108)
9287 MINT(108)=MINTSV
9288 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
9289 ENDIF
9290
9291C...Pick process type, possibly by user process machinery.
9292C...(If the latter, also event will be picked here.)
9293 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
9294 CALL UPEVNT
9295 CALL PYUPRE
9296 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
9297 CALL UPEVNT
9298 CALL PYUPRE
9299 ISUB=0
9300 110 ISUB=ISUB+1
9301 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
9302 & ISUB.LT.500) GOTO 110
9303 ELSE
9304 RSUB=XSEC(0,1)*PYR(0)
9305 DO 120 I=1,500
9306 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
9307 ISUB=I
9308 RSUB=RSUB-XSEC(I,1)
9309 IF(RSUB.LE.0D0) GOTO 130
9310 120 CONTINUE
9311 130 IF(ISUB.EQ.95) ISUB=96
9312 IF(ISUB.EQ.96) INMULT=1
9313 IF(ISET(ISUB).EQ.11) THEN
9314 IDPRUP=KFPR(ISUB,2)
9315 CALL UPEVNT
9316 CALL PYUPRE
9317 ENDIF
9318 ENDIF
9319
9320C...Choice of inclusive process type - pileup events.
9321 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
9322 RSUB=VINT(131)*PYR(0)
9323 ISUB=96
9324 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
9325 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
9326 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
9327 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
9328 & ISUB=91
9329 IF(ISUB.EQ.96) INMULT=1
9330 ENDIF
9331
9332C...Choice of photon energy and flux factor inside lepton.
9333 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9334 CALL PYGAGA(3,WTGAGA)
9335 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
9336 CKIN(3)=MAX(VINT(285),VINT(154))
9337 CKIN(1)=2D0*CKIN(3)
9338 ENDIF
9339C...When necessary set direct/resolved photon by hand.
9340 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
9341 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
9342 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
9343 ENDIF
9344
9345C...Restrict direct*resolved processes to pTmin >= Q,
9346C...to avoid doublecounting with DIS.
9347 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
9348 IF(MINT(15).EQ.22) THEN
9349 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
9350 ELSE
9351 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
9352 ENDIF
9353 CKIN(1)=2D0*CKIN(3)
9354 ENDIF
9355
9356C...Set up for multiple interactions (may include impact parameter).
9357 IF(INMULT.EQ.1) THEN
9358 IF(MINT(35).LE.1) CALL PYMULT(2)
9359 IF(MINT(35).GE.2) CALL PYMIGN(2)
9360 ENDIF
9361
9362C...Loopback point for minimum bias in photon physics.
9363 LOOP2=0
9364 140 LOOP2=LOOP2+1
9365 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
9366 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
9367 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
9368 &NGEN(97,1)=NGEN(97,1)+MINT(143)
9369 MINT(1)=ISUB
9370 ISTSB=ISET(ISUB)
9371
9372C...Random choice of flavour for some SUSY processes.
9373 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
9374C...~e_L ~nu_e or ~mu_L ~nu_mu.
9375 IF(ISUB.EQ.210) THEN
9376 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
9377 KFPR(ISUB,2)=KFPR(ISUB,1)+1
9378C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9379 ELSEIF(ISUB.EQ.213) THEN
9380 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
9381 KFPR(ISUB,2)=KFPR(ISUB,1)
9382C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9383 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
9384 & ISUB.NE.257) THEN
9385 IF(ISUB.GE.258) THEN
9386 RKF=4D0
9387 ELSE
9388 RKF=5D0
9389 ENDIF
9390 IF(MOD(ISUB,2).EQ.0) THEN
9391 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
9392 ELSE
9393 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
9394 ENDIF
9395C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9396 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
9397 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
9398 KSU1=KSUSY1
9399 KSU2=KSUSY1
9400 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
9401 KSU1=KSUSY2
9402 KSU2=KSUSY2
9403 ELSEIF(PYR(0).LT.0.5D0) THEN
9404 KSU1=KSUSY1
9405 KSU2=KSUSY2
9406 ELSE
9407 KSU1=KSUSY2
9408 KSU2=KSUSY1
9409 ENDIF
9410 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
9411 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
9412C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9413 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
9414 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
9415 KFPR(ISUB,2)=KFPR(ISUB,1)
9416 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
9417 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
9418 KFPR(ISUB,2)=KFPR(ISUB,1)
9419C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9420 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
9421 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
9422 KSU1=KSUSY1
9423 KSU2=KSUSY1
9424 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
9425 KSU1=KSUSY2
9426 KSU2=KSUSY2
9427 ELSEIF(PYR(0).LT.0.5D0) THEN
9428 KSU1=KSUSY1
9429 KSU2=KSUSY2
9430 ELSE
9431 KSU1=KSUSY2
9432 KSU2=KSUSY1
9433 ENDIF
9434 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
9435 RKF=5D0
9436 ELSE
9437 RKF=4D0
9438 ENDIF
9439 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
9440 ENDIF
9441 ENDIF
9442
9443C...Random choice of flavours for some UED processes
9444c...The production processes can generate a doublet pair,
9445c...a singlet pair, or a doublet + singlet.
9446 IF(ISUB.EQ.313)THEN
9447C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
9448 IF(PYR(0).LE.0.1)THEN
9449 KFPR(ISUB,1)=5100001
9450 ELSE
9451 KFPR(ISUB,1)=5100002
9452 ENDIF
9453 KFPR(ISUB,2)=KFPR(ISUB,1)
9454 ELSEIF(ISUB.EQ.314.OR.ISUB.EQ.315)THEN
9455C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
9456C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
9457 IF(PYR(0).LE.0.1)THEN
9458 KFPR(ISUB,1)=5100001
9459 ELSE
9460 KFPR(ISUB,1)=5100002
9461 ENDIF
9462 KFPR(ISUB,2)=-KFPR(ISUB,1)
9463 ELSEIF(ISUB.EQ.316)THEN
9464C...qi + qbarj -> q*_Di + q*_Sbarj
9465 IF(PYR(0).LE.0.5)THEN
9466 KFPR(ISUB,1)=5100001
9467c Changed from private pythia6410_ued code
9468c KFPR(ISUB,2)=-5010001
9469 KFPR(ISUB,2)=-6100002
9470 ELSE
9471 KFPR(ISUB,1)=5100002
9472c Changed from private pythia6410_ued code
9473c KFPR(ISUB,2)=-5010002
9474 KFPR(ISUB,2)=-6100001
9475 ENDIF
9476 ELSEIF(ISUB.EQ.317)THEN
9477C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
9478 IF(PYR(0).LE.0.5)THEN
9479 KFPR(ISUB,1)=5100001
9480 KFPR(ISUB,2)=-5100002
9481 ELSE
9482 KFPR(ISUB,1)=5100002
9483 KFPR(ISUB,2)=-5100001
9484 ENDIF
9485 ELSEIF(ISUB.EQ.318)THEN
9486C...qi + qj -> q*_Di + q*_Sj
9487 IF(PYR(0).LE.0.5)THEN
9488 KFPR(ISUB,1)=5100001
9489 KFPR(ISUB,2)=6100002
9490 ELSE
9491 KFPR(ISUB,1)=5100002
9492 KFPR(ISUB,2)=6100001
9493 ENDIF
9494 ENDIF
9495
9496C...Find resonances (explicit or implicit in cross-section).
9497 MINT(72)=0
9498 KFR1=0
9499 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
9500 KFR1=KFPR(ISUB,1)
9501 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
9502 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
9503 KFR1=23
9504 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
9505 & ISUB.EQ.177) THEN
9506 KFR1=24
9507 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
9508 KFR1=25
9509 IF(MSTP(46).EQ.5) THEN
9510 KFR1=89
9511 PMAS(89,1)=PARP(45)
9512 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
9513 ENDIF
9514 ELSEIF(ISUB.EQ.481) THEN
9515 KFR1=9900001
9516 ENDIF
9517 CKMX=CKIN(2)
9518 IF(CKMX.LE.0D0) CKMX=VINT(1)
9519 KCR1=PYCOMP(KFR1)
9520 IF(KCR1.EQ.0) KFR1=0
9521 IF(KFR1.NE.0) THEN
9522 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
9523 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
9524 ENDIF
9525 IF(KFR1.NE.0) THEN
9526 TAUR1=PMAS(KCR1,1)**2/VINT(2)
9527 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
9528 MINT(72)=1
9529 MINT(73)=KFR1
9530 VINT(73)=TAUR1
9531 VINT(74)=GAMR1
9532 ENDIF
9533 KFR2=0
9534 KFR3=0
9535 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
9536 $(ISUB.GE.361.AND.ISUB.LE.380))
9537 $THEN
9538 KFR2=23
9539 IF(ISUB.EQ.141) THEN
9540 KCR2=PYCOMP(KFR2)
9541 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
9542 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
9543 KFR2=0
9544 ELSE
9545 TAUR2=PMAS(KCR2,1)**2/VINT(2)
9546 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
9547 MINT(72)=2
9548 MINT(74)=KFR2
9549 VINT(75)=TAUR2
9550 VINT(76)=GAMR2
9551 ENDIF
9552C...3 resonances at work: rho, omega, a
9553 ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
9554 & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
9555 MINT(72)=IRES
9556 IF(IRES.GE.1) THEN
9557 VINT(73)=XMAS(1)**2/VINT(2)
9558 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
9559 TAUR1=VINT(73)
9560 GAMR1=VINT(74)
9561 KFR1=1
9562 ENDIF
9563 IF(IRES.GE.2) THEN
9564 VINT(75)=XMAS(2)**2/VINT(2)
9565 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
9566 TAUR2=VINT(75)
9567 GAMR2=VINT(76)
9568 KFR2=2
9569 ENDIF
9570 IF(IRES.EQ.3) THEN
9571 VINT(77)=XMAS(3)**2/VINT(2)
9572 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
9573 TAUR3=VINT(77)
9574 GAMR3=VINT(78)
9575 KFR3=3
9576 ENDIF
9577C...Charged current: rho+- and a+-
9578 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
9579 MINT(72)=IRES
9580 IF(JRES.GE.1) THEN
9581 VINT(73)=YMAS(1)**2/VINT(2)
9582 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
9583 KFR1=1
9584 TAUR1=VINT(73)
9585 GAMR1=VINT(74)
9586 ENDIF
9587 IF(JRES.GE.2) THEN
9588 VINT(75)=YMAS(2)**2/VINT(2)
9589 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
9590 KFR2=2
9591 TAUR2=VINT(73)
9592 GAMR2=VINT(74)
9593 ENDIF
9594 KFR3=0
9595 ENDIF
9596 IF(ISUB.NE.141) THEN
9597 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
9598
9599 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
9600 MINT(72)=2
9601 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
9602 MINT(72)=2
9603 MINT(74)=KFR3
9604 VINT(75)=TAUR3
9605 VINT(76)=GAMR3
9606 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
9607 MINT(72)=2
9608 MINT(73)=KFR2
9609 VINT(73)=TAUR2
9610 VINT(74)=GAMR2
9611 MINT(74)=KFR3
9612 VINT(75)=TAUR3
9613 VINT(76)=GAMR3
9614 ELSEIF(KFR1.NE.0) THEN
9615 MINT(72)=1
9616 ELSEIF(KFR2.NE.0) THEN
9617 MINT(72)=1
9618 MINT(73)=KFR2
9619 VINT(73)=TAUR2
9620 VINT(74)=GAMR2
9621 ELSEIF(KFR3.NE.0) THEN
9622 MINT(72)=1
9623 MINT(73)=KFR3
9624 VINT(73)=TAUR3
9625 VINT(74)=GAMR3
9626 ELSE
9627 MINT(72)=0
9628 ENDIF
9629 ELSE
9630 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
9631
9632 ELSEIF(KFR2.NE.0) THEN
9633 KFR1=KFR2
9634 TAUR1=TAUR2
9635 GAMR1=GAMR2
9636 MINT(72)=1
9637 MINT(73)=KFR1
9638 VINT(73)=TAUR1
9639 VINT(74)=GAMR1
9640 KFR2=0
9641 ELSE
9642 MINT(72)=0
9643 ENDIF
9644 ENDIF
9645 ENDIF
9646
9647C...Find product masses and minimum pT of process,
9648C...optionally with broadening according to a truncated Breit-Wigner.
9649 VINT(63)=0D0
9650 VINT(64)=0D0
9651 MINT(71)=0
9652 VINT(71)=CKIN(3)
9653 IF(MINT(82).GE.2) VINT(71)=0D0
9654 VINT(80)=1D0
9655 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9656 NBW=0
9657 DO 160 I=1,2
9658 PMMN(I)=0D0
9659 IF(KFPR(ISUB,I).EQ.0) THEN
9660 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
9661 & PARP(41)) THEN
9662 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
9663 ELSE
9664 NBW=NBW+1
9665C...This prevents SUSY/t particles from becoming too light.
9666 KFLW=KFPR(ISUB,I)
9667 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9668 KCW=PYCOMP(KFLW)
9669 PMMN(I)=PMAS(KCW,1)
9670 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9671 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9672 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9673 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9674 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9675 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9676 PMMN(I)=MIN(PMMN(I),PMSUM)
9677 ENDIF
9678 150 CONTINUE
9679 ELSEIF(KFLW.EQ.6) THEN
9680 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9681 ENDIF
9682 ENDIF
9683 160 CONTINUE
9684 IF(NBW.GE.1) THEN
9685 CKIN41=CKIN(41)
9686 CKIN43=CKIN(43)
9687 CKIN(41)=MAX(PMMN(1),CKIN(41))
9688 CKIN(43)=MAX(PMMN(2),CKIN(43))
9689 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
9690 CKIN(41)=CKIN41
9691 CKIN(43)=CKIN43
9692 IF(MINT(51).EQ.1) THEN
9693 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9694 IF(MFAIL.EQ.1) THEN
9695 MSTI(61)=1
9696 RETURN
9697 ENDIF
9698 GOTO 100
9699 ENDIF
9700 VINT(63)=PQM3**2
9701 VINT(64)=PQM4**2
9702 ENDIF
9703 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
9704 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
9705 ENDIF
9706
9707C...Prepare for additional variable choices in 2 -> 3.
9708 IF(ISTSB.EQ.5) THEN
9709 VINT(201)=0D0
9710 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
9711 VINT(206)=VINT(201)
9712 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
9713 VINT(204)=PMAS(23,1)
9714 IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
9715 & VINT(204)=PMAS(24,1)
9716 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
9717 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
9718 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
9719 & VINT(204)=VINT(201)
9720 VINT(209)=VINT(204)
9721 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
9722 ENDIF
9723
9724C...Select incoming VDM particle (rho/omega/phi/J/psi).
9725 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
9726 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
9727 VRN=PYR(0)*SIGT(0,0,5)
9728 IF(MINT(101).LE.1) THEN
9729 I1MN=0
9730 I1MX=0
9731 ELSE
9732 I1MN=1
9733 I1MX=MINT(101)
9734 ENDIF
9735 IF(MINT(102).LE.1) THEN
9736 I2MN=0
9737 I2MX=0
9738 ELSE
9739 I2MN=1
9740 I2MX=MINT(102)
9741 ENDIF
9742 DO 180 I1=I1MN,I1MX
9743 KFV1=110*I1+3
9744 DO 170 I2=I2MN,I2MX
9745 KFV2=110*I2+3
9746 VRN=VRN-SIGT(I1,I2,5)
9747 IF(VRN.LE.0D0) GOTO 190
9748 170 CONTINUE
9749 180 CONTINUE
9750 190 IF(MINT(101).GE.2) MINT(103)=KFV1
9751 IF(MINT(102).GE.2) MINT(104)=KFV2
9752 ENDIF
9753
9754 IF(ISTSB.EQ.0) THEN
9755C...Elastic scattering or single or double diffractive scattering.
9756
9757C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9758 MINT(103)=MINT(11)
9759 MINT(104)=MINT(12)
9760 PMM(1)=VINT(3)
9761 PMM(2)=VINT(4)
9762 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
9763 JJ=ISUB-90
9764 VRN=PYR(0)*SIGT(0,0,JJ)
9765 IF(MINT(101).LE.1) THEN
9766 I1MN=0
9767 I1MX=0
9768 ELSE
9769 I1MN=1
9770 I1MX=MINT(101)
9771 ENDIF
9772 IF(MINT(102).LE.1) THEN
9773 I2MN=0
9774 I2MX=0
9775 ELSE
9776 I2MN=1
9777 I2MX=MINT(102)
9778 ENDIF
9779 DO 210 I1=I1MN,I1MX
9780 KFV1=110*I1+3
9781 DO 200 I2=I2MN,I2MX
9782 KFV2=110*I2+3
9783 VRN=VRN-SIGT(I1,I2,JJ)
9784 IF(VRN.LE.0D0) GOTO 220
9785 200 CONTINUE
9786 210 CONTINUE
9787 220 IF(MINT(101).GE.2) THEN
9788 MINT(103)=KFV1
9789 PMM(1)=PYMASS(KFV1)
9790 ENDIF
9791 IF(MINT(102).GE.2) THEN
9792 MINT(104)=KFV2
9793 PMM(2)=PYMASS(KFV2)
9794 ENDIF
9795 ENDIF
9796 VINT(67)=PMM(1)
9797 VINT(68)=PMM(2)
9798
9799C...Select mass for GVMD states (rejecting previous assignment).
9800 Q0S=4D0*PARP(15)**2
9801 Q1S=4D0*VINT(154)**2
9802 LOOP3=0
9803 230 LOOP3=LOOP3+1
9804 DO 240 JT=1,2
9805 IF(MINT(106+JT).EQ.3) THEN
9806 PS=VINT(2+JT)**2
9807 PMM(JT)=SQRT((Q0S+PS)*(Q1S+PS)/
9808 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS)
9809 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9810 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9811 ENDIF
9812 240 CONTINUE
9813 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9814 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9815 & GOTO 230
9816 GOTO 100
9817 ENDIF
9818
9819C...Side/sides of diffractive system.
9820 MINT(17)=0
9821 MINT(18)=0
9822 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9823 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9824
9825C...Find masses of particles and minimal masses of diffractive states.
9826 DO 250 JT=1,2
9827 PDIF(JT)=PMM(JT)
9828 VINT(68+JT)=PDIF(JT)
9829 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9830 250 CONTINUE
9831 SH=VINT(2)
9832 SQM1=PMM(1)**2
9833 SQM2=PMM(2)**2
9834 SQM3=PDIF(1)**2
9835 SQM4=PDIF(2)**2
9836 SMRES1=(PMM(1)+PMRC)**2
9837 SMRES2=(PMM(2)+PMRC)**2
9838
9839C...Find elastic slope and lower limit diffractive slope.
9840 IHA=MAX(2,IABS(MINT(103))/110)
9841 IF(IHA.GE.5) IHA=1
9842 IHB=MAX(2,IABS(MINT(104))/110)
9843 IF(IHB.GE.5) IHB=1
9844 IF(ISUB.EQ.91) THEN
9845 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9846 ELSEIF(ISUB.EQ.92) THEN
9847 BMN=MAX(2D0,2D0*BHAD(IHB))
9848 ELSEIF(ISUB.EQ.93) THEN
9849 BMN=MAX(2D0,2D0*BHAD(IHA))
9850 ELSEIF(ISUB.EQ.94) THEN
9851 BMN=2D0*ALP*4D0
9852 ENDIF
9853
9854C...Determine maximum possible t range and coefficient of generation.
9855 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9856 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9857 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9858 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9859 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9860 & (SQM1*SQM4-SQM2*SQM3)/SH
9861 THL=-0.5D0*(THA+THB)
9862 THU=THC/THL
9863 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9864
9865C...Select diffractive mass/masses according to dm^2/m^2.
9866 LOOP3=0
9867 260 LOOP3=LOOP3+1
9868 DO 270 JT=1,2
9869 IF(MINT(16+JT).EQ.0) THEN
9870 PDIF(2+JT)=PDIF(JT)
9871 ELSE
9872 PMMIN=PDIF(JT)
9873 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9874 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9875 ENDIF
9876 270 CONTINUE
9877 SQM3=PDIF(3)**2
9878 SQM4=PDIF(4)**2
9879
9880C..Additional mass factors, including resonance enhancement.
9881 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9882 IF(LOOP3.LT.100) GOTO 260
9883 GOTO 100
9884 ENDIF
9885 IF(ISUB.EQ.92) THEN
9886 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9887 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9888 ELSEIF(ISUB.EQ.93) THEN
9889 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9890 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9891 ELSEIF(ISUB.EQ.94) THEN
9892 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9893 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9894 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9895 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9896 ENDIF
9897
9898C...Select t according to exp(Bmn*t) and correct to right slope.
9899 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9900 IF(ISUB.GE.92) THEN
9901 IF(ISUB.EQ.92) THEN
9902 BADD=2D0*ALP*LOG(SH/SQM3)
9903 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9904 ELSEIF(ISUB.EQ.93) THEN
9905 BADD=2D0*ALP*LOG(SH/SQM4)
9906 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9907 ELSEIF(ISUB.EQ.94) THEN
9908 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9909 ENDIF
9910 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9911 ENDIF
9912
9913C...Check whether m^2 and t choices are consistent.
9914 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9915 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9916 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9917 IF(THB.LE.1D-8) GOTO 260
9918 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9919 & (SQM1*SQM4-SQM2*SQM3)/SH
9920 THLM=-0.5D0*(THA+THB)
9921 THUM=THC/THLM
9922 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9923
9924C...Information to output.
9925 VINT(21)=1D0
9926 VINT(22)=0D0
9927 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9928 VINT(45)=TH
9929 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9930 VINT(63)=PDIF(3)**2
9931 VINT(64)=PDIF(4)**2
9932 VINT(283)=PMM(1)**2/4D0
9933 VINT(284)=PMM(2)**2/4D0
9934
9935C...Note: in the following, by In is meant the integral over the
9936C...quantity multiplying coefficient cn.
9937C...Choose tau according to h1(tau)/tau, where
9938C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9939C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9940C...I1/I5*c5*1/(tau+tau_R') +
9941C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9942C...I1/I7*c7*tau/(1.-tau), and
9943C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9944 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9945 CALL PYKLIM(1)
9946 IF(MINT(51).NE.0) THEN
9947 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9948 IF(MFAIL.EQ.1) THEN
9949 MSTI(61)=1
9950 RETURN
9951 ENDIF
9952 GOTO 100
9953 ENDIF
9954 RTAU=PYR(0)
9955 MTAU=1
9956 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9957 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9958 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9959 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9960 & MTAU=5
9961 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9962 & COEF(ISUB,5)) MTAU=6
9963 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9964 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9965C...Additional check to handle techni-processes with extra resonance
9966C....Only modify tau treatment
9967 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
9968 & THEN
9969 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9970 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
9971 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9972 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
9973 & +COEFX(ISUB,1)) MTAU=9
9974 ENDIF
9975 CALL PYKMAP(1,MTAU,PYR(0))
9976
9977C...2 -> 3, 4 processes:
9978C...Choose tau' according to h4(tau,tau')/tau', where
9979C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9980C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9981 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9982 CALL PYKLIM(4)
9983 IF(MINT(51).NE.0) THEN
9984 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9985 IF(MFAIL.EQ.1) THEN
9986 MSTI(61)=1
9987 RETURN
9988 ENDIF
9989 GOTO 100
9990 ENDIF
9991 RTAUP=PYR(0)
9992 MTAUP=1
9993 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9994 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9995 CALL PYKMAP(4,MTAUP,PYR(0))
9996 ENDIF
9997
9998C...Choose y* according to h2(y*), where
9999C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
10000C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
10001C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
10002C...and c1 + c2 + c3 + c4 + c5 = 1.
10003 CALL PYKLIM(2)
10004 IF(MINT(51).NE.0) THEN
10005 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10006 IF(MFAIL.EQ.1) THEN
10007 MSTI(61)=1
10008 RETURN
10009 ENDIF
10010 GOTO 100
10011 ENDIF
10012 RYST=PYR(0)
10013 MYST=1
10014 IF(RYST.GT.COEF(ISUB,8)) MYST=2
10015 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10016 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
10017 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
10018 & COEF(ISUB,11)) MYST=5
10019 CALL PYKMAP(2,MYST,PYR(0))
10020
10021C...2 -> 2 processes:
10022C...Choose cos(theta-hat) (cth) according to h3(cth), where
10023C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
10024C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
10025C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
10026C...and c0 + c1 + c2 + c3 + c4 = 1.
10027 CALL PYKLIM(3)
10028 IF(MINT(51).NE.0) THEN
10029 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10030 IF(MFAIL.EQ.1) THEN
10031 MSTI(61)=1
10032 RETURN
10033 ENDIF
10034 GOTO 100
10035 ENDIF
10036 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
10037 RCTH=PYR(0)
10038 MCTH=1
10039 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
10040 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
10041 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
10042 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
10043 & COEF(ISUB,16)) MCTH=5
10044 CALL PYKMAP(3,MCTH,PYR(0))
10045 ENDIF
10046
10047C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
10048 IF(ISTSB.EQ.5) THEN
10049 CALL PYKMAP(5,0,0D0)
10050 IF(MINT(51).NE.0) THEN
10051 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10052 IF(MFAIL.EQ.1) THEN
10053 MSTI(61)=1
10054 RETURN
10055 ENDIF
10056 GOTO 100
10057 ENDIF
10058 ENDIF
10059
10060C...DIS as f + gamma* -> f process: set dummy values.
10061 ELSEIF(ISTSB.EQ.8) THEN
10062 VINT(21)=0.9D0
10063 VINT(22)=0D0
10064 VINT(23)=0D0
10065 VINT(47)=0D0
10066 VINT(48)=0D0
10067
10068C...Low-pT or multiple interactions (first semihard interaction).
10069 ELSEIF(ISTSB.EQ.9) THEN
10070 IF(MINT(35).LE.1) CALL PYMULT(3)
10071 IF(MINT(35).GE.2) CALL PYMIGN(3)
10072 ISUB=MINT(1)
10073
10074C...Study user-defined process: kinematics plus weight.
10075 ELSEIF(ISTSB.EQ.11) THEN
10076 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
10077 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
10078 MSTI(51)=0
10079 IF(NUP.LE.0) THEN
10080 MINT(51)=2
10081 MSTI(51)=1
10082 IF(MINT(82).EQ.1) THEN
10083 NGEN(0,1)=NGEN(0,1)-1
10084 NGEN(ISUB,1)=NGEN(ISUB,1)-1
10085 ENDIF
10086 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10087 RETURN
10088 ENDIF
10089
10090C...Extract cross section event weight.
10091 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
10092 SIGS=1D-9*XWGTUP
10093 ELSE
10094 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
10095 ENDIF
10096 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
10097 VINT(97)=SIGN(1D0,XWGTUP)
10098 ELSE
10099 VINT(97)=1D-9*XWGTUP
10100 ENDIF
10101
10102C...Construct 'trivial' kinematical variables needed.
10103 KFL1=IDUP(1)
10104 KFL2=IDUP(2)
10105 VINT(41)=PUP(4,1)/EBMUP(1)
10106 VINT(42)=PUP(4,2)/EBMUP(2)
10107 IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
10108 CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
10109 & '(listing follows):')
10110 CALL PYLIST(7)
10111 ENDIF
10112 VINT(21)=VINT(41)*VINT(42)
10113 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
10114 VINT(44)=VINT(21)*VINT(2)
10115 VINT(43)=SQRT(MAX(0D0,VINT(44)))
10116 VINT(55)=SCALUP
10117 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
10118 VINT(56)=VINT(55)**2
10119 VINT(57)=AQEDUP
10120 VINT(58)=AQCDUP
10121
10122C...Construct other kinematical variables needed (approximately).
10123 VINT(23)=0D0
10124 VINT(26)=VINT(21)
10125 VINT(45)=-0.5D0*VINT(44)
10126 VINT(46)=-0.5D0*VINT(44)
10127 VINT(49)=VINT(43)
10128 VINT(50)=VINT(44)
10129 VINT(51)=VINT(55)
10130 VINT(52)=VINT(56)
10131 VINT(53)=VINT(55)
10132 VINT(54)=VINT(56)
10133 VINT(25)=0D0
10134 VINT(48)=0D0
10135 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
10136 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
10137 DO 280 IUP=3,NUP
10138 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
10139 & '(PYRAND:) unacceptable ISTUP code for particles')
10140 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
10141 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
10142 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
10143 & PUP(2,IUP)**2)
10144 280 CONTINUE
10145 VINT(47)=SQRT(VINT(48))
10146 ENDIF
10147
10148C...Choose azimuthal angle.
10149 VINT(24)=0D0
10150 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
10151
10152C...Check against user cuts on kinematics at parton level.
10153 MINT(51)=0
10154 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
10155 IF(MINT(51).NE.0) THEN
10156 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10157 IF(MFAIL.EQ.1) THEN
10158 MSTI(61)=1
10159 RETURN
10160 ENDIF
10161 GOTO 100
10162 ENDIF
10163 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
10164 MCUT=0
10165 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
10166 & CALL PYKCUT(MCUT)
10167 IF(MCUT.NE.0) THEN
10168 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10169 IF(MFAIL.EQ.1) THEN
10170 MSTI(61)=1
10171 RETURN
10172 ENDIF
10173 GOTO 100
10174 ENDIF
10175 ENDIF
10176
10177 IF(ISTSB.LE.10) THEN
10178C... If internal process, call PYSIGH
10179 CALL PYSIGH(NCHN,SIGS)
10180 ELSE
10181C... If external process, still have to set MI starting scale
10182 IF (MSTP(86).EQ.1) THEN
10183C... Limit phase space by xT2 of hard interaction
10184C... (gives undercounting of MI when ext proc != dijets)
10185 XT2GMX = VINT(25)
10186 ELSE
10187C... All accessible phase space allowed
10188C... (gives double counting of MI when ext proc = dijets)
10189 XT2GMX = (1D0-VINT(41))*(1D0-VINT(42))
10190 ENDIF
10191 VINT(62)=0.25D0*XT2GMX*VINT(2)
10192 VINT(61)=SQRT(MAX(0D0,VINT(62)))
10193 ENDIF
10194
10195 SIGSOR=SIGS
10196 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
10197
10198C...Multiply cross section by lepton -> photon flux factor.
10199 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
10200 SIGS=WTGAGA*SIGS
10201 DO 290 ICHN=1,NCHN
10202 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
10203 290 CONTINUE
10204 SIGLPT=WTGAGA*SIGLPT
10205 ENDIF
10206
10207C...Multiply cross-section by user-defined weights.
10208 IF(MSTP(173).EQ.1) THEN
10209 SIGS=PARP(173)*SIGS
10210 DO 300 ICHN=1,NCHN
10211 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
10212 300 CONTINUE
10213 SIGLPT=PARP(173)*SIGLPT
10214 ENDIF
10215 WTXS=1D0
10216 SIGSWT=SIGS
10217 VINT(99)=1D0
10218 VINT(100)=1D0
10219 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
10220 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
10221 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
10222 SIGSWT=WTXS*SIGS
10223 VINT(99)=WTXS
10224 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
10225 ENDIF
10226
10227C...Calculations for Monte Carlo estimate of all cross-sections.
10228 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
10229 IF(MSTP(142).LE.1) THEN
10230 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10231 ELSE
10232 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
10233 ENDIF
10234 ELSEIF(MINT(82).EQ.1) THEN
10235 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10236 ENDIF
10237 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
10238 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
10239
10240C...Multiple interactions: store results of cross-section calculation.
10241 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
10242 VINT(153)=SIGSOR
10243 IF(MINT(35).LE.1) CALL PYMULT(4)
10244 IF(MINT(35).GE.2) CALL PYMIGN(4)
10245 ENDIF
10246
10247C...Ratio of actual to maximum cross section.
10248 IF(ISTSB.NE.11) THEN
10249 VIOL=SIGSWT/XSEC(ISUB,1)
10250 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
10251 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
10252 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
10253 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
10254 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
10255 ELSE
10256 VIOL=1D0
10257 ENDIF
10258
10259C...Check that weight not negative.
10260 IF(MSTP(123).LE.0) THEN
10261 IF(VIOL.LT.-1D-3) THEN
10262 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
10263 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10264 & VINT(22),VINT(23),VINT(26)
10265 CALL PYSTOP(2)
10266 ENDIF
10267 ELSE
10268 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
10269 VINT(109)=VIOL
10270 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
10271 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10272 & VINT(22),VINT(23),VINT(26)
10273 ENDIF
10274 ENDIF
10275
10276C...Weighting using estimate of maximum of differential cross-section.
10277 RATND=1D0
10278 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
10279 IF(VIOL.LT.PYR(0)) THEN
10280 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10281 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
10282 GOTO 100
10283 ENDIF
10284 ELSEIF(MFAIL.EQ.0) THEN
10285 RATND=SIGLPT/XSEC(95,1)
10286 VIOL=VIOL/RATND
10287 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
10288 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
10289 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
10290 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10291 ISUB=0
10292 GOTO 100
10293 ENDIF
10294 IF(VIOL.LT.PYR(0)) THEN
10295 GOTO 140
10296 ENDIF
10297 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
10298 IF(VIOL.LT.PYR(0)) THEN
10299 MSTI(61)=1
10300 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10301 RETURN
10302 ENDIF
10303 ELSE
10304 RATND=SIGLPT/XSEC(95,1)
10305 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
10306 MSTI(61)=1
10307 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10308 RETURN
10309 ENDIF
10310 VIOL=VIOL/RATND
10311 IF(VIOL.LT.PYR(0)) THEN
10312 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10313 GOTO 100
10314 ENDIF
10315 ENDIF
10316
10317C...Check for possible violation of estimated maximum of differential
10318C...cross-section used in weighting.
10319 IF(MSTP(123).LE.0) THEN
10320 IF(VIOL.GT.1D0) THEN
10321 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
10322 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10323 & VINT(22),VINT(23),VINT(26)
10324 CALL PYSTOP(2)
10325 ENDIF
10326 ELSEIF(MSTP(123).EQ.1) THEN
10327 IF(VIOL.GT.VINT(108)) THEN
10328 VINT(108)=VIOL
10329 IF(VIOL.GT.1.0001D0) THEN
10330 MINT(10)=1
10331 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10332 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10333 & VINT(22),VINT(23),VINT(26)
10334 ENDIF
10335 ENDIF
10336 ELSEIF(VIOL.GT.VINT(108)) THEN
10337 VINT(108)=VIOL
10338 IF(VIOL.GT.1D0) THEN
10339 MINT(10)=1
10340 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10341 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
10342 & THEN
10343 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
10344 IF(KFPR(ISUB,1).LE.9) THEN
10345 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
10346 & XMAXUP(KFPR(ISUB,1))
10347 ELSEIF(KFPR(ISUB,1).LE.99) THEN
10348 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
10349 & XMAXUP(KFPR(ISUB,1))
10350 ELSE
10351 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
10352 & XMAXUP(KFPR(ISUB,1))
10353 ENDIF
10354 ENDIF
10355 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
10356 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
10357 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
10358 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
10359 & XSEC(0,1)=XSEC(0,1)+XDIF
10360 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10361 & VINT(22),VINT(23),VINT(26)
10362 IF(ISUB.LE.9) THEN
10363 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
10364 ELSEIF(ISUB.LE.99) THEN
10365 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
10366 ELSE
10367 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
10368 ENDIF
10369 ENDIF
10370 VINT(108)=1D0
10371 ENDIF
10372 ENDIF
10373
10374C...Multiple interactions: choose impact parameter (if not already done).
10375 IF(MINT(39).EQ.0) VINT(148)=1D0
10376 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
10377 &MSTP(82).GE.3) THEN
10378 IF(MINT(35).LE.1) CALL PYMULT(5)
10379 IF(MINT(35).GE.2) CALL PYMIGN(5)
10380 IF(VINT(150).LT.PYR(0)) THEN
10381 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10382 IF(MFAIL.EQ.1) THEN
10383 MSTI(61)=1
10384 RETURN
10385 ENDIF
10386 GOTO 100
10387 ENDIF
10388 ENDIF
10389 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
10390 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
10391 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
10392 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
10393 ENDIF
10394 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
10395
10396C...Choose flavour of reacting partons (and subprocess).
10397 IF(ISTSB.GE.11) GOTO 320
10398 RSIGS=SIGS*PYR(0)
10399 QT2=VINT(48)
10400 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
10401 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
10402 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
10403 &PYR(0).GT.RQQBAR)) THEN
10404 DO 310 ICHN=1,NCHN
10405 KFL1=ISIG(ICHN,1)
10406 KFL2=ISIG(ICHN,2)
10407 MINT(2)=ISIG(ICHN,3)
10408 RSIGS=RSIGS-SIGH(ICHN)
10409 IF(RSIGS.LE.0D0) GOTO 320
10410 310 CONTINUE
10411
10412C...Multiple interactions: choose qqbar preferentially at small pT.
10413 ELSEIF(ISUB.EQ.96) THEN
10414 MINT(105)=MINT(103)
10415 MINT(109)=MINT(107)
10416 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
10417 MINT(105)=MINT(104)
10418 MINT(109)=MINT(108)
10419 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
10420 MINT(1)=11
10421 MINT(2)=1
10422 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
10423
10424C...Low-pT: choose string drawing configuration.
10425 ELSE
10426 KFL1=21
10427 KFL2=21
10428 RSIGS=6D0*PYR(0)
10429 MINT(2)=1
10430 IF(RSIGS.GT.1D0) MINT(2)=2
10431 IF(RSIGS.GT.2D0) MINT(2)=3
10432 ENDIF
10433
10434C...Reassign QCD process. Partons before initial state radiation.
10435 320 IF(MINT(2).GT.10) THEN
10436 MINT(1)=MINT(2)/10
10437 MINT(2)=MOD(MINT(2),10)
10438 ENDIF
10439 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
10440 &NGEN(MINT(1),2)+1
10441 MINT(15)=KFL1
10442 MINT(16)=KFL2
10443 MINT(13)=MINT(15)
10444 MINT(14)=MINT(16)
10445 VINT(141)=VINT(41)
10446 VINT(142)=VINT(42)
10447 VINT(151)=0D0
10448 VINT(152)=0D0
10449
10450C...Calculate x value of photon for parton inside photon inside e.
10451 DO 350 JT=1,2
10452 MINT(18+JT)=0
10453 VINT(154+JT)=0D0
10454 MSPLI=0
10455 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
10456 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
10457 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
10458 IF(MSPLI.EQ.2) THEN
10459 KFLH=MINT(14+JT)
10460 XHRD=VINT(140+JT)
10461 Q2HRD=VINT(54)
10462 MINT(105)=MINT(102+JT)
10463 MINT(109)=MINT(106+JT)
10464 VINT(120)=VINT(2+JT)
10465C.... ALICE
10466C.... Store side in MINT(124)
10467 MINT(124) = JT
10468C....
10469 IF(MSTP(57).LE.1) THEN
10470 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
10471 ELSE
10472 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
10473 ENDIF
10474 WTMX=4D0*XPQ(KFLH)
10475 IF(MSTP(13).EQ.2) THEN
10476 Q2PMS=Q2HRD/PMAS(11,1)**2
10477 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
10478 ENDIF
10479 330 XE=XHRD**PYR(0)
10480 XG=MIN(1D0-1D-10,XHRD/XE)
10481 IF(MSTP(57).LE.1) THEN
10482 CALL PYPDFU(22,XG,Q2HRD,XPQ)
10483 ELSE
10484 CALL PYPDFL(22,XG,Q2HRD,XPQ)
10485 ENDIF
10486 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
10487 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
10488 IF(WT.LT.PYR(0)*WTMX) GOTO 330
10489 MINT(18+JT)=1
10490 VINT(154+JT)=XE
10491 DO 340 KFLS=-25,25
10492 XSFX(JT,KFLS)=XPQ(KFLS)
10493 340 CONTINUE
10494 ENDIF
10495 350 CONTINUE
10496
10497C...Pick scale where photon is resolved.
10498 Q0S=PARP(15)**2
10499 Q1S=VINT(154)**2
10500 VINT(283)=0D0
10501 IF(MINT(107).EQ.3) THEN
10502 IF(MSTP(66).EQ.1) THEN
10503 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
10504 ELSEIF(MSTP(66).EQ.2) THEN
10505 PS=VINT(3)**2
10506 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10507 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10508 Q2INT=SQRT(Q0S*Q2EFF)
10509 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10510 ELSEIF(MSTP(66).EQ.3) THEN
10511 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
10512 ELSEIF(MSTP(66).GE.4) THEN
10513 PS=0.25D0*VINT(3)**2
10514 VINT(283)=(Q0S+PS)*(Q1S+PS)/
10515 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10516 ENDIF
10517 ENDIF
10518 VINT(284)=0D0
10519 IF(MINT(108).EQ.3) THEN
10520 IF(MSTP(66).EQ.1) THEN
10521 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
10522 ELSEIF(MSTP(66).EQ.2) THEN
10523 PS=VINT(4)**2
10524 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10525 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10526 Q2INT=SQRT(Q0S*Q2EFF)
10527 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10528 ELSEIF(MSTP(66).EQ.3) THEN
10529 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
10530 ELSEIF(MSTP(66).GE.4) THEN
10531 PS=0.25D0*VINT(4)**2
10532 VINT(284)=(Q0S+PS)*(Q1S+PS)/
10533 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10534 ENDIF
10535 ENDIF
10536 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10537
10538C...Format statements for differential cross-section maximum violations.
10539 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
10540 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10541 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
10542 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
10543 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
10544 &'in event',1X,I7)
10545 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
10546 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10547 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
10548 &'in event',1X,I7)
10549 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
10550 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
10551 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
10552 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
10553 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
10554 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
10555
10556 RETURN
10557 END
10558
10559C*********************************************************************
10560
10561C...PYSCAT
10562C...Finds outgoing flavours and event type; sets up the kinematics
10563C...and colour flow of the hard scattering
10564
10565 SUBROUTINE PYSCAT
10566
10567C...Double precision and integer declarations
10568 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10569 IMPLICIT INTEGER(I-N)
10570 INTEGER PYK,PYCHGE,PYCOMP
10571C...Parameter statement to help give large particle numbers.
10572 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
10573 &KEXCIT=4000000,KDIMEN=5000000)
10574C...Parameter statement for maximum size of showers.
10575 PARAMETER (MAXNUR=1000)
10576
10577C...User process event common block.
10578 INTEGER MAXNUP
10579 PARAMETER (MAXNUP=500)
10580 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10581 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10582 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
10583 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
10584 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
10585 SAVE /HEPEUP/
10586
10587C...Commonblocks.
10588 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
10589 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10590 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10591 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10592 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
10593 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10594 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10595 COMMON/PYINT1/MINT(400),VINT(400)
10596 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10597 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10598 COMMON/PYINT4/MWID(500),WIDS(500,5)
10599 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10600 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
10601 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
10602 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
10603 COMMON/PYPUED/IUED(0:99),RUED(0:99)
10604 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
10605 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
10606 &/PYTCSM/,/PYPUED/
10607C...Local arrays and saved variables
10608 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
10609 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
10610 INTEGER IOKFLA(6),IIFLAV
10611C...UED related declarations:
10612C...equivalences between ordered particles (451->475)
10613C...and UED particle code (5 000 000 + id)
10614 DIMENSION IUEDEQ(475),MUED(2)
10615 DATA (IUEDEQ(I),I=451,475)/
10616 & 6100001,6100002,6100003,6100004,6100005,6100006,
10617 & 5100001,5100002,5100003,5100004,5100005,5100006,
10618 & 6100011,6100013,6100015,
10619 & 5100012,5100011,5100014,5100013,5100016,5100015,
10620 & 5100021,5100022,5100023,5100024/
10621 SAVE VINTSV
10622
10623C...Read out process
10624 ISUB=MINT(1)
10625 ISUBSV=ISUB
10626
10627C...Restore information for low-pT processes
10628 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
10629 DO 100 J=41,66
10630 100 VINT(J)=VINTSV(J)
10631 ENDIF
10632
10633C...Convert H' or A process into equivalent H one
10634 IHIGG=1
10635 KFHIGG=25
10636 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
10637 &ISUB.LE.190)) THEN
10638 IHIGG=2
10639 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
10640 KFHIGG=33+IHIGG
10641 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
10642 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
10643 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
10644 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
10645 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
10646 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
10647 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
10648 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
10649 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
10650 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
10651 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
10652 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
10653 ENDIF
10654
10655 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
10656
10657C...Convert bottomonium process into equivalent charmonium ones.
10658 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
10659
10660C...Choice of subprocess, number of documentation lines
10661 IDOC=6+ISET(ISUB)
10662 IF(ISUB.EQ.95) IDOC=8
10663 IF(ISET(ISUB).EQ.5) IDOC=9
10664 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
10665 MINT(3)=IDOC-6
10666 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
10667 MINT(4)=IDOC
10668 IPU1=MINT(84)+1
10669 IPU2=MINT(84)+2
10670 IPU3=MINT(84)+3
10671 IPU4=MINT(84)+4
10672 IPU5=MINT(84)+5
10673 IPU6=MINT(84)+6
10674
10675C...Reset K, P and V vectors. Store incoming particles
10676 DO 120 JT=1,MSTP(126)+100
10677 I=MINT(83)+JT
10678 IF(I.GT.MSTU(4)) GOTO 120
10679 DO 110 J=1,5
10680 K(I,J)=0
10681 P(I,J)=0D0
10682 V(I,J)=0D0
10683 110 CONTINUE
10684 120 CONTINUE
10685 DO 140 JT=1,2
10686 I=MINT(83)+JT
10687 K(I,1)=21
10688 K(I,2)=MINT(10+JT)
10689 DO 130 J=1,5
10690 P(I,J)=VINT(285+5*JT+J)
10691 130 CONTINUE
10692 140 CONTINUE
10693 MINT(6)=2
10694 KFRES=0
10695
10696C...Store incoming partons in their CM-frame. Save pdf value.
10697 SH=VINT(44)
10698 SHR=SQRT(SH)
10699 SHP=VINT(26)*VINT(2)
10700 SHPR=SQRT(SHP)
10701 SHUSER=SHR
10702 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
10703 DO 150 JT=1,2
10704 I=MINT(84)+JT
10705 K(I,1)=14
10706 K(I,2)=MINT(14+JT)
10707 K(I,3)=MINT(83)+2+JT
10708 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
10709 P(I,4)=0.5D0*SHUSER
10710 IF(MINT(14+JT).GE.-40.AND.MINT(14+JT).LE.40) THEN
10711 VINT(38+JT)=XSFX(JT,MINT(14+JT))
10712 ELSE
10713 VINT(38+JT)=1D0
10714 ENDIF
10715 150 CONTINUE
10716
10717C...Copy incoming partons to documentation lines
10718 DO 170 JT=1,2
10719 I1=MINT(83)+4+JT
10720 I2=MINT(84)+JT
10721 K(I1,1)=21
10722 K(I1,2)=K(I2,2)
10723 K(I1,3)=I1-2
10724 DO 160 J=1,5
10725 P(I1,J)=P(I2,J)
10726 160 CONTINUE
10727 170 CONTINUE
10728
10729C...Choose new quark/lepton flavour for relevant annihilation graphs
10730 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
10731 &ISUB.EQ.314.OR.ISUB.EQ.319.OR.ISUB.EQ.316.OR.
10732 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
10733 IGLGA=21
10734 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
10735 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
10736 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
10737 DO 190 I=1,MDCY(IGLGA,3)
10738 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
10739 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
10740 IF(RKFL.LE.0D0) GOTO 200
10741 190 CONTINUE
10742 200 CONTINUE
10743 IF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319
10744 & .OR.ISUB.EQ.316).AND.MINT(2).LE.2) THEN
10745 IF(KFLF.GE.4) GOTO 180
10746 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10747 & OR.ISUB.EQ.316).AND.MINT(2).LE.4) THEN
10748 KFLF=4
10749 MINT(2)=MINT(2)-2
10750 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10751 & OR.ISUB.EQ.316) THEN
10752 KFLF=5
10753 MINT(2)=MINT(2)-4
10754 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
10755 & .AND.IABS(KFLF).GE.3) THEN
10756 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
10757 & VINT(44)**2
10758 FACCIB=VINT(46)**2/RTCM(41)**4
10759 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
10760 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
10761 KFLF=5
10762 MINT(2)=1
10763 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
10764 IF(KFLF.EQ.5) GOTO 180
10765 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10766 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
10767 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
10768 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
10769 ENDIF
10770 ENDIF
10771
10772C...Final state flavours and colour flow: default values
10773 JS=1
10774 MINT(21)=MINT(15)
10775 MINT(22)=MINT(16)
10776 MINT(23)=0
10777 MINT(24)=0
10778 KCC=20
10779 KCS=ISIGN(1,MINT(15))
10780
10781 IF(ISET(ISUB).EQ.11) THEN
10782C...User-defined processes: find products
10783 MINT(3)=0
10784 DO 210 IUP=3,NUP
10785 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
10786 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
10787 MINT(21+IUP)=IDUP(IUP)
10788 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
10789 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
10790 ELSEIF(IDUP(IUP).EQ.0) THEN
10791 ELSE
10792 MINT(3)=MINT(3)+1
10793 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
10794 ENDIF
10795 210 CONTINUE
10796
10797 ELSEIF(ISUB.LE.10) THEN
10798 IF(ISUB.EQ.1) THEN
10799C...f + fbar -> gamma*/Z0
10800 KFRES=23
10801
10802 ELSEIF(ISUB.EQ.2) THEN
10803C...f + fbar' -> W+/-
10804 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10805 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10806 KFRES=ISIGN(24,KCH1+KCH2)
10807
10808 ELSEIF(ISUB.EQ.3) THEN
10809C...f + fbar -> h0 (or H0, or A0)
10810 KFRES=KFHIGG
10811
10812 ELSEIF(ISUB.EQ.4) THEN
10813C...gamma + W+/- -> W+/-
10814
10815 ELSEIF(ISUB.EQ.5) THEN
10816C...Z0 + Z0 -> h0
10817 XH=SH/SHP
10818 MINT(21)=MINT(15)
10819 MINT(22)=MINT(16)
10820 PMQ(1)=PYMASS(MINT(21))
10821 PMQ(2)=PYMASS(MINT(22))
10822 220 JT=INT(1.5D0+PYR(0))
10823 ZMIN=2D0*PMQ(JT)/SHPR
10824 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10825 & (SHPR*(SHPR-PMQ(3-JT)))
10826 ZMAX=MIN(1D0-XH,ZMAX)
10827 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10828 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10829 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
10830 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10831 IF(SQC1.LT.1D-8) GOTO 220
10832 C1=SQRT(SQC1)
10833 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10834 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10835 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10836 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10837 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10838 IF(SQC1.LT.1D-8) GOTO 220
10839 C1=SQRT(SQC1)
10840 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10841 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10842 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10843 PHIR=PARU(2)*PYR(0)
10844 CPHI=COS(PHIR)
10845 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10846 & SQRT(1D0-CTHE(2)**2)*CPHI
10847 Z1=2D0-Z(JT)
10848 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10849 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10850 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10851 & PMQ(3-JT)**2/SHP))
10852 ZMIN=2D0*PMQ(3-JT)/SHPR
10853 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10854 ZMAX=MIN(1D0-XH,ZMAX)
10855 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10856 KCC=22
10857 KFRES=25
10858
10859 ELSEIF(ISUB.EQ.6) THEN
10860C...Z0 + W+/- -> W+/-
10861
10862 ELSEIF(ISUB.EQ.7) THEN
10863C...W+ + W- -> Z0
10864
10865 ELSEIF(ISUB.EQ.8) THEN
10866C...W+ + W- -> h0
10867 XH=SH/SHP
10868 230 DO 260 JT=1,2
10869 I=MINT(14+JT)
10870 IA=IABS(I)
10871 IF(IA.LE.10) THEN
10872 RVCKM=VINT(180+I)*PYR(0)
10873 DO 240 J=1,MSTP(1)
10874 IB=2*J-1+MOD(IA,2)
10875 IPM=(5-ISIGN(1,I))/2
10876 IDC=J+MDCY(IA,2)+2
10877 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10878 MINT(20+JT)=ISIGN(IB,I)
10879 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10880 IF(RVCKM.LE.0D0) GOTO 250
10881 240 CONTINUE
10882 ELSE
10883 IB=2*((IA+1)/2)-1+MOD(IA,2)
10884 MINT(20+JT)=ISIGN(IB,I)
10885 ENDIF
10886 250 PMQ(JT)=PYMASS(MINT(20+JT))
10887 260 CONTINUE
10888 JT=INT(1.5D0+PYR(0))
10889 ZMIN=2D0*PMQ(JT)/SHPR
10890 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10891 & (SHPR*(SHPR-PMQ(3-JT)))
10892 ZMAX=MIN(1D0-XH,ZMAX)
10893 IF(ZMIN.GE.ZMAX) GOTO 230
10894 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10895 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10896 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10897 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10898 IF(SQC1.LT.1D-8) GOTO 230
10899 C1=SQRT(SQC1)
10900 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10901 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10902 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10903 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10904 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10905 IF(SQC1.LT.1D-8) GOTO 230
10906 C1=SQRT(SQC1)
10907 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10908 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10909 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10910 PHIR=PARU(2)*PYR(0)
10911 CPHI=COS(PHIR)
10912 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10913 & SQRT(1D0-CTHE(2)**2)*CPHI
10914 Z1=2D0-Z(JT)
10915 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10916 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10917 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10918 & PMQ(3-JT)**2/SHP))
10919 ZMIN=2D0*PMQ(3-JT)/SHPR
10920 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10921 ZMAX=MIN(1D0-XH,ZMAX)
10922 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10923 KCC=22
10924 KFRES=25
10925
10926 ELSEIF(ISUB.EQ.10) THEN
10927C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10928 IF(MINT(2).EQ.1) THEN
10929 KCC=22
10930 ELSE
10931C...W exchange: need to mix flavours according to CKM matrix
10932 DO 280 JT=1,2
10933 I=MINT(14+JT)
10934 IA=IABS(I)
10935 IF(IA.LE.10) THEN
10936 RVCKM=VINT(180+I)*PYR(0)
10937 DO 270 J=1,MSTP(1)
10938 IB=2*J-1+MOD(IA,2)
10939 IPM=(5-ISIGN(1,I))/2
10940 IDC=J+MDCY(IA,2)+2
10941 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10942 MINT(20+JT)=ISIGN(IB,I)
10943 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10944 IF(RVCKM.LE.0D0) GOTO 280
10945 270 CONTINUE
10946 ELSE
10947 IB=2*((IA+1)/2)-1+MOD(IA,2)
10948 MINT(20+JT)=ISIGN(IB,I)
10949 ENDIF
10950 280 CONTINUE
10951 KCC=22
10952 ENDIF
10953 ENDIF
10954
10955 ELSEIF(ISUB.LE.20) THEN
10956 IF(ISUB.EQ.11) THEN
10957C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10958 KCC=MINT(2)
10959 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10960
10961 ELSEIF(ISUB.EQ.12) THEN
10962C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10963 MINT(21)=ISIGN(KFLF,MINT(15))
10964 MINT(22)=-MINT(21)
10965 KCC=4
10966
10967 ELSEIF(ISUB.EQ.13) THEN
10968C...f + fbar -> g + g; th arbitrary
10969 MINT(21)=21
10970 MINT(22)=21
10971 KCC=MINT(2)+4
10972
10973 ELSEIF(ISUB.EQ.14) THEN
10974C...f + fbar -> g + gamma; th arbitrary
10975 IF(PYR(0).GT.0.5D0) JS=2
10976 MINT(20+JS)=21
10977 MINT(23-JS)=22
10978 KCC=17+JS
10979
10980 ELSEIF(ISUB.EQ.15) THEN
10981C...f + fbar -> g + Z0; th arbitrary
10982 IF(PYR(0).GT.0.5D0) JS=2
10983 MINT(20+JS)=21
10984 MINT(23-JS)=23
10985 KCC=17+JS
10986
10987 ELSEIF(ISUB.EQ.16) THEN
10988C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10989 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10990 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10991 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10992 MINT(20+JS)=21
10993 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10994 KCC=17+JS
10995
10996 ELSEIF(ISUB.EQ.17) THEN
10997C...f + fbar -> g + h0; th arbitrary
10998 IF(PYR(0).GT.0.5D0) JS=2
10999 MINT(20+JS)=21
11000 MINT(23-JS)=25
11001 KCC=17+JS
11002
11003 ELSEIF(ISUB.EQ.18) THEN
11004C...f + fbar -> gamma + gamma; th arbitrary
11005 MINT(21)=22
11006 MINT(22)=22
11007
11008 ELSEIF(ISUB.EQ.19) THEN
11009C...f + fbar -> gamma + Z0; th arbitrary
11010 IF(PYR(0).GT.0.5D0) JS=2
11011 MINT(20+JS)=22
11012 MINT(23-JS)=23
11013
11014 ELSEIF(ISUB.EQ.20) THEN
11015C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
11016C...(p(fbar')-p(W+))**2
11017 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11018 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11019 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
11020 MINT(20+JS)=22
11021 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
11022 ENDIF
11023
11024 ELSEIF(ISUB.LE.30) THEN
11025 IF(ISUB.EQ.21) THEN
11026C...f + fbar -> gamma + h0; th arbitrary
11027 IF(PYR(0).GT.0.5D0) JS=2
11028 MINT(20+JS)=22
11029 MINT(23-JS)=25
11030
11031 ELSEIF(ISUB.EQ.22) THEN
11032C...f + fbar -> Z0 + Z0; th arbitrary
11033 MINT(21)=23
11034 MINT(22)=23
11035
11036 ELSEIF(ISUB.EQ.23) THEN
11037C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
11038 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11039 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11040 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
11041 MINT(20+JS)=23
11042 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
11043
11044 ELSEIF(ISUB.EQ.24) THEN
11045C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
11046 IF(PYR(0).GT.0.5D0) JS=2
11047 MINT(20+JS)=23
11048 MINT(23-JS)=KFHIGG
11049
11050 ELSEIF(ISUB.EQ.25) THEN
11051C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
11052 MINT(21)=-ISIGN(24,MINT(15))
11053 MINT(22)=-MINT(21)
11054
11055 ELSEIF(ISUB.EQ.26) THEN
11056C...f + fbar' -> W+/- + h0 (or H0, or A0);
11057C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
11058 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11059 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11060 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11061 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
11062 MINT(23-JS)=KFHIGG
11063
11064 ELSEIF(ISUB.EQ.27) THEN
11065C...f + fbar -> h0 + h0
11066
11067 ELSEIF(ISUB.EQ.28) THEN
11068C...f + g -> f + g; th = (p(f)-p(f))**2
11069 IF(MINT(15).EQ.21) JS=2
11070 KCC=MINT(2)+6
11071 IF(MINT(15).EQ.21) KCC=KCC+2
11072 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
11073 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
11074
11075 ELSEIF(ISUB.EQ.29) THEN
11076C...f + g -> f + gamma; th = (p(f)-p(f))**2
11077 IF(MINT(15).EQ.21) JS=2
11078 MINT(23-JS)=22
11079 KCC=15+JS
11080 KCS=ISIGN(1,MINT(14+JS))
11081
11082 ELSEIF(ISUB.EQ.30) THEN
11083C...f + g -> f + Z0; th = (p(f)-p(f))**2
11084 IF(MINT(15).EQ.21) JS=2
11085 MINT(23-JS)=23
11086 KCC=15+JS
11087 KCS=ISIGN(1,MINT(14+JS))
11088 ENDIF
11089
11090 ELSEIF(ISUB.LE.40) THEN
11091 IF(ISUB.EQ.31) THEN
11092C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
11093 IF(MINT(15).EQ.21) JS=2
11094 I=MINT(14+JS)
11095 IA=IABS(I)
11096 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11097 RVCKM=VINT(180+I)*PYR(0)
11098 DO 290 J=1,MSTP(1)
11099 IB=2*J-1+MOD(IA,2)
11100 IPM=(5-ISIGN(1,I))/2
11101 IDC=J+MDCY(IA,2)+2
11102 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
11103 MINT(20+JS)=ISIGN(IB,I)
11104 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11105 IF(RVCKM.LE.0D0) GOTO 300
11106 290 CONTINUE
11107 300 KCC=15+JS
11108 KCS=ISIGN(1,MINT(14+JS))
11109
11110 ELSEIF(ISUB.EQ.32) THEN
11111C...f + g -> f + h0; th = (p(f)-p(f))**2
11112 IF(MINT(15).EQ.21) JS=2
11113 MINT(23-JS)=25
11114 KCC=15+JS
11115 KCS=ISIGN(1,MINT(14+JS))
11116
11117 ELSEIF(ISUB.EQ.33) THEN
11118C...f + gamma -> f + g; th=(p(f)-p(f))**2
11119 IF(MINT(15).EQ.22) JS=2
11120 MINT(23-JS)=21
11121 KCC=24+JS
11122 KCS=ISIGN(1,MINT(14+JS))
11123
11124 ELSEIF(ISUB.EQ.34) THEN
11125C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
11126 IF(MINT(15).EQ.22) JS=2
11127 KCC=22
11128 KCS=ISIGN(1,MINT(14+JS))
11129
11130 ELSEIF(ISUB.EQ.35) THEN
11131C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
11132 IF(MINT(15).EQ.22) JS=2
11133 MINT(23-JS)=23
11134 KCC=22
11135
11136 ELSEIF(ISUB.EQ.36) THEN
11137C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
11138 IF(MINT(15).EQ.22) JS=2
11139 I=MINT(14+JS)
11140 IA=IABS(I)
11141 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11142 IF(IA.LE.10) THEN
11143 RVCKM=VINT(180+I)*PYR(0)
11144 DO 310 J=1,MSTP(1)
11145 IB=2*J-1+MOD(IA,2)
11146 IPM=(5-ISIGN(1,I))/2
11147 IDC=J+MDCY(IA,2)+2
11148 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
11149 MINT(20+JS)=ISIGN(IB,I)
11150 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11151 IF(RVCKM.LE.0D0) GOTO 320
11152 310 CONTINUE
11153 ELSE
11154 IB=2*((IA+1)/2)-1+MOD(IA,2)
11155 MINT(20+JS)=ISIGN(IB,I)
11156 ENDIF
11157 320 KCC=22
11158
11159 ELSEIF(ISUB.EQ.37) THEN
11160C...f + gamma -> f + h0
11161
11162 ELSEIF(ISUB.EQ.38) THEN
11163C...f + Z0 -> f + g
11164
11165 ELSEIF(ISUB.EQ.39) THEN
11166C...f + Z0 -> f + gamma
11167
11168 ELSEIF(ISUB.EQ.40) THEN
11169C...f + Z0 -> f + Z0
11170 ENDIF
11171
11172 ELSEIF(ISUB.LE.50) THEN
11173 IF(ISUB.EQ.41) THEN
11174C...f + Z0 -> f' + W+/-
11175
11176 ELSEIF(ISUB.EQ.42) THEN
11177C...f + Z0 -> f + h0
11178
11179 ELSEIF(ISUB.EQ.43) THEN
11180C...f + W+/- -> f' + g
11181
11182 ELSEIF(ISUB.EQ.44) THEN
11183C...f + W+/- -> f' + gamma
11184
11185 ELSEIF(ISUB.EQ.45) THEN
11186C...f + W+/- -> f' + Z0
11187
11188 ELSEIF(ISUB.EQ.46) THEN
11189C...f + W+/- -> f' + W+/-
11190
11191 ELSEIF(ISUB.EQ.47) THEN
11192C...f + W+/- -> f' + h0
11193
11194 ELSEIF(ISUB.EQ.48) THEN
11195C...f + h0 -> f + g
11196
11197 ELSEIF(ISUB.EQ.49) THEN
11198C...f + h0 -> f + gamma
11199
11200 ELSEIF(ISUB.EQ.50) THEN
11201C...f + h0 -> f + Z0
11202 ENDIF
11203
11204 ELSEIF(ISUB.LE.60) THEN
11205 IF(ISUB.EQ.51) THEN
11206C...f + h0 -> f' + W+/-
11207
11208 ELSEIF(ISUB.EQ.52) THEN
11209C...f + h0 -> f + h0
11210
11211 ELSEIF(ISUB.EQ.53) THEN
11212C...g + g -> f + fbar; th arbitrary
11213 KCS=(-1)**INT(1.5D0+PYR(0))
11214 MINT(21)=ISIGN(KFLF,KCS)
11215 MINT(22)=-MINT(21)
11216 KCC=MINT(2)+10
11217
11218 ELSEIF(ISUB.EQ.54) THEN
11219C...g + gamma -> f + fbar; th arbitrary
11220 KCS=(-1)**INT(1.5D0+PYR(0))
11221 MINT(21)=ISIGN(KFLF,KCS)
11222 MINT(22)=-MINT(21)
11223 KCC=27
11224 IF(MINT(16).EQ.21) KCC=28
11225
11226 ELSEIF(ISUB.EQ.55) THEN
11227C...g + Z0 -> f + fbar
11228
11229 ELSEIF(ISUB.EQ.56) THEN
11230C...g + W+/- -> f + fbar'
11231
11232 ELSEIF(ISUB.EQ.57) THEN
11233C...g + h0 -> f + fbar
11234
11235 ELSEIF(ISUB.EQ.58) THEN
11236C...gamma + gamma -> f + fbar; th arbitrary
11237 KCS=(-1)**INT(1.5D0+PYR(0))
11238 MINT(21)=ISIGN(KFLF,KCS)
11239 MINT(22)=-MINT(21)
11240 KCC=21
11241
11242 ELSEIF(ISUB.EQ.59) THEN
11243C...gamma + Z0 -> f + fbar
11244
11245 ELSEIF(ISUB.EQ.60) THEN
11246C...gamma + W+/- -> f + fbar'
11247 ENDIF
11248
11249 ELSEIF(ISUB.LE.70) THEN
11250 IF(ISUB.EQ.61) THEN
11251C...gamma + h0 -> f + fbar
11252
11253 ELSEIF(ISUB.EQ.62) THEN
11254C...Z0 + Z0 -> f + fbar
11255
11256 ELSEIF(ISUB.EQ.63) THEN
11257C...Z0 + W+/- -> f + fbar'
11258
11259 ELSEIF(ISUB.EQ.64) THEN
11260C...Z0 + h0 -> f + fbar
11261
11262 ELSEIF(ISUB.EQ.65) THEN
11263C...W+ + W- -> f + fbar
11264
11265 ELSEIF(ISUB.EQ.66) THEN
11266C...W+/- + h0 -> f + fbar'
11267
11268 ELSEIF(ISUB.EQ.67) THEN
11269C...h0 + h0 -> f + fbar
11270
11271 ELSEIF(ISUB.EQ.68) THEN
11272C...g + g -> g + g; th arbitrary
11273 KCC=MINT(2)+12
11274 KCS=(-1)**INT(1.5D0+PYR(0))
11275
11276 ELSEIF(ISUB.EQ.69) THEN
11277C...gamma + gamma -> W+ + W-; th arbitrary
11278 MINT(21)=24
11279 MINT(22)=-24
11280 KCC=21
11281
11282 ELSEIF(ISUB.EQ.70) THEN
11283C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
11284 IF(MINT(15).EQ.22) MINT(21)=23
11285 IF(MINT(16).EQ.22) MINT(22)=23
11286 KCC=21
11287 ENDIF
11288
11289 ELSEIF(ISUB.LE.80) THEN
11290 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
11291C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
11292 XH=SH/SHP
11293 MINT(21)=MINT(15)
11294 MINT(22)=MINT(16)
11295 PMQ(1)=PYMASS(MINT(21))
11296 PMQ(2)=PYMASS(MINT(22))
11297 330 JT=INT(1.5D0+PYR(0))
11298 ZMIN=2D0*PMQ(JT)/SHPR
11299 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11300 & (SHPR*(SHPR-PMQ(3-JT)))
11301 ZMAX=MIN(1D0-XH,ZMAX)
11302 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11303 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11304 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
11305 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11306 IF(SQC1.LT.1D-8) GOTO 330
11307 C1=SQRT(SQC1)
11308 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11309 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11310 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11311 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11312 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11313 IF(SQC1.LT.1D-8) GOTO 330
11314 C1=SQRT(SQC1)
11315 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11316 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11317 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11318 PHIR=PARU(2)*PYR(0)
11319 CPHI=COS(PHIR)
11320 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11321 & SQRT(1D0-CTHE(2)**2)*CPHI
11322 Z1=2D0-Z(JT)
11323 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11324 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11325 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11326 & PMQ(3-JT)**2/SHP))
11327 ZMIN=2D0*PMQ(3-JT)/SHPR
11328 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11329 ZMAX=MIN(1D0-XH,ZMAX)
11330 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
11331 KCC=22
11332
11333 ELSEIF(ISUB.EQ.73) THEN
11334C...Z0 + W+/- -> Z0 + W+/-
11335 JS=MINT(2)
11336 XH=SH/SHP
11337 340 JT=3-MINT(2)
11338 I=MINT(14+JT)
11339 IA=IABS(I)
11340 IF(IA.LE.10) THEN
11341 RVCKM=VINT(180+I)*PYR(0)
11342 DO 350 J=1,MSTP(1)
11343 IB=2*J-1+MOD(IA,2)
11344 IPM=(5-ISIGN(1,I))/2
11345 IDC=J+MDCY(IA,2)+2
11346 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
11347 MINT(20+JT)=ISIGN(IB,I)
11348 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11349 IF(RVCKM.LE.0D0) GOTO 360
11350 350 CONTINUE
11351 ELSE
11352 IB=2*((IA+1)/2)-1+MOD(IA,2)
11353 MINT(20+JT)=ISIGN(IB,I)
11354 ENDIF
11355 360 PMQ(JT)=PYMASS(MINT(20+JT))
11356 MINT(23-JT)=MINT(17-JT)
11357 PMQ(3-JT)=PYMASS(MINT(23-JT))
11358 JT=INT(1.5D0+PYR(0))
11359 ZMIN=2D0*PMQ(JT)/SHPR
11360 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11361 & (SHPR*(SHPR-PMQ(3-JT)))
11362 ZMAX=MIN(1D0-XH,ZMAX)
11363 IF(ZMIN.GE.ZMAX) GOTO 340
11364 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11365 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11366 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
11367 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11368 IF(SQC1.LT.1D-8) GOTO 340
11369 C1=SQRT(SQC1)
11370 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11371 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11372 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11373 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11374 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11375 IF(SQC1.LT.1D-8) GOTO 340
11376 C1=SQRT(SQC1)
11377 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11378 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11379 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11380 PHIR=PARU(2)*PYR(0)
11381 CPHI=COS(PHIR)
11382 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11383 & SQRT(1D0-CTHE(2)**2)*CPHI
11384 Z1=2D0-Z(JT)
11385 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11386 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11387 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11388 & PMQ(3-JT)**2/SHP))
11389 ZMIN=2D0*PMQ(3-JT)/SHPR
11390 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11391 ZMAX=MIN(1D0-XH,ZMAX)
11392 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
11393 KCC=22
11394
11395 ELSEIF(ISUB.EQ.74) THEN
11396C...Z0 + h0 -> Z0 + h0
11397
11398 ELSEIF(ISUB.EQ.75) THEN
11399C...W+ + W- -> gamma + gamma
11400
11401 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
11402C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
11403 XH=SH/SHP
11404 370 DO 400 JT=1,2
11405 I=MINT(14+JT)
11406 IA=IABS(I)
11407 IF(IA.LE.10) THEN
11408 RVCKM=VINT(180+I)*PYR(0)
11409 DO 380 J=1,MSTP(1)
11410 IB=2*J-1+MOD(IA,2)
11411 IPM=(5-ISIGN(1,I))/2
11412 IDC=J+MDCY(IA,2)+2
11413 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
11414 MINT(20+JT)=ISIGN(IB,I)
11415 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11416 IF(RVCKM.LE.0D0) GOTO 390
11417 380 CONTINUE
11418 ELSE
11419 IB=2*((IA+1)/2)-1+MOD(IA,2)
11420 MINT(20+JT)=ISIGN(IB,I)
11421 ENDIF
11422 390 PMQ(JT)=PYMASS(MINT(20+JT))
11423 400 CONTINUE
11424 JT=INT(1.5D0+PYR(0))
11425 ZMIN=2D0*PMQ(JT)/SHPR
11426 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11427 & (SHPR*(SHPR-PMQ(3-JT)))
11428 ZMAX=MIN(1D0-XH,ZMAX)
11429 IF(ZMIN.GE.ZMAX) GOTO 370
11430 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11431 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11432 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
11433 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11434 IF(SQC1.LT.1D-8) GOTO 370
11435 C1=SQRT(SQC1)
11436 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11437 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11438 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11439 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11440 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11441 IF(SQC1.LT.1D-8) GOTO 370
11442 C1=SQRT(SQC1)
11443 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11444 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11445 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11446 PHIR=PARU(2)*PYR(0)
11447 CPHI=COS(PHIR)
11448 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11449 & SQRT(1D0-CTHE(2)**2)*CPHI
11450 Z1=2D0-Z(JT)
11451 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11452 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11453 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11454 & PMQ(3-JT)**2/SHP))
11455 ZMIN=2D0*PMQ(3-JT)/SHPR
11456 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11457 ZMAX=MIN(1D0-XH,ZMAX)
11458 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
11459 KCC=22
11460
11461 ELSEIF(ISUB.EQ.78) THEN
11462C...W+/- + h0 -> W+/- + h0
11463
11464 ELSEIF(ISUB.EQ.79) THEN
11465C...h0 + h0 -> h0 + h0
11466
11467 ELSEIF(ISUB.EQ.80) THEN
11468C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11469 IF(MINT(15).EQ.22) JS=2
11470 I=MINT(14+JS)
11471 IA=IABS(I)
11472 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
11473 IB=3-IA
11474 MINT(20+JS)=ISIGN(IB,I)
11475 KCC=22
11476 ENDIF
11477
11478 ELSEIF(ISUB.LE.90) THEN
11479 IF(ISUB.EQ.81) THEN
11480C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11481 MINT(21)=ISIGN(MINT(55),MINT(15))
11482 MINT(22)=-MINT(21)
11483 KCC=4
11484
11485 ELSEIF(ISUB.EQ.82) THEN
11486C...g + g -> Q + Qbar; th arbitrary
11487 KCS=(-1)**INT(1.5D0+PYR(0))
11488 MINT(21)=ISIGN(MINT(55),KCS)
11489 MINT(22)=-MINT(21)
11490 KCC=MINT(2)+10
11491
11492 ELSEIF(ISUB.EQ.83) THEN
11493C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11494 KFOLD=MINT(16)
11495 IF(MINT(2).EQ.2) KFOLD=MINT(15)
11496 KFAOLD=IABS(KFOLD)
11497 IF(KFAOLD.GT.10) THEN
11498 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
11499 ELSE
11500 RCKM=VINT(180+KFOLD)*PYR(0)
11501 IPM=(5-ISIGN(1,KFOLD))/2
11502 KFANEW=-MOD(KFAOLD+1,2)
11503 410 KFANEW=KFANEW+2
11504 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
11505 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
11506 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
11507 & VCKM(KFAOLD/2,(KFANEW+1)/2)
11508 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
11509 & VCKM(KFANEW/2,(KFAOLD+1)/2)
11510 ENDIF
11511 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
11512 ENDIF
11513 IF(MINT(2).EQ.1) THEN
11514 MINT(21)=ISIGN(MINT(55),MINT(15))
11515 MINT(22)=ISIGN(KFANEW,MINT(16))
11516 ELSE
11517 MINT(21)=ISIGN(KFANEW,MINT(15))
11518 MINT(22)=ISIGN(MINT(55),MINT(16))
11519 JS=2
11520 ENDIF
11521 KCC=22
11522
11523 ELSEIF(ISUB.EQ.84) THEN
11524C...g + gamma -> Q + Qbar; th arbitary
11525 KCS=(-1)**INT(1.5D0+PYR(0))
11526 MINT(21)=ISIGN(MINT(55),KCS)
11527 MINT(22)=-MINT(21)
11528 KCC=27
11529 IF(MINT(16).EQ.21) KCC=28
11530
11531 ELSEIF(ISUB.EQ.85) THEN
11532C...gamma + gamma -> F + Fbar; th arbitary
11533 KCS=(-1)**INT(1.5D0+PYR(0))
11534 MINT(21)=ISIGN(MINT(56),KCS)
11535 MINT(22)=-MINT(21)
11536 KCC=21
11537
11538 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
11539C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11540 MINT(21)=KFPR(ISUB,1)
11541 MINT(22)=KFPR(ISUB,2)
11542 KCC=24
11543 KCS=(-1)**INT(1.5D0+PYR(0))
11544 ENDIF
11545
11546 ELSEIF(ISUB.LE.100) THEN
11547 IF(ISUB.EQ.95) THEN
11548C...Low-pT ( = energyless g + g -> g + g)
11549 KCC=MINT(2)+12
11550 KCS=(-1)**INT(1.5D0+PYR(0))
11551
11552 ELSEIF(ISUB.EQ.96) THEN
11553C...Multiple interactions (should be reassigned to QCD process)
11554 ENDIF
11555
11556 ELSEIF(ISUB.LE.110) THEN
11557 IF(ISUB.EQ.101) THEN
11558C...g + g -> gamma*/Z0
11559 KCC=21
11560 KFRES=22
11561
11562 ELSEIF(ISUB.EQ.102) THEN
11563C...g + g -> h0 (or H0, or A0)
11564 KCC=21
11565 KFRES=KFHIGG
11566
11567 ELSEIF(ISUB.EQ.103) THEN
11568C...gamma + gamma -> h0 (or H0, or A0)
11569 KCC=21
11570 KFRES=KFHIGG
11571
11572 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
11573C...g + g -> chi_0c or chi_2c.
11574 KCC=21
11575 KFRES=KFPR(ISUB,1)
11576
11577 ELSEIF(ISUB.EQ.106) THEN
11578C...g + g -> J/Psi + gamma
11579 MINT(21)=KFPR(ISUB,1)
11580 MINT(22)=KFPR(ISUB,2)
11581 KCC=21
11582
11583 ELSEIF(ISUB.EQ.107) THEN
11584C...g + gamma -> J/Psi + g
11585 MINT(21)=KFPR(ISUB,1)
11586 MINT(22)=KFPR(ISUB,2)
11587 KCC=22
11588 IF(MINT(16).EQ.22) KCC=33
11589
11590 ELSEIF(ISUB.EQ.108) THEN
11591C...gamma + gamma -> J/Psi + gamma
11592 MINT(21)=KFPR(ISUB,1)
11593 MINT(22)=KFPR(ISUB,2)
11594
11595 ELSEIF(ISUB.EQ.110) THEN
11596C...f + fbar -> gamma + h0; th arbitrary
11597 IF(PYR(0).GT.0.5D0) JS=2
11598 MINT(20+JS)=22
11599 MINT(23-JS)=KFHIGG
11600 ENDIF
11601
11602 ELSEIF(ISUB.LE.120) THEN
11603 IF(ISUB.EQ.111) THEN
11604C...f + fbar -> g + h0; th arbitrary
11605 IF(PYR(0).GT.0.5D0) JS=2
11606 MINT(20+JS)=21
11607 MINT(23-JS)=KFHIGG
11608 KCC=17+JS
11609
11610 ELSEIF(ISUB.EQ.112) THEN
11611C...f + g -> f + h0; th = (p(f) - p(f))**2
11612 IF(MINT(15).EQ.21) JS=2
11613 MINT(23-JS)=KFHIGG
11614 KCC=15+JS
11615 KCS=ISIGN(1,MINT(14+JS))
11616
11617 ELSEIF(ISUB.EQ.113) THEN
11618C...g + g -> g + h0; th arbitrary
11619 IF(PYR(0).GT.0.5D0) JS=2
11620 MINT(23-JS)=KFHIGG
11621 KCC=22+JS
11622 KCS=(-1)**INT(1.5D0+PYR(0))
11623
11624 ELSEIF(ISUB.EQ.114) THEN
11625C...g + g -> gamma + gamma; th arbitrary
11626 IF(PYR(0).GT.0.5D0) JS=2
11627 MINT(21)=22
11628 MINT(22)=22
11629 KCC=21
11630
11631 ELSEIF(ISUB.EQ.115) THEN
11632C...g + g -> g + gamma; th arbitrary
11633 IF(PYR(0).GT.0.5D0) JS=2
11634 MINT(23-JS)=22
11635 KCC=22+JS
11636 KCS=(-1)**INT(1.5D0+PYR(0))
11637
11638 ELSEIF(ISUB.EQ.116) THEN
11639C...g + g -> gamma + Z0
11640
11641 ELSEIF(ISUB.EQ.117) THEN
11642C...g + g -> Z0 + Z0
11643
11644 ELSEIF(ISUB.EQ.118) THEN
11645C...g + g -> W+ + W-
11646 ENDIF
11647
11648 ELSEIF(ISUB.LE.140) THEN
11649 IF(ISUB.EQ.121) THEN
11650C...g + g -> Q + Qbar + h0
11651 KCS=(-1)**INT(1.5D0+PYR(0))
11652 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11653 MINT(22)=-MINT(21)
11654 KCC=11+INT(0.5D0+PYR(0))
11655 KFRES=KFHIGG
11656
11657 ELSEIF(ISUB.EQ.122) THEN
11658C...q + qbar -> Q + Qbar + h0
11659 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
11660 MINT(22)=-MINT(21)
11661 KCC=4
11662 KFRES=KFHIGG
11663
11664 ELSEIF(ISUB.EQ.123) THEN
11665C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11666C...inner process)
11667 KCC=22
11668 KFRES=KFHIGG
11669
11670 ELSEIF(ISUB.EQ.124) THEN
11671C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11672C...inner process)
11673 DO 430 JT=1,2
11674 I=MINT(14+JT)
11675 IA=IABS(I)
11676 IF(IA.LE.10) THEN
11677 RVCKM=VINT(180+I)*PYR(0)
11678 DO 420 J=1,MSTP(1)
11679 IB=2*J-1+MOD(IA,2)
11680 IPM=(5-ISIGN(1,I))/2
11681 IDC=J+MDCY(IA,2)+2
11682 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
11683 MINT(20+JT)=ISIGN(IB,I)
11684 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11685 IF(RVCKM.LE.0D0) GOTO 430
11686 420 CONTINUE
11687 ELSE
11688 IB=2*((IA+1)/2)-1+MOD(IA,2)
11689 MINT(20+JT)=ISIGN(IB,I)
11690 ENDIF
11691 430 CONTINUE
11692 KCC=22
11693 KFRES=KFHIGG
11694
11695 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
11696C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11697 IF(MINT(15).EQ.22) JS=2
11698 MINT(23-JS)=21
11699 KCC=24+JS
11700 KCS=ISIGN(1,MINT(14+JS))
11701
11702 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
11703C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11704 IF(MINT(15).EQ.22) JS=2
11705 KCC=22
11706 KCS=ISIGN(1,MINT(14+JS))
11707
11708 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
11709C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11710 KCS=(-1)**INT(1.5D0+PYR(0))
11711 MINT(21)=ISIGN(KFLF,KCS)
11712 MINT(22)=-MINT(21)
11713 KCC=27
11714 IF(MINT(16).EQ.21) KCC=28
11715
11716 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
11717C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11718 KCS=(-1)**INT(1.5D0+PYR(0))
11719 MINT(21)=ISIGN(KFLF,KCS)
11720 MINT(22)=-MINT(21)
11721 KCC=21
11722
11723 ENDIF
11724
11725 ELSEIF(ISUB.LE.160) THEN
11726 IF(ISUB.EQ.141) THEN
11727C...f + fbar -> gamma*/Z0/Z'0
11728 KFRES=32
11729
11730 ELSEIF(ISUB.EQ.142) THEN
11731C...f + fbar' -> W'+/-
11732 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11733 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11734 KFRES=ISIGN(34,KCH1+KCH2)
11735
11736 ELSEIF(ISUB.EQ.143) THEN
11737C...f + fbar' -> H+/-
11738 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11739 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11740 KFRES=ISIGN(37,KCH1+KCH2)
11741
11742 ELSEIF(ISUB.EQ.144) THEN
11743C...f + fbar' -> R
11744 KFRES=ISIGN(41,MINT(15)+MINT(16))
11745
11746 ELSEIF(ISUB.EQ.145) THEN
11747C...q + l -> LQ (leptoquark)
11748 IF(IABS(MINT(16)).LE.8) JS=2
11749 KFRES=ISIGN(42,MINT(14+JS))
11750 KCC=28+JS
11751 KCS=ISIGN(1,MINT(14+JS))
11752
11753 ELSEIF(ISUB.EQ.146) THEN
11754C...e + gamma -> e* (excited lepton)
11755 IF(MINT(15).EQ.22) JS=2
11756 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11757 KCC=22
11758
11759 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
11760C...q + g -> q* (excited quark)
11761 IF(MINT(15).EQ.21) JS=2
11762 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11763 KCC=30+JS
11764 KCS=ISIGN(1,MINT(14+JS))
11765
11766 ELSEIF(ISUB.EQ.149) THEN
11767C...g + g -> eta_tc
11768 KFRES=KTECHN+331
11769 KCC=23
11770 KCS=(-1)**INT(1.5D0+PYR(0))
11771 ENDIF
11772
11773 ELSEIF(ISUB.LE.200) THEN
11774 IF(ISUB.EQ.161) THEN
11775C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11776 IF(MINT(15).EQ.21) JS=2
11777 I=MINT(14+JS)
11778 IA=IABS(I)
11779 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
11780 IB=IA+MOD(IA,2)-MOD(IA+1,2)
11781 MINT(20+JS)=ISIGN(IB,I)
11782 KCC=15+JS
11783 KCS=ISIGN(1,MINT(14+JS))
11784
11785 ELSEIF(ISUB.EQ.162) THEN
11786C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11787 IF(MINT(15).EQ.21) JS=2
11788 MINT(20+JS)=ISIGN(42,MINT(14+JS))
11789 KFLQL=KFDP(MDCY(42,2),2)
11790 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
11791 KCC=15+JS
11792 KCS=ISIGN(1,MINT(14+JS))
11793
11794 ELSEIF(ISUB.EQ.163) THEN
11795C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11796 KCS=(-1)**INT(1.5D0+PYR(0))
11797 MINT(21)=ISIGN(42,KCS)
11798 MINT(22)=-MINT(21)
11799 KCC=MINT(2)+10
11800
11801 ELSEIF(ISUB.EQ.164) THEN
11802C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11803 MINT(21)=ISIGN(42,MINT(15))
11804 MINT(22)=-MINT(21)
11805 KCC=4
11806
11807 ELSEIF(ISUB.EQ.165) THEN
11808C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11809 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11810 MINT(22)=-MINT(21)
11811
11812 ELSEIF(ISUB.EQ.166) THEN
11813C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11814 IF(MOD(MINT(15),2).EQ.0) THEN
11815 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11816 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11817 ELSE
11818 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11819 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11820 ENDIF
11821
11822 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
11823C...q + q' -> q" + q* (excited quark)
11824 KFQSTR=KFPR(ISUB,2)
11825 KFQEXC=MOD(KFQSTR,KEXCIT)
11826 JS=MINT(2)
11827 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11828 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
11829 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11830 KCC=22
11831 JS=3-JS
11832
11833 ELSEIF(ISUB.EQ.169) THEN
11834C...q + qbar -> e + e* (excited lepton)
11835 KFQSTR=KFPR(ISUB,2)
11836 KFQEXC=MOD(KFQSTR,KEXCIT)
11837 JS=MINT(2)
11838 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11839 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11840 JS=3-JS
11841
11842 ELSEIF(ISUB.EQ.191) THEN
11843C...f + fbar -> rho_tc0.
11844 KFRES=KTECHN+113
11845
11846 ELSEIF(ISUB.EQ.192) THEN
11847C...f + fbar' -> rho_tc+/-
11848 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11849 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11850 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11851
11852 ELSEIF(ISUB.EQ.193) THEN
11853C...f + fbar -> omega_tc0.
11854 KFRES=KTECHN+223
11855
11856 ELSEIF(ISUB.EQ.194) THEN
11857C...f + fbar -> f' + fbar' via mixture of s-channel
11858C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11859 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11860 MINT(22)=-MINT(21)
11861
11862 ELSEIF(ISUB.EQ.195) THEN
11863C...f + fbar' -> f'' + fbar''' via s-channel
11864C...rho_tc+ th=(p(f)-p(f'))**2
11865C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11866 IF(MOD(MINT(15),2).EQ.0) THEN
11867 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11868 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11869 ELSE
11870 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11871 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11872 ENDIF
11873 ENDIF
11874
11875CMRENNA++
11876 ELSEIF(ISUB.LE.215) THEN
11877 IF(ISUB.EQ.201) THEN
11878C...f + fbar -> ~e_L + ~e_Lbar
11879 MINT(21)=ISIGN(KSUSY1+11,KCS)
11880 MINT(22)=-MINT(21)
11881
11882 ELSEIF(ISUB.EQ.202) THEN
11883C...f + fbar -> ~e_R + ~e_Rbar
11884 MINT(21)=ISIGN(KSUSY2+11,KCS)
11885 MINT(22)=-MINT(21)
11886
11887 ELSEIF(ISUB.EQ.203) THEN
11888C...f + fbar -> ~e_L + ~e_Rbar
11889 IF(MINT(15).LT.0) JS=2
11890 IF(MINT(2).EQ.1) THEN
11891 MINT(20+JS)=KFPR(ISUB,1)
11892 MINT(23-JS)=-KFPR(ISUB,2)
11893 ELSE
11894 MINT(20+JS)=-KFPR(ISUB,1)
11895 MINT(23-JS)=KFPR(ISUB,2)
11896 ENDIF
11897
11898 ELSEIF(ISUB.EQ.204) THEN
11899C...f + fbar -> ~mu_L + ~mu_Lbar
11900 MINT(21)=ISIGN(KSUSY1+13,KCS)
11901 MINT(22)=-MINT(21)
11902
11903 ELSEIF(ISUB.EQ.205) THEN
11904C...f + fbar -> ~mu_R + ~mu_Rbar
11905 MINT(21)=ISIGN(KSUSY2+13,KCS)
11906 MINT(22)=-MINT(21)
11907
11908 ELSEIF(ISUB.EQ.206) THEN
11909C...f + fbar -> ~mu_L + ~mu_Rbar
11910 IF(MINT(15).LT.0) JS=2
11911 IF(MINT(2).EQ.1) THEN
11912 MINT(20+JS)=KFPR(ISUB,1)
11913 MINT(23-JS)=-KFPR(ISUB,2)
11914 ELSE
11915 MINT(20+JS)=-KFPR(ISUB,1)
11916 MINT(23-JS)=KFPR(ISUB,2)
11917 ENDIF
11918
11919 ELSEIF(ISUB.EQ.207) THEN
11920C...f + fbar -> ~tau_1 + ~tau_1bar
11921 MINT(21)=ISIGN(KSUSY1+15,KCS)
11922 MINT(22)=-MINT(21)
11923
11924 ELSEIF(ISUB.EQ.208) THEN
11925C...f + fbar -> ~tau_2 + ~tau_2bar
11926 MINT(21)=ISIGN(KSUSY2+15,KCS)
11927 MINT(22)=-MINT(21)
11928
11929 ELSEIF(ISUB.EQ.209) THEN
11930C...f + fbar -> ~tau_1 + ~tau_2bar
11931 IF(MINT(15).LT.0) JS=2
11932 IF(MINT(2).EQ.1) THEN
11933 MINT(20+JS)=KFPR(ISUB,1)
11934 MINT(23-JS)=-KFPR(ISUB,2)
11935 ELSE
11936 MINT(20+JS)=-KFPR(ISUB,1)
11937 MINT(23-JS)=KFPR(ISUB,2)
11938 ENDIF
11939
11940 ELSEIF(ISUB.EQ.210) THEN
11941C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11942 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11943 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11944 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11945 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11946
11947 ELSEIF(ISUB.EQ.211) THEN
11948C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11949 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11950 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11951 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11952 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11953
11954 ELSEIF(ISUB.EQ.212) THEN
11955C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11956 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11957 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11958 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11959 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11960
11961 ELSEIF(ISUB.EQ.213) THEN
11962C...f + fbar -> ~nul + ~nulbar
11963 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11964 MINT(22)=-MINT(21)
11965
11966 ELSEIF(ISUB.EQ.214) THEN
11967C...f + fbar -> ~nutau + ~nutaubar
11968 MINT(21)=ISIGN(KSUSY1+16,KCS)
11969 MINT(22)=-MINT(21)
11970 ENDIF
11971
11972 ELSEIF(ISUB.LE.225) THEN
11973 IF(ISUB.EQ.216) THEN
11974C...f + fbar -> ~chi01 + ~chi01
11975 MINT(21)=KSUSY1+22
11976 MINT(22)=KSUSY1+22
11977
11978 ELSEIF(ISUB.EQ.217) THEN
11979C...f + fbar -> ~chi02 + ~chi02
11980 MINT(21)=KSUSY1+23
11981 MINT(22)=KSUSY1+23
11982
11983 ELSEIF(ISUB.EQ.218 ) THEN
11984C...f + fbar -> ~chi03 + ~chi03
11985 MINT(21)=KSUSY1+25
11986 MINT(22)=KSUSY1+25
11987
11988 ELSEIF(ISUB.EQ.219 ) THEN
11989C...f + fbar -> ~chi04 + ~chi04
11990 MINT(21)=KSUSY1+35
11991 MINT(22)=KSUSY1+35
11992
11993 ELSEIF(ISUB.EQ.220 ) THEN
11994C...f + fbar -> ~chi01 + ~chi02
11995 IF(MINT(15).LT.0) JS=2
11996C IF(PYR(0).GT.0.5D0) JS=2
11997 MINT(20+JS)=KSUSY1+22
11998 MINT(23-JS)=KSUSY1+23
11999
12000 ELSEIF(ISUB.EQ.221 ) THEN
12001C...f + fbar -> ~chi01 + ~chi03
12002 IF(MINT(15).LT.0) JS=2
12003C IF(PYR(0).GT.0.5D0) JS=2
12004 MINT(20+JS)=KSUSY1+22
12005 MINT(23-JS)=KSUSY1+25
12006
12007 ELSEIF(ISUB.EQ.222) THEN
12008C...f + fbar -> ~chi01 + ~chi04
12009 IF(MINT(15).LT.0) JS=2
12010C IF(PYR(0).GT.0.5D0) JS=2
12011 MINT(20+JS)=KSUSY1+22
12012 MINT(23-JS)=KSUSY1+35
12013
12014 ELSEIF(ISUB.EQ.223) THEN
12015C...f + fbar -> ~chi02 + ~chi03
12016 IF(MINT(15).LT.0) JS=2
12017C IF(PYR(0).GT.0.5D0) JS=2
12018 MINT(20+JS)=KSUSY1+23
12019 MINT(23-JS)=KSUSY1+25
12020
12021 ELSEIF(ISUB.EQ.224) THEN
12022C...f + fbar -> ~chi02 + ~chi04
12023 IF(MINT(15).LT.0) JS=2
12024C IF(PYR(0).GT.0.5D0) JS=2
12025 MINT(20+JS)=KSUSY1+23
12026 MINT(23-JS)=KSUSY1+35
12027
12028 ELSEIF(ISUB.EQ.225) THEN
12029C...f + fbar -> ~chi03 + ~chi04
12030 IF(MINT(15).LT.0) JS=2
12031C IF(PYR(0).GT.0.5D0) JS=2
12032 MINT(20+JS)=KSUSY1+25
12033 MINT(23-JS)=KSUSY1+35
12034 ENDIF
12035
12036 ELSEIF(ISUB.LE.236) THEN
12037 IF(ISUB.EQ.226) THEN
12038C...f + fbar -> ~chi+-1 + ~chi-+1
12039C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
12040 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12041 MINT(21)=ISIGN(KSUSY1+24,KCH1)
12042 MINT(22)=-MINT(21)
12043
12044 ELSEIF(ISUB.EQ.227) THEN
12045C...f + fbar -> ~chi+-2 + ~chi-+2
12046 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12047 MINT(21)=ISIGN(KSUSY1+37,KCH1)
12048 MINT(22)=-MINT(21)
12049
12050 ELSEIF(ISUB.EQ.228) THEN
12051C...f + fbar -> ~chi+-1 + ~chi-+2
12052C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
12053C...js=1 if pyr<.5, js=2 if pyr>.5
12054C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
12055C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
12056C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
12057C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
12058 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12059 KCH2=INT(1-KCH1)/2
12060 IF(MINT(2).EQ.1) THEN
12061 MINT(21)= ISIGN(KSUSY1+24,KCH1)
12062 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
12063c IF(KCH2.EQ.0) JS=2
12064 ELSE
12065 MINT(21)= ISIGN(KSUSY1+37,KCH1)
12066 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
12067 JS=2
12068c IF(KCH2.EQ.1) JS=2
12069 ENDIF
12070
12071 ELSEIF(ISUB.EQ.229) THEN
12072C...q + qbar' -> ~chi01 + ~chi+-1
12073C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
12074 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12075 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12076C...CHECK THIS
12077 IF(MOD(MINT(15),2).EQ.0) JS=2
12078 MINT(20+JS)=KSUSY1+22
12079 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12080
12081 ELSEIF(ISUB.EQ.230) THEN
12082C...q + qbar' -> ~chi02 + ~chi+-1
12083 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12084 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12085 IF(MOD(MINT(15),2).EQ.0) JS=2
12086 MINT(20+JS)=KSUSY1+23
12087 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12088
12089 ELSEIF(ISUB.EQ.231) THEN
12090C...q + qbar' -> ~chi03 + ~chi+-1
12091 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12092 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12093 IF(MOD(MINT(15),2).EQ.0) JS=2
12094 MINT(20+JS)=KSUSY1+25
12095 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12096
12097 ELSEIF(ISUB.EQ.232) THEN
12098C...q + qbar' -> ~chi04 + ~chi+-1
12099 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12100 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12101 IF(MOD(MINT(15),2).EQ.0) JS=2
12102 MINT(20+JS)=KSUSY1+35
12103 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12104
12105 ELSEIF(ISUB.EQ.233) THEN
12106C...q + qbar' -> ~chi01 + ~chi+-2
12107 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12108 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12109 IF(MOD(MINT(15),2).EQ.0) JS=2
12110 MINT(20+JS)=KSUSY1+22
12111 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12112
12113 ELSEIF(ISUB.EQ.234) THEN
12114C...q + qbar' -> ~chi02 + ~chi+-2
12115 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12116 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12117 IF(MOD(MINT(15),2).EQ.0) JS=2
12118 MINT(20+JS)=KSUSY1+23
12119 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12120
12121 ELSEIF(ISUB.EQ.235) THEN
12122C...q + qbar' -> ~chi03 + ~chi+-2
12123 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12124 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12125 IF(MOD(MINT(15),2).EQ.0) JS=2
12126 MINT(20+JS)=KSUSY1+25
12127 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12128
12129 ELSEIF(ISUB.EQ.236) THEN
12130C...q + qbar' -> ~chi04 + ~chi+-2
12131 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12132 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12133 IF(MOD(MINT(15),2).EQ.0) JS=2
12134 MINT(20+JS)=KSUSY1+35
12135 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12136 ENDIF
12137
12138 ELSEIF(ISUB.LE.245) THEN
12139 IF(ISUB.EQ.237) THEN
12140C...q + qbar -> ~chi01 + ~g
12141C...th arbitrary
12142 IF(PYR(0).GT.0.5D0) JS=2
12143 MINT(20+JS)=KSUSY1+21
12144 MINT(23-JS)=KSUSY1+22
12145 KCC=17+JS
12146
12147 ELSEIF(ISUB.EQ.238) THEN
12148C...q + qbar -> ~chi02 + ~g
12149C...th arbitrary
12150 IF(PYR(0).GT.0.5D0) JS=2
12151 MINT(20+JS)=KSUSY1+21
12152 MINT(23-JS)=KSUSY1+23
12153 KCC=17+JS
12154
12155 ELSEIF(ISUB.EQ.239) THEN
12156C...q + qbar -> ~chi03 + ~g
12157C...th arbitrary
12158 IF(PYR(0).GT.0.5D0) JS=2
12159 MINT(20+JS)=KSUSY1+21
12160 MINT(23-JS)=KSUSY1+25
12161 KCC=17+JS
12162
12163 ELSEIF(ISUB.EQ.240) THEN
12164C...q + qbar -> ~chi04 + ~g
12165C...th arbitrary
12166 IF(PYR(0).GT.0.5D0) JS=2
12167 MINT(20+JS)=KSUSY1+21
12168 MINT(23-JS)=KSUSY1+35
12169 KCC=17+JS
12170
12171 ELSEIF(ISUB.EQ.241) THEN
12172C...q + qbar' -> ~chi+-1 + ~g
12173C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12174C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12175C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12176C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12177C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12178 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12179 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12180 JS=1
12181 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12182 MINT(20+JS)=KSUSY1+21
12183 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12184 KCC=17+JS
12185
12186 ELSEIF(ISUB.EQ.242) THEN
12187C...q + qbar' -> ~chi+-2 + ~g
12188C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12189C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12190C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12191C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12192C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12193 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12194 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12195 JS=1
12196 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12197 MINT(20+JS)=KSUSY1+21
12198 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12199 KCC=17+JS
12200
12201 ELSEIF(ISUB.EQ.243) THEN
12202C...q + qbar -> ~g + ~g ; th arbitrary
12203 MINT(21)=KSUSY1+21
12204 MINT(22)=KSUSY1+21
12205 KCC=MINT(2)+4
12206
12207 ELSEIF(ISUB.EQ.244) THEN
12208C...g + g -> ~g + ~g ; th arbitrary
12209 KCC=MINT(2)+12
12210 KCS=(-1)**INT(1.5D0+PYR(0))
12211 MINT(21)=KSUSY1+21
12212 MINT(22)=KSUSY1+21
12213 ENDIF
12214
12215 ELSEIF(ISUB.LE.260) THEN
12216 IF(ISUB.EQ.246) THEN
12217C...qj + g -> ~qj_L + ~chi01
12218 IF(MINT(15).EQ.21) JS=2
12219 I=MINT(14+JS)
12220 IA=IABS(I)
12221 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12222 MINT(23-JS)=KSUSY1+22
12223 KCC=15+JS
12224 KCS=ISIGN(1,MINT(14+JS))
12225
12226 ELSEIF(ISUB.EQ.247) THEN
12227C...qj + g -> ~qj_R + ~chi01
12228 IF(MINT(15).EQ.21) JS=2
12229 I=MINT(14+JS)
12230 IA=IABS(I)
12231 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12232 MINT(23-JS)=KSUSY1+22
12233 KCC=15+JS
12234 KCS=ISIGN(1,MINT(14+JS))
12235
12236 ELSEIF(ISUB.EQ.248) THEN
12237C...qj + g -> ~qj_L + ~chi02
12238 IF(MINT(15).EQ.21) JS=2
12239 I=MINT(14+JS)
12240 IA=IABS(I)
12241 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12242 MINT(23-JS)=KSUSY1+23
12243 KCC=15+JS
12244 KCS=ISIGN(1,MINT(14+JS))
12245
12246 ELSEIF(ISUB.EQ.249) THEN
12247C...qj + g -> ~qj_R + ~chi02
12248 IF(MINT(15).EQ.21) JS=2
12249 I=MINT(14+JS)
12250 IA=IABS(I)
12251 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12252 MINT(23-JS)=KSUSY1+23
12253 KCC=15+JS
12254 KCS=ISIGN(1,MINT(14+JS))
12255
12256 ELSEIF(ISUB.EQ.250) THEN
12257C...qj + g -> ~qj_L + ~chi03
12258 IF(MINT(15).EQ.21) JS=2
12259 I=MINT(14+JS)
12260 IA=IABS(I)
12261 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12262 MINT(23-JS)=KSUSY1+25
12263 KCC=15+JS
12264 KCS=ISIGN(1,MINT(14+JS))
12265
12266 ELSEIF(ISUB.EQ.251) THEN
12267C...qj + g -> ~qj_R + ~chi03
12268 IF(MINT(15).EQ.21) JS=2
12269 I=MINT(14+JS)
12270 IA=IABS(I)
12271 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12272 MINT(23-JS)=KSUSY1+25
12273 KCC=15+JS
12274 KCS=ISIGN(1,MINT(14+JS))
12275
12276 ELSEIF(ISUB.EQ.252) THEN
12277C...qj + g -> ~qj_L + ~chi04
12278 IF(MINT(15).EQ.21) JS=2
12279 I=MINT(14+JS)
12280 IA=IABS(I)
12281 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12282 MINT(23-JS)=KSUSY1+35
12283 KCC=15+JS
12284 KCS=ISIGN(1,MINT(14+JS))
12285
12286 ELSEIF(ISUB.EQ.253) THEN
12287C...qj + g -> ~qj_R + ~chi04
12288 IF(MINT(15).EQ.21) JS=2
12289 I=MINT(14+JS)
12290 IA=IABS(I)
12291 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12292 MINT(23-JS)=KSUSY1+35
12293 KCC=15+JS
12294 KCS=ISIGN(1,MINT(14+JS))
12295
12296 ELSEIF(ISUB.EQ.254) THEN
12297C...qj + g -> ~qk_L + ~chi+-1
12298 IF(MINT(15).EQ.21) JS=2
12299 I=MINT(14+JS)
12300 IA=IABS(I)
12301 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12302 IB=-IA+INT((IA+1)/2)*4-1
12303 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12304 KCC=15+JS
12305 KCS=ISIGN(1,MINT(14+JS))
12306
12307 ELSEIF(ISUB.EQ.255) THEN
12308C...qj + g -> ~qk_L + ~chi+-1
12309 IF(MINT(15).EQ.21) JS=2
12310 I=MINT(14+JS)
12311 IA=IABS(I)
12312 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12313 IB=-IA+INT((IA+1)/2)*4-1
12314 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12315 KCC=15+JS
12316 KCS=ISIGN(1,MINT(14+JS))
12317
12318 ELSEIF(ISUB.EQ.256) THEN
12319C...qj + g -> ~qk_L + ~chi+-2
12320 IF(MINT(15).EQ.21) JS=2
12321 I=MINT(14+JS)
12322 IA=IABS(I)
12323 IB=-IA+INT((IA+1)/2)*4-1
12324 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12325 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12326 KCC=15+JS
12327 KCS=ISIGN(1,MINT(14+JS))
12328
12329 ELSEIF(ISUB.EQ.257) THEN
12330C...qj + g -> ~qk_R + ~chi+-2
12331 IF(MINT(15).EQ.21) JS=2
12332 I=MINT(14+JS)
12333 IA=IABS(I)
12334 IB=-IA+INT((IA+1)/2)*4-1
12335 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12336 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12337 KCC=15+JS
12338 KCS=ISIGN(1,MINT(14+JS))
12339
12340 ELSEIF(ISUB.EQ.258) THEN
12341C...qj + g -> ~qj_L + ~g
12342 IF(MINT(15).EQ.21) JS=2
12343 I=MINT(14+JS)
12344 IA=IABS(I)
12345 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12346 MINT(23-JS)=KSUSY1+21
12347 KCC=MINT(2)+6
12348 IF(JS.EQ.2) KCC=KCC+2
12349 KCS=ISIGN(1,I)
12350
12351 ELSEIF(ISUB.EQ.259) THEN
12352C...qj + g -> ~qj_R + ~g
12353 IF(MINT(15).EQ.21) JS=2
12354 I=MINT(14+JS)
12355 IA=IABS(I)
12356 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12357 MINT(23-JS)=KSUSY1+21
12358 KCC=MINT(2)+6
12359 IF(JS.EQ.2) KCC=KCC+2
12360 KCS=ISIGN(1,I)
12361 ENDIF
12362
12363 ELSEIF(ISUB.LE.270) THEN
12364 IF(ISUB.EQ.261) THEN
12365C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
12366 ISGN=1
12367 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12368 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12369 MINT(22)=-MINT(21)
12370C...Correct color combination
12371 IF(MINT(43).EQ.4) KCC=4
12372
12373 ELSEIF(ISUB.EQ.262) THEN
12374C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
12375 ISGN=1
12376 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12377 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12378 MINT(22)=-MINT(21)
12379C...Correct color combination
12380 IF(MINT(43).EQ.4) KCC=4
12381
12382 ELSEIF(ISUB.EQ.263) THEN
12383C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
12384 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
12385 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
12386 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12387 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
12388 ELSE
12389 JS=2
12390 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
12391 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
12392 ENDIF
12393C...Correct color combination
12394 IF(MINT(43).EQ.4) KCC=4
12395
12396 ELSEIF(ISUB.EQ.264) THEN
12397C...g + g -> ~t_1 + ~t_1bar; th arbitrary
12398 KCS=(-1)**INT(1.5D0+PYR(0))
12399 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12400 MINT(22)=-MINT(21)
12401 KCC=MINT(2)+10
12402
12403 ELSEIF(ISUB.EQ.265) THEN
12404C...g + g -> ~t_2 + ~t_2bar; th arbitrary
12405 KCS=(-1)**INT(1.5D0+PYR(0))
12406 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12407 MINT(22)=-MINT(21)
12408 KCC=MINT(2)+10
12409 ENDIF
12410
12411 ELSEIF(ISUB.LE.301) THEN
12412 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
12413C...qi + qj -> ~qi_L + ~qj_L
12414 KCC=MINT(2)
12415 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12416 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12417 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12418
12419 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
12420C...qi + qj -> ~qi_R + ~qj_R
12421 KCC=MINT(2)
12422 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12423 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12424 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12425
12426 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
12427C...qi + qj -> ~qi_L + ~qj_R
12428 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12429 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12430 KCC=MINT(2)
12431 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12432
12433 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
12434C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
12435 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12436 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12437 KCC=MINT(2)
12438 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12439
12440 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
12441C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12442 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12443 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12444 KCC=MINT(2)
12445 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12446
12447 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
12448C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12449 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12450 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12451 KCC=MINT(2)
12452 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12453
12454 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
12455C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12456 ISGN=1
12457 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12458 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12459 MINT(22)=-MINT(21)
12460 IF(MINT(43).EQ.4) KCC=4
12461
12462 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
12463C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12464 ISGN=1
12465 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12466 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12467 MINT(22)=-MINT(21)
12468 IF(MINT(43).EQ.4) KCC=4
12469
12470 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
12471C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12472C...pure LL + RR
12473 KCS=(-1)**INT(1.5D0+PYR(0))
12474 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12475 MINT(22)=-MINT(21)
12476 KCC=MINT(2)+10
12477
12478 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
12479C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12480 KCS=(-1)**INT(1.5D0+PYR(0))
12481 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12482 MINT(22)=-MINT(21)
12483 KCC=MINT(2)+10
12484
12485 ELSEIF(ISUB.EQ.294) THEN
12486C...qj + g -> ~qj_L + ~g
12487 IF(MINT(15).EQ.21) JS=2
12488 I=MINT(14+JS)
12489 IA=IABS(I)
12490 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12491 MINT(23-JS)=KSUSY1+21
12492 KCC=MINT(2)+6
12493 IF(JS.EQ.2) KCC=KCC+2
12494 KCS=ISIGN(1,I)
12495
12496 ELSEIF(ISUB.EQ.295) THEN
12497C...qj + g -> ~qj_R + ~g
12498 IF(MINT(15).EQ.21) JS=2
12499 I=MINT(14+JS)
12500 IA=IABS(I)
12501 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12502 MINT(23-JS)=KSUSY1+21
12503 KCC=MINT(2)+6
12504 IF(JS.EQ.2) KCC=KCC+2
12505 KCS=ISIGN(1,I)
12506
12507 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
12508C...q + qbar' -> H+ + H0
12509 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12510 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12511 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12512 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
12513 MINT(23-JS)=KFPR(ISUB,2)
12514 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
12515C...f + fbar -> A0 + H0; th arbitrary
12516 IF(PYR(0).GT.0.5D0) JS=2
12517 MINT(20+JS)=KFPR(ISUB,1)
12518 MINT(23-JS)=KFPR(ISUB,2)
12519 ELSEIF(ISUB.EQ.301) THEN
12520C...f + fbar -> H+ H-
12521 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12522 MINT(22)=-MINT(21)
12523 ENDIF
12524CMRENNA--
12525 ELSEIF(ISUB.LE.330) THEN
12526 IF(ISUB.EQ.311)THEN
12527C...g + g -> g* + g* (UED)
12528 KCC=MINT(2)+12
12529 KCS=(-1)**INT(1.5D0+PYR(0))
12530 MUED(1)=472
12531 MUED(2)=472
12532 MINT(21)=IUEDEQ(472)
12533 MINT(22)=IUEDEQ(472)
12534 ELSEIF(ISUB.EQ.312)THEN
12535C...q + g -> q*_D + g*, q*_S + g*
12536C...The two channels have the same cross section
12537 KKFLMI=450
12538 IF(PYR(0).GT.0.5)KKFLMI=456
12539 IF(MINT(15).EQ.21) JS=2
12540 KCC=MINT(2)+6
12541 IF(MINT(15).EQ.21)KCC=KCC+2
12542 IF(MINT(15).NE.21)THEN
12543 KCS=ISIGN(1,MINT(15))
12544 MUED(2)=472
12545 MUED(1)=KCS*(KKFLMI+IABS(MINT(15)))
12546 MINT(22)=IUEDEQ(472)
12547 MINT(21)=KCS*IUEDEQ(KKFLMI+IABS(MINT(15)))
12548 ENDIF
12549 IF(MINT(16).NE.21)THEN
12550 KCS=ISIGN(1,MINT(16))
12551 MUED(2)=KCS*(KKFLMI+IABS(MINT(16)))
12552 MUED(1)=472
12553 MINT(22)=KCS*IUEDEQ(KKFLMI+IABS(MINT(16)))
12554 MINT(21)=IUEDEQ(472)
12555 ENDIF
12556 ELSEIF(ISUB.EQ.313)THEN
12557C...q + q' -> q*_D + q*_D',q*_S+q*_S'
12558C...The two channels have the same cross section
12559 KKFLMI=450
12560 IF(PYR(0).GT.0.5)KKFLMI=456
12561 KCC=MINT(2)
12562 IF(MINT(15).EQ.MINT(16))THEN
12563 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12564 MUED(2)=MINT(21)
12565 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12566 MINT(22)=MINT(21)
12567 ELSE
12568 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12569 MUED(2)=SIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12570 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12571 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12572 ENDIF
12573 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12574 ELSEIF(ISUB.EQ.314)THEN
12575C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar
12576C...The two channels have the same cross section
12577 KKFLMI=450
12578 IF(PYR(0).GT.0.5)KKFLMI=456
12579 KCS=(-1)**INT(1.5D0+PYR(0))
12580 XFLAOUT=PYR(0)
12581 IF(XFLAOUT.LE.0.2)THEN
12582 MUED(1)=ISIGN(1,KCS)*(KKFLMI+1)
12583 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+1)
12584 ELSEIF(XFLAOUT.LE.0.4)THEN
12585 MUED(1)=ISIGN(1,KCS)*(KKFLMI+2)
12586 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+2)
12587 ELSEIF(XFLAOUT.LE.0.6)THEN
12588 MUED(1)=ISIGN(1,KCS)*(KKFLMI+3)
12589 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+3)
12590 ELSEIF(XFLAOUT.LE.0.8)THEN
12591 MUED(1)=ISIGN(1,KCS)*(KKFLMI+4)
12592 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+4)
12593 ELSE
12594 MUED(1)=ISIGN(1,KCS)*(KKFLMI+5)
12595 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+5)
12596 ENDIF
12597 MINT(22)=-MINT(21)
12598 MUED(2)=-MUED(1)
12599 KCC=MINT(2)+10
12600 ELSEIF(ISUB.EQ.315)THEN
12601C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar
12602C...The two channels have the same cross section
12603 KKFLMI=450
12604 IF(PYR(0).GT.0.5)KKFLMI=456
12605 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12606 MUED(2)=-MINT(21)
12607 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12608 MINT(22)=-MINT(21)
12609 KCC=4
12610 ELSEIF(ISUB.EQ.316)THEN
12611C...q + qbar' -> q*_D + q*_S_bar'
12612 MUED(1)=ISIGN(1,MINT(15))*(456+IABS(MINT(15)))
12613 MUED(2)=ISIGN(1,MINT(16))*(450+IABS(MINT(16)))
12614 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12615 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12616 KCC=MINT(2)+2
12617 ELSEIF(ISUB.EQ.317)THEN
12618C...q + qbar' -> q*_D + q*_D_bar', q*_S + q*_S_bar
12619C...The two channels have the same cross section
12620 KKFLMI=450
12621 IF(PYR(0).GT.0.5)KKFLMI=456
12622 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12623 MUED(2)=ISIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12624 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12625 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12626 KCC=MINT(2)+2
12627 ELSEIF(ISUB.EQ.318)THEN
12628C...q + q' -> q*_D + q*_S'
12629 KCC=MINT(2)
12630 MUED(1)=SIGN(1,MINT(15))*(456+IABS(MINT(15)))
12631 MUED(2)=SIGN(1,MINT(16))*(450+IABS(MINT(16)))
12632 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12633 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12634 ELSEIF(ISUB.EQ.319)THEN
12635C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar'
12636C...The two channels have the same cross section
12637 KKFLMI=450
12638 IF(PYR(0).GT.0.5)KKFLMI=456
12639 XFLAOUT=PYR(0)
12640 IIFLAV=0
12641C...N.B. NFLAVOURS=IUED(3)
12642C DO I=1,NFLAVOURS
12643 DO 433 I=1,IUED(3)
12644 IF(I.NE.IABS(MINT(15)))THEN
12645 IIFLAV=IIFLAV+1
12646 IOKFLA(IIFLAV)=I
12647 ENDIF
12648 433 CONTINUE
12649 FLASTEP=1./(IUED(3)-1)
12650 DO I=1,IUED(3)-1
12651 FLAVV=FLASTEP*I
12652 IF(XFLAOUT.LE.FLAVV)THEN
12653 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IOKFLA(I))
12654 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IOKFLA(I))
12655 GOTO 435
12656 ENDIF
12657 ENDDO
12658 435 CONTINUE
12659 IF(IABS(MUED(1)).LT.451.AND.IABS(MUED(1)).GT.462)THEN
12660 WRITE(MSTU(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!'
12661 CALL PYSTOP(5000000)
12662 ENDIF
12663 MINT(22)=-MINT(21)
12664 KCC=4
12665 ENDIF
12666
12667 ELSEIF(ISUB.LE.360) THEN
12668
12669 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
12670C...l + l -> H_L++/--, H_R++/--
12671 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12672 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12673 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12674
12675 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
12676C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12677 IF(MINT(15).EQ.22) JS=2
12678 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
12679 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
12680 KCC=22
12681
12682 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
12683C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12684 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
12685 MINT(22)=-MINT(21)
12686
12687 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
12688C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12689C...as inner process).
12690 DO 450 JT=1,2
12691 I=MINT(14+JT)
12692 IA=IABS(I)
12693 IF(IA.LE.10) THEN
12694 RVCKM=VINT(180+I)*PYR(0)
12695 DO 440 J=1,MSTP(1)
12696 IB=2*J-1+MOD(IA,2)
12697 IPM=(5-ISIGN(1,I))/2
12698 IDC=J+MDCY(IA,2)+2
12699 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
12700 MINT(20+JT)=ISIGN(IB,I)
12701 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12702 IF(RVCKM.LE.0D0) GOTO 450
12703 440 CONTINUE
12704 ELSE
12705 IB=2*((IA+1)/2)-1+MOD(IA,2)
12706 MINT(20+JT)=ISIGN(IB,I)
12707 ENDIF
12708 450 CONTINUE
12709 KCC=22
12710 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
12711 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
12712
12713 ELSEIF(ISUB.EQ.353) THEN
12714C...f + fbar -> Z_R0
12715 KFRES=KFPR(ISUB,1)
12716
12717 ELSEIF(ISUB.EQ.354) THEN
12718C...f + fbar' -> W+/-
12719 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12720 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12721 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12722
12723 ENDIF
12724
12725 ELSEIF(ISUB.LE.380) THEN
12726
12727 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
12728C...f + fbar -> charged+ charged- technicolor
12729 KSW=(-1)**INT(1.5D0+PYR(0))
12730 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
12731 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
12732
12733 ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
12734C...f + fbar -> neutral neutral technicolor
12735 MINT(21)=KFPR(ISUB,1)
12736 MINT(22)=KFPR(ISUB,2)
12737
12738 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
12739C...f + fbar' -> neutral charged technicolor
12740 IN=1
12741 IC=2
12742 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12743 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12744 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12745 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12746 MINT(20+JS)=KFPR(ISUB,IN)
12747
12748 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
12749C...f + fbar' -> charged neutral technicolor
12750 IN=2
12751 IC=1
12752 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12753 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12754 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12755 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12756 MINT(23-JS)=KFPR(ISUB,IN)
12757 ENDIF
12758
12759 ELSEIF(ISUB.LE.400) THEN
12760 IF(ISUB.EQ.381) THEN
12761C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12762 KCC=MINT(2)
12763 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12764
12765 ELSEIF(ISUB.EQ.382) THEN
12766C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12767 MINT(21)=ISIGN(KFLF,MINT(15))
12768 MINT(22)=-MINT(21)
12769 KCC=4
12770
12771 ELSEIF(ISUB.EQ.383) THEN
12772C...f + fbar -> g + g; th arbitrary, TC extensions
12773 MINT(21)=21
12774 MINT(22)=21
12775 KCC=MINT(2)+4
12776
12777 ELSEIF(ISUB.EQ.384) THEN
12778C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12779 IF(MINT(15).EQ.21) JS=2
12780 KCC=MINT(2)+6
12781 IF(MINT(15).EQ.21) KCC=KCC+2
12782 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12783 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12784
12785 ELSEIF(ISUB.EQ.385) THEN
12786C...g + g -> f + fbar; th arbitrary, TC extensions
12787 KCS=(-1)**INT(1.5D0+PYR(0))
12788 MINT(21)=ISIGN(KFLF,KCS)
12789 MINT(22)=-MINT(21)
12790 KCC=MINT(2)+10
12791
12792 ELSEIF(ISUB.EQ.386) THEN
12793C...g + g -> g + g; th arbitrary, TC extensions
12794 KCC=MINT(2)+12
12795 KCS=(-1)**INT(1.5D0+PYR(0))
12796
12797 ELSEIF(ISUB.EQ.387) THEN
12798C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12799 MINT(21)=ISIGN(MINT(55),MINT(15))
12800 MINT(22)=-MINT(21)
12801 KCC=4
12802
12803 ELSEIF(ISUB.EQ.388) THEN
12804C...g + g -> Q + Qbar; th arbitrary, TC extensions
12805 KCS=(-1)**INT(1.5D0+PYR(0))
12806 MINT(21)=ISIGN(MINT(55),KCS)
12807 MINT(22)=-MINT(21)
12808 KCC=MINT(2)+10
12809
12810 ELSEIF(ISUB.EQ.391) THEN
12811C...f + fbar -> G*.
12812 KFRES=KFPR(ISUB,1)
12813
12814 ELSEIF(ISUB.EQ.392) THEN
12815C...g + g -> G*.
12816 KCC=21
12817 KFRES=KFPR(ISUB,1)
12818
12819 ELSEIF(ISUB.EQ.393) THEN
12820C...q + qbar -> g + G*; th arbitrary.
12821 IF(PYR(0).GT.0.5D0) JS=2
12822 MINT(20+JS)=KFPR(ISUB,1)
12823 MINT(23-JS)=KFPR(ISUB,2)
12824 KCC=17+JS
12825
12826 ELSEIF(ISUB.EQ.394) THEN
12827C...q + g -> q + G*; th = (p(f) - p(f))**2
12828 IF(MINT(15).EQ.21) JS=2
12829 MINT(23-JS)=KFPR(ISUB,2)
12830 KCC=15+JS
12831 KCS=ISIGN(1,MINT(14+JS))
12832
12833 ELSEIF(ISUB.EQ.395) THEN
12834C...g + g -> G* + g; th arbitrary.
12835 IF(PYR(0).GT.0.5D0) JS=2
12836 MINT(23-JS)=KFPR(ISUB,2)
12837 KCC=22+JS
12838 ENDIF
12839
12840 ELSEIF(ISUB.LE.420) THEN
12841 IF(ISUB.EQ.401) THEN
12842C...g + g -> t + b + H+/-
12843 KCS=(-1)**INT(1.5D0+PYR(0))
12844 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
12845 MINT(22)=ISIGN(5,-KCS)
12846 KCC=11+INT(0.5D0+PYR(0))
12847 KFRES=ISIGN(KFHIGG,-KCS)
12848
12849 ELSEIF(ISUB.EQ.402) THEN
12850C...q + qbar -> t + b + H+/-
12851 KFL=(-1)**INT(1.5D0+PYR(0))
12852 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
12853 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
12854 KCC=4
12855 KFRES=ISIGN(KFHIGG,-KFL*KCS)
12856 ENDIF
12857
12858C...QUARKONIA+++
12859C...Additional code by Stefan Wolf
12860 ELSEIF(ISUB.LE.430) THEN
12861 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
12862C...g + g -> QQ~[n] + g
12863C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12864C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12865C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12866C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12867C...or from ISUB.EQ.68 (for ISUB.NE.421)
12868C...[g + g -> g + g; th arbitrary]
12869 MINT(21)=KFPR(ISUBSV,1)
12870 MINT(22)=KFPR(ISUBSV,2)
12871 IF(ISUB.EQ.421) THEN
12872 KCC=24
12873 KCS=(-1)**INT(1.5D0+PYR(0))
12874 ELSE
12875 KCC=MINT(2)+12
12876 KCS=(-1)**INT(1.5D0+PYR(0))
12877 ENDIF
12878
12879 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
12880C...q + g -> q + QQ~[n]
12881C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12882C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12883C...KCC copied from ISUB.EQ.28
12884C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12885 IF(MINT(15).EQ.21) JS=2
12886 MINT(23-JS)=KFPR(ISUBSV,2)
12887 KCC=MINT(2)+6
12888 IF(MINT(15).EQ.21) KCC=KCC+2
12889 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12890 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12891
12892 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
12893C...q + q~ -> g + QQ~[n]
12894C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12895C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12896C...KCC copied from ISUB.EQ.13
12897C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12898 IF(PYR(0).GT.0.5) JS=2
12899 MINT(20+JS)=21
12900 MINT(23-JS)=KFPR(ISUBSV,2)
12901 KCC=MINT(2)+4
12902 ENDIF
12903
12904 ELSEIF(ISUB.LE.440) THEN
12905 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
12906C...g + g -> QQ~[n] + g
12907C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12908C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12909C...KCC and KCS copied from ISUB.EQ.86-89
12910C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12911 MINT(21)=KFPR(ISUBSV,1)
12912 MINT(22)=KFPR(ISUBSV,2)
12913 KCC=24
12914 KCS=(-1)**INT(1.5D0+PYR(0))
12915
12916 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
12917C...q + g -> q + QQ~[n]
12918C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12919C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12920C...KCC and KCS copied from ISUB.EQ.112
12921C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12922 IF(MINT(15).EQ.21) JS=2
12923 MINT(23-JS)=KFPR(ISUBSV,2)
12924 KCC=15+JS
12925 KCS=ISIGN(1,MINT(14+JS))
12926
12927 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
12928C...q + q~ -> g + QQ~[n]
12929C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12930C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12931C...KCC copied from ISUB.EQ.111
12932C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12933 IF(PYR(0).GT.0.5) JS=2
12934 MINT(20+JS)=21
12935 MINT(23-JS)=KFPR(ISUBSV,2)
12936 KCC=17+JS
12937C...QUARKONIA---
12938 ENDIF
12939 ELSEIF(ISUB.LE.500) THEN
12940 IF(ISUB.EQ.481.OR.ISUB.EQ.482) THEN
12941 KFRES=9900001
12942 KCRES=PYCOMP(KFRES)
12943 MCOL=KCHG(KCRES,2)
12944 MCHG=KCHG(KCRES,1)
12945 IF(KCRES.EQ.0)
12946 $ CALL PYERRM(21,"No resonance for Generic 2-> 2 Process")
12947 IDCY=MDCY(KCRES,2)
12948 IF(IDCY.EQ.0)
12949 $ CALL PYERRM(21,"No decays for resonance in Generic 2->2")
12950 KCI1=PYCOMP(MINT(15))
12951 KCI2=PYCOMP(MINT(16))
12952 ICOL1=ISIGN(KCHG(KCI1,2),MINT(15))
12953 ICOL2=ISIGN(KCHG(KCI2,2),MINT(16))
12954 KFF1=KFPR(ISUB,1)
12955 KFF2=KFPR(ISUB,2)
12956 KCF1=PYCOMP(KFF1)
12957 KCF2=PYCOMP(KFF2)
12958 JCOL1=SIGN(KCHG(KCF1,2),KFF1)
12959 IF(JCOL1.EQ.-2) JCOL1=2
12960 JCOL2=SIGN(KCHG(KCF2,2),KFF2)
12961 IF(JCOL2.EQ.-2) JCOL2=2
12962 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12963 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12964 KCHW=KCH1+KCH2
12965 KREL=1
12966 IF(MCHG.NE.0.AND.KCHW.EQ.-MCHG) KREL=-1
12967 IF(KCHG(KCF1,3).NE.0) KFF1=KFF1*KREL
12968 IF(KCHG(KCF2,3).NE.0) KFF2=KFF2*KREL
12969 IF(JCOL1.EQ.1.OR.JCOL1.EQ.-1) JCOL1=JCOL1*KREL
12970 IF(JCOL2.EQ.1.OR.JCOL2.EQ.-1) JCOL2=JCOL2*KREL
12971 IF((ICOL1.EQ.1.AND.ICOL2.EQ.-1).OR.
12972 $ (ICOL2.EQ.1.AND.ICOL1.EQ.-1)) THEN
12973 IF(PYR(0).GT.0.5D0) JS=2
12974 MINT(20+JS)=KFF1
12975 MINT(23-JS)=KFF2
12976 IF(JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN
12977
12978 ELSEIF(JCOL1.EQ.0.AND.JCOL2.EQ.2) THEN
12979 KCC=17+JS
12980 MINT(20+JS)=KFF2
12981 MINT(23-JS)=KFF1
12982 ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.0) THEN
12983 KCC=17+JS
12984 MINT(20+JS)=KFF1
12985 MINT(23-JS)=KFF2
12986 ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2.AND.MCOL.EQ.0) THEN
12987
12988 ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
12989 KCC=MINT(2)+4
12990 ELSEIF((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR.
12991 $ (JCOL1.EQ.-1.AND.JCOL2.EQ.1)) THEN
12992 IF(ICOL1.EQ.JCOL1) THEN
12993 JS=1
12994 MINT(21)=KFF1
12995 MINT(22)=KFF2
12996 ELSE
12997 JS=2
12998 MINT(21)=KFF2
12999 MINT(22)=KFF1
13000 ENDIF
13001 IF(MCOL.EQ.0) THEN
13002
13003 ELSE
13004 KCC=4
13005 ENDIF
13006 ENDIF
13007 ELSEIF((ICOL1.EQ.2.AND.(ICOL2.EQ.1.OR.ICOL2.EQ.-1)).OR.
13008 $ (ICOL2.EQ.2.AND.(ICOL1.EQ.1.OR.ICOL1.EQ.-1))) THEN
13009 IF((JCOL1.EQ.2.AND.ABS(JCOL2).EQ.1).OR.
13010 $ (JCOL2.EQ.2.AND.ABS(JCOL1).EQ.1)) THEN
13011 IF(MINT(15).EQ.21) JS=2
13012 KCC=MINT(2)+6
13013 IF(MINT(15).EQ.21) KCC=KCC+2
13014 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
13015 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
13016 IF(JCOL1.EQ.2) THEN
13017 MINT(20+JS)=KFF2
13018 MINT(23-JS)=KFF1
13019 ELSE
13020 MINT(20+JS)=KFF1
13021 MINT(23-JS)=KFF2
13022 ENDIF
13023 ELSEIF((ABS(JCOL1).EQ.1.AND.JCOL2.EQ.0).OR.
13024 $ (ABS(JCOL2).EQ.1.AND.JCOL1.EQ.0)) THEN
13025 IF(MINT(15).EQ.21) JS=2
13026 KCC=15+JS
13027 KCS=ISIGN(1,MINT(14+JS))
13028 IF(JCOL1.EQ.0) THEN
13029 MINT(23-JS)=KFF1
13030 MINT(20+JS)=KFF2
13031 ELSE
13032 MINT(23-JS)=KFF2
13033 MINT(20+JS)=KFF1
13034 ENDIF
13035 ENDIF
13036 ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13037 $ JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN
13038 IF(PYR(0).GT.0.5D0) JS=2
13039 KCC=21
13040 MINT(20+JS)=KFF1
13041 MINT(23-JS)=KFF2
13042 ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13043 $ ((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR.
13044 $ ((JCOL2.EQ.0.AND.JCOL1.EQ.2)))) THEN
13045 IF(PYR(0).GT.0.5D0) JS=2
13046 KCC=22+JS
13047 KCS=(-1)**INT(1.5D0+PYR(0))
13048 IF(JCOL1.EQ.0) THEN
13049 MINT(23-JS)=KFF1
13050 MINT(20+JS)=KFF2
13051 ELSE
13052 MINT(23-JS)=KFF2
13053 MINT(20+JS)=KFF1
13054 ENDIF
13055 ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13056 $ ((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR.
13057 $ ((JCOL2.EQ.1.AND.JCOL1.EQ.-1)))) THEN
13058C....two choices, 0 or 2 depending upon mother properties
13059 IF(MCOL.EQ.2) THEN
13060 KCS=(-1)**INT(1.5D0+PYR(0))
13061 KCC=MINT(2)+10
13062 IF(JCOL1.EQ.1) THEN
13063 MINT(21)=KFF1*KCS
13064 MINT(22)=KFF2*KCS
13065 ELSE
13066 MINT(22)=KFF1*KCS
13067 MINT(21)=KFF2*KCS
13068 ENDIF
13069c MINT(20+JS)=KFF1*KCS
13070c MINT(23-JS)=KFF2*KCS
13071 ELSEIF(MCOL.EQ.0) THEN
13072 KCC=21
13073 MINT(20+JS)=KFF1*KCS
13074 MINT(23-JS)=KFF2*KCS
13075 ENDIF
13076
13077 ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13078 $ JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
13079C....two choices, 0 or 2 depending upon mother properties
13080 IF(MCOL.EQ.0) THEN
13081 KCC=21
13082 IF(PYR(0).GT.0.5D0) JS=2
13083 MINT(20+JS)=KFF1
13084 MINT(23-JS)=KFF2
13085 ELSEIF(MCOL.EQ.2) THEN
13086 IF(PYR(0).GT.0.5D0) JS=2
13087 KCC=MINT(2)+12
13088 KCS=(-1)**INT(1.5D0+PYR(0))
13089 MINT(20+JS)=KFF1
13090 MINT(23-JS)=KFF2
13091 ENDIF
13092 ELSEIF((ICOL1.EQ.1.AND.ICOL2.EQ.1).OR.
13093 $ (ICOL1.EQ.-1.AND.ICOL2.EQ.-1)) THEN
13094 KCC=MINT(2)
13095 IF(PYR(0).GT.0.5D0) JS=2
13096 MINT(20+JS)=KFF1
13097 MINT(23-JS)=KFF2
13098 ELSEIF(ICOL1.EQ.0.AND.ICOL2.EQ.0.AND.MCOL.EQ.0) THEN
13099 KCC=20
13100 IF(PYR(0).GT.0.5D0) JS=2
13101 MINT(20+JS)=KFF1
13102 MINT(23-JS)=KFF2
13103 ELSE
13104 CALL PYERRM(21,"PYSCAT: No recognized Generic Process")
13105 ENDIF
13106 IF(ISUBSV.EQ.482) KFRES=0
13107 ENDIF
13108 ENDIF
13109
13110 IF(ISET(ISUB).EQ.11) THEN
13111C...Store documentation for user-defined processes
13112 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
13113 KUPPO(1)=MINT(83)+5
13114 KUPPO(2)=MINT(83)+6
13115 I=MINT(83)+6
13116 DO 470 IUP=3,NUP
13117 KUPPO(IUP)=0
13118 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
13119 IDOC=IDOC-1
13120 MINT(4)=MINT(4)-1
13121 GOTO 470
13122 ENDIF
13123 I=I+1
13124 KUPPO(IUP)=I
13125 K(I,1)=21
13126 K(I,2)=IDUP(IUP)
13127 IF(IDUP(IUP).EQ.0) K(I,2)=90
13128 K(I,3)=0
13129 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
13130 K(I,4)=0
13131 K(I,5)=0
13132 DO 460 J=1,5
13133 P(I,J)=PUP(J,IUP)
13134 460 CONTINUE
13135 V(I,5)=VTIMUP(IUP)
13136 470 CONTINUE
13137 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
13138 & -BEZUP)
13139
13140C...Store final state partons for user-defined processes
13141 N=IPU2
13142 DO 490 IUP=3,NUP
13143 N=N+1
13144 K(N,1)=1
13145 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
13146 K(N,2)=IDUP(IUP)
13147 IF(IDUP(IUP).EQ.0) K(N,2)=90
13148 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
13149 K(N,3)=KUPPO(IUP)
13150 ELSE
13151 K(N,3)=MINT(84)+MOTHUP(1,IUP)
13152 ENDIF
13153 K(N,4)=0
13154 K(N,5)=0
13155C...Search for daughters of intermediate colourless particles.
13156 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
13157 DO 475 IUPDAU=IUP+1,NUP
13158 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
13159 & N+IUPDAU-IUP
13160 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
13161 475 CONTINUE
13162 ENDIF
13163 DO 480 J=1,5
13164 P(N,J)=PUP(J,IUP)
13165 480 CONTINUE
13166 V(N,5)=VTIMUP(IUP)
13167 490 CONTINUE
13168 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
13169
13170C...Arrange colour flow for user-defined processes
13171 NLBL=0
13172 DO 540 IUP1=1,NUP
13173 I1=MINT(84)+IUP1
13174 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
13175 IF(K(I1,1).EQ.1) K(I1,1)=3
13176 IF(K(I1,1).EQ.11) K(I1,1)=14
13177C...Find a not yet considered colour/anticolour line.
13178 DO 530 ISDE1=1,2
13179 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
13180 NMAT=0
13181 DO 500 ILBL=1,NLBL
13182 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
13183 500 CONTINUE
13184 IF(NMAT.EQ.0) THEN
13185 NLBL=NLBL+1
13186 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
13187C...Find all others belonging to same line.
13188 I3=I1
13189 I4=0
13190 DO 520 IUP2=IUP1+1,NUP
13191 I2=MINT(84)+IUP2
13192 DO 510 ISDE2=1,2
13193 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
13194 IF(ISDE2.EQ.ISDE1) THEN
13195 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
13196 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
13197 I3=I2
13198 ELSEIF(I4.NE.0) THEN
13199 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
13200 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
13201 I4=I2
13202 ELSEIF(IUP2.LE.2) THEN
13203 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
13204 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
13205 I4=I2
13206 ELSE
13207 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
13208 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
13209 I4=I2
13210 ENDIF
13211 ENDIF
13212 510 CONTINUE
13213 520 CONTINUE
13214 ENDIF
13215 530 CONTINUE
13216 540 CONTINUE
13217
13218 ELSEIF(IDOC.EQ.7) THEN
13219C...Resonance not decaying; store kinematics
13220 I=MINT(83)+7
13221 K(IPU3,1)=1
13222 K(IPU3,2)=KFRES
13223 K(IPU3,3)=I
13224 P(IPU3,4)=SHUSER
13225 P(IPU3,5)=SHUSER
13226 K(I,1)=21
13227 K(I,2)=KFRES
13228 P(I,4)=SHUSER
13229 P(I,5)=SHUSER
13230 N=IPU3
13231 MINT(21)=KFRES
13232 MINT(22)=0
13233
13234C...Special cases: colour flow in coloured resonances
13235 KCRES=PYCOMP(KFRES)
13236 IF(KCHG(KCRES,2).NE.0) THEN
13237 K(IPU3,1)=3
13238 DO 550 J=1,2
13239 JC=J
13240 IF(KCS.EQ.-1) JC=3-J
13241 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13242 & MINT(84)+ICOL(KCC,1,JC)
13243 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13244 & MINT(84)+ICOL(KCC,2,JC)
13245 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
13246 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13247 550 CONTINUE
13248 ELSE
13249 K(IPU1,4)=IPU2
13250 K(IPU1,5)=IPU2
13251 K(IPU2,4)=IPU1
13252 K(IPU2,5)=IPU1
13253 ENDIF
13254
13255 ELSEIF(IDOC.EQ.8) THEN
13256C...2 -> 2 processes: store outgoing partons in their CM-frame
13257 DO 560 JT=1,2
13258 I=MINT(84)+2+JT
13259 KCA=PYCOMP(MINT(20+JT))
13260 K(I,1)=1
13261 IF(KCHG(KCA,2).NE.0) K(I,1)=3
13262 K(I,2)=MINT(20+JT)
13263 K(I,3)=MINT(83)+IDOC+JT-2
13264 KFAA=IABS(K(I,2))
13265 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
13266 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13267 ELSE
13268 P(I,5)=PYMASS(K(I,2))
13269 ENDIF
13270 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
13271 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
13272 560 CONTINUE
13273 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
13274 KFA1=IABS(MINT(21))
13275 KFA2=IABS(MINT(22))
13276 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
13277 & THEN
13278 MINT(51)=1
13279 RETURN
13280 ENDIF
13281 P(IPU3,5)=0D0
13282 P(IPU4,5)=0D0
13283 ENDIF
13284 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
13285 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
13286 P(IPU4,4)=SHR-P(IPU3,4)
13287 P(IPU4,3)=-P(IPU3,3)
13288 N=IPU4
13289 MINT(7)=MINT(83)+7
13290 MINT(8)=MINT(83)+8
13291
13292C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
13293 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
13294
13295 ELSEIF(IDOC.EQ.9) THEN
13296C...2 -> 3 processes: store outgoing partons in their CM frame
13297 DO 570 JT=1,2
13298 I=MINT(84)+2+JT
13299 KCA=PYCOMP(MINT(20+JT))
13300 K(I,1)=1
13301 IF(KCHG(KCA,2).NE.0) K(I,1)=3
13302 K(I,2)=MINT(20+JT)
13303 K(I,3)=MINT(83)+IDOC+JT-3
13304 JTA=JT
13305C...t and b in opposide order in event list as compared to
13306C...matrix element?
13307 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
13308 IF(IABS(K(I,2)).LE.22) THEN
13309 P(I,5)=PYMASS(K(I,2))
13310 ELSE
13311 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
13312 ENDIF
13313 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
13314 P(I,1)=PT*COS(VINT(198+5*JTA))
13315 P(I,2)=PT*SIN(VINT(198+5*JTA))
13316 570 CONTINUE
13317 K(IPU5,1)=1
13318 K(IPU5,2)=KFRES
13319 K(IPU5,3)=MINT(83)+IDOC
13320 P(IPU5,5)=SHR
13321 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13322 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13323 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
13324 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
13325 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
13326 PMT3=SQRT(PMS3)
13327 P(IPU5,3)=PMT3*SINH(VINT(211))
13328 P(IPU5,4)=PMT3*COSH(VINT(211))
13329 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
13330 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
13331 IF(SQL12.LE.0D0) THEN
13332 MINT(51)=1
13333 RETURN
13334 ENDIF
13335 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
13336 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13337 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
13338 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
13339C...t and b in opposide order in event list as compared to
13340C...matrix element
13341 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
13342 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13343 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
13344 END IF
13345 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
13346 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
13347 MINT(23)=KFRES
13348 N=IPU5
13349 MINT(7)=MINT(83)+7
13350 MINT(8)=MINT(83)+8
13351
13352 ELSEIF(IDOC.EQ.11) THEN
13353C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
13354 PHI(1)=PARU(2)*PYR(0)
13355 PHI(2)=PHI(1)-PHIR
13356 DO 580 JT=1,2
13357 I=MINT(84)+2+JT
13358 K(I,1)=1
13359 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13360 K(I,2)=MINT(20+JT)
13361 K(I,3)=MINT(83)+IDOC+JT-2
13362 P(I,5)=PYMASS(K(I,2))
13363 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
13364 MINT(51)=1
13365 RETURN
13366 ENDIF
13367 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13368 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13369 P(I,1)=PTABS*COS(PHI(JT))
13370 P(I,2)=PTABS*SIN(PHI(JT))
13371 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13372 P(I,4)=0.5D0*SHPR*Z(JT)
13373 IZW=MINT(83)+6+JT
13374 K(IZW,1)=21
13375 K(IZW,2)=23
13376 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
13377 K(IZW,3)=IZW-2
13378 P(IZW,1)=-P(I,1)
13379 P(IZW,2)=-P(I,2)
13380 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13381 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13382 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13383 580 CONTINUE
13384 I=MINT(83)+9
13385 K(IPU5,1)=1
13386 K(IPU5,2)=KFRES
13387 K(IPU5,3)=I
13388 P(IPU5,5)=SHR
13389 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13390 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13391 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
13392 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
13393 K(I,1)=21
13394 K(I,2)=KFRES
13395 DO 590 J=1,5
13396 P(I,J)=P(IPU5,J)
13397 590 CONTINUE
13398 N=IPU5
13399 MINT(23)=KFRES
13400
13401 ELSEIF(IDOC.EQ.12) THEN
13402C...Z0 and W+/- scattering: store bosons and outgoing partons
13403 PHI(1)=PARU(2)*PYR(0)
13404 PHI(2)=PHI(1)-PHIR
13405 JTRAN=INT(1.5D0+PYR(0))
13406 DO 600 JT=1,2
13407 I=MINT(84)+2+JT
13408 K(I,1)=1
13409 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13410 K(I,2)=MINT(20+JT)
13411 K(I,3)=MINT(83)+IDOC+JT-2
13412 P(I,5)=PYMASS(K(I,2))
13413 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
13414 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13415 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13416 P(I,1)=PTABS*COS(PHI(JT))
13417 P(I,2)=PTABS*SIN(PHI(JT))
13418 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13419 P(I,4)=0.5D0*SHPR*Z(JT)
13420 IZW=MINT(83)+6+JT
13421 K(IZW,1)=21
13422 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
13423 K(IZW,2)=23
13424 ELSE
13425 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
13426 ENDIF
13427 K(IZW,3)=IZW-2
13428 P(IZW,1)=-P(I,1)
13429 P(IZW,2)=-P(I,2)
13430 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13431 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13432 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13433 IPU=MINT(84)+4+JT
13434 K(IPU,1)=3
13435 K(IPU,2)=KFPR(ISUB,JT)
13436 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
13437 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
13438 K(IPU,3)=MINT(83)+8+JT
13439 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
13440 P(IPU,5)=PYMASS(K(IPU,2))
13441 ELSE
13442 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13443 ENDIF
13444 MINT(22+JT)=K(IPU,2)
13445 600 CONTINUE
13446C...Find rotation and boost for hard scattering subsystem
13447 I1=MINT(83)+7
13448 I2=MINT(83)+8
13449 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
13450 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
13451 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
13452 GAMCM=(P(I1,4)+P(I2,4))/SHR
13453 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
13454 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
13455 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
13456 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
13457 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
13458 PHICM=PYANGL(PX,PY)
13459C...Store hard scattering subsystem. Rotate and boost it
13460 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
13461 & P(IPU6,5)**2
13462 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
13463 CTHWZ=VINT(23)
13464 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
13465 PHIWZ=VINT(24)-PHICM
13466 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
13467 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
13468 P(IPU5,3)=PABS*CTHWZ
13469 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
13470 P(IPU6,1)=-P(IPU5,1)
13471 P(IPU6,2)=-P(IPU5,2)
13472 P(IPU6,3)=-P(IPU5,3)
13473 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
13474 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
13475 DO 620 JT=1,2
13476 I1=MINT(83)+8+JT
13477 I2=MINT(84)+4+JT
13478 K(I1,1)=21
13479 K(I1,2)=K(I2,2)
13480 DO 610 J=1,5
13481 P(I1,J)=P(I2,J)
13482 610 CONTINUE
13483 620 CONTINUE
13484 N=IPU6
13485 MINT(7)=MINT(83)+9
13486 MINT(8)=MINT(83)+10
13487 ENDIF
13488
13489 IF(ISET(ISUB).EQ.11) THEN
13490 ELSEIF(IDOC.GE.8) THEN
13491C...Store colour connection indices
13492 DO 630 J=1,2
13493 JC=J
13494 IF(KCS.EQ.-1) JC=3-J
13495 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13496 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
13497 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13498 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
13499 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
13500 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13501 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13502 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13503 630 CONTINUE
13504
13505C...Copy outgoing partons to documentation lines
13506 IMAX=2
13507 IF(IDOC.EQ.9) IMAX=3
13508 DO 650 I=1,IMAX
13509 I1=MINT(83)+IDOC-IMAX+I
13510 I2=MINT(84)+2+I
13511 K(I1,1)=21
13512 K(I1,2)=K(I2,2)
13513 IF(IDOC.LE.9) K(I1,3)=0
13514 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
13515 DO 640 J=1,5
13516 P(I1,J)=P(I2,J)
13517 640 CONTINUE
13518 650 CONTINUE
13519
13520 ELSEIF(IDOC.EQ.9) THEN
13521C...Store colour connection indices
13522 DO 660 J=1,2
13523 JC=J
13524 IF(KCS.EQ.-1) JC=3-J
13525 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13526 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
13527 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
13528 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13529 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
13530 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
13531 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13532 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13533 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
13534 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13535 660 CONTINUE
13536
13537C...Copy outgoing partons to documentation lines
13538 DO 680 I=1,3
13539 I1=MINT(83)+IDOC-3+I
13540 I2=MINT(84)+2+I
13541 K(I1,1)=21
13542 K(I1,2)=K(I2,2)
13543 K(I1,3)=0
13544 DO 670 J=1,5
13545 P(I1,J)=P(I2,J)
13546 670 CONTINUE
13547 680 CONTINUE
13548 ENDIF
13549
13550C...Copy outgoing partons to list of allowed radiators.
13551 NPART=0
13552 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
13553 DO 690 I=MINT(84)+3,N
13554 NPART=NPART+1
13555 IPART(NPART)=I
13556 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
13557 690 CONTINUE
13558 ENDIF
13559
13560C...Low-pT events: remove gluons used for string drawing purposes
13561 IF(ISUB.EQ.95) THEN
13562 IF(MINT(35).LE.1) THEN
13563 K(IPU3,1)=K(IPU3,1)+10
13564 K(IPU4,1)=K(IPU4,1)+10
13565 ENDIF
13566 DO 700 J=41,66
13567 VINTSV(J)=VINT(J)
13568 VINT(J)=0D0
13569 700 CONTINUE
13570 DO 720 I=MINT(83)+5,MINT(83)+8
13571 DO 710 J=1,5
13572 P(I,J)=0D0
13573 710 CONTINUE
13574 720 CONTINUE
13575 ENDIF
13576
13577 RETURN
13578 END
13579
13580C***********************************************************************
13581
13582C...PYEVOL
13583C...Handles intertwined pT-ordered spacelike initial-state parton
13584C...and multiple interactions.
13585
13586 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
13587C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
13588C...MODE = 0 : (Re-)initialize ISR/MI evolution.
13589C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
13590
13591C...Double precision and integer declarations.
13592 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13593 IMPLICIT INTEGER(I-N)
13594 INTEGER PYK,PYCHGE,PYCOMP
13595C...External
13596 EXTERNAL PYALPS
13597 DOUBLE PRECISION PYALPS
13598C...Parameter statement for maximum size of showers.
13599 PARAMETER (MAXNUR=1000)
13600C...Commonblocks.
13601 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13602 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13603 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13604 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13605 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13606 COMMON/PYINT1/MINT(400),VINT(400)
13607 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13608 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13609 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
13610 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
13611 & XMI(2,240),PT2MI(240),IMISEP(0:240)
13612 COMMON/PYCTAG/NCT,MCT(4000,2)
13613 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
13614 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
13615 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
13616C...Local arrays and saved variables.
13617 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
13618 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
13619 & ,PSAV,KSAV,VSAV
13620
13621 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
13622 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
13623
13624C----------------------------------------------------------------------
13625C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
13626C...done only once per event, while MODE=0 is repeated each time the
13627C...evolution needs to be restarted.
13628 IF (MODE.EQ.-1) THEN
13629 ISUBHD=MINT(1)
13630 NSAV=N
13631 NPARTS=NPART
13632C...Store hard scattering variables
13633 M15SV=MINT(15)
13634 M16SV=MINT(16)
13635 M21SV=MINT(21)
13636 M22SV=MINT(22)
13637 DO 100 J=11,80
13638 VINTSV(J)=VINT(J)
13639 100 CONTINUE
13640 DO 120 J=1,5
13641 DO 110 IS=1,4
13642 I=IS+MINT(84)
13643 PSAV(IS,J)=P(I,J)
13644 KSAV(IS,J)=K(I,J)
13645 VSAV(IS,J)=V(I,J)
13646 110 CONTINUE
13647 120 CONTINUE
13648
13649C...Set shat for hardest scattering
13650 SHAT(1)=VINT(44)
13651 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
13652 & *VINT(2)
13653
13654C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
13655 RMC=PMAS(4,1)
13656 RMB=PMAS(5,1)
13657 ALAM4=PARP(61)
13658 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
13659 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
13660 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
13661
13662C----------------------------------------------------------------------
13663C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
13664C...interaction initiators, with no previous evolution. Check the input
13665C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
13666C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
13667C...smaller than the CM energy / 2.)
13668 ELSEIF (MODE.EQ.0) THEN
13669C...Reset counters and switches
13670 N=NSAV
13671 NPART=NPARTS
13672 MINT(30)=0
13673 MINT(31)=1
13674 MINT(36)=1
13675C...Reset hard scattering variables
13676 MINT(1)=ISUBHD
13677 DO 130 J=11,80
13678 VINT(J)=VINTSV(J)
13679 130 CONTINUE
13680 DO 150 J=1,5
13681 DO 140 IS=1,4
13682 I=IS+MINT(84)
13683 P(I,J)=PSAV(IS,J)
13684 K(I,J)=KSAV(IS,J)
13685 V(I,J)=VSAV(IS,J)
13686 P(MINT(83)+4+IS,J)=PSAV(IS,J)
13687 V(MINT(83)+4+IS,J)=VSAV(IS,J)
13688 140 CONTINUE
13689 150 CONTINUE
13690C...Reset statistics on activity in event.
13691 DO 160 J=351,359
13692 MINT(J)=0
13693 VINT(J)=0D0
13694 160 CONTINUE
13695C...Reset extra companion reweighting factor
13696 VINT(140)=1D0
13697
13698C...We do not generate MI for soft process (ISUB=95), but the
13699C...initialization must be done regardless, for later purposes.
13700 MINT(36)=1
13701
13702C...Initialize multiple interactions.
13703 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
13704 IF(MINT(51).NE.0) RETURN
13705
13706C...Decide whether quarks in hard scattering were valence or sea
13707 PT2HD=VINT(54)
13708 DO 170 JS=1,2
13709 MINT(30)=JS
13710 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
13711 IF(MINT(51).NE.0) RETURN
13712 170 CONTINUE
13713
13714C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
13715 VINT(18)=0D0
13716 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
13717 IF (MSTP(70).EQ.2) THEN
13718C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
13719 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
13720 ELSEIF (MSTP(70).EQ.3) THEN
13721C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73)
13722 ALPHA0 = MAX(1D-6,PARP(73))
13723 Q20 = ALAM3**2/PARP(64)
13724 IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2
13725 VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0)
13726 ENDIF
13727C...Also store PT2MIN in VINT(17).
13728 180 VINT(17)=PT2MIN
13729
13730C...Set FS masses zero now.
13731 VINT(63)=0D0
13732 VINT(64)=0D0
13733
13734C...Initialize IS showers with VINT(56) as max scale.
13735 PT2ISR=VINT(56)
13736 PT20=PT2MIN
13737 IF (MSTP(70).EQ.0) THEN
13738 PT20=MAX(PT2MIN,PARP(62)**2)
13739 ELSEIF (MSTP(70).EQ.1) THEN
13740 PT20=MAX(PT2MIN,(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13741 ENDIF
13742 CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL)
13743 IF(MINT(51).NE.0) RETURN
13744
13745 RETURN
13746
13747C----------------------------------------------------------------------
13748C...MODE= 1: Evolve event from PTMAX to PTMIN.
13749 ELSEIF (MODE.EQ.1) THEN
13750
13751C...Skip if no phase space.
13752 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
13753
13754C...Starting pT2 max scale (to be udpated successively).
13755 PT2CMX=PT2MAX
13756
13757C...Evolve two sides of the event to find which branches at highest pT.
13758 200 JSMX=-1
13759 MIMX=0
13760 PT2MX=0D0
13761
13762C...Loop over current shower initiators.
13763 IF (MSTP(61).GE.1) THEN
13764 DO 230 MI=1,MINT(31)
13765 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
13766 ISUB=96
13767 IF (MI.EQ.1) ISUB=ISUBHD
13768 MINT(1)=ISUB
13769 MINT(36)=MI
13770C...Set up shat, initiator x values, and x remaining in BR.
13771 VINT(44)=SHAT(MI)
13772 VINT(141)=XMI(1,MI)
13773 VINT(142)=XMI(2,MI)
13774 VINT(143)=1D0
13775 VINT(144)=1D0
13776 DO 210 JI=1,MINT(31)
13777 IF (JI.EQ.MINT(36)) GOTO 210
13778 VINT(143)=VINT(143)-XMI(1,JI)
13779 VINT(144)=VINT(144)-XMI(2,JI)
13780 210 CONTINUE
13781C...Loop over sides.
13782C...Generate trial branchings for this interaction. The hardest
13783C...branching so far is automatically updated if necessary in /PYISMX/.
13784 DO 220 JS=1,2
13785 MINT(30)=JS
13786 PT20=PT2MIN
13787 IF (MSTP(70).EQ.0) THEN
13788 PT20=MAX(PT2MIN,PARP(62)**2)
13789 ELSEIF (MSTP(70).EQ.1) THEN
13790 PT20=MAX(PT2MIN,
13791 & (PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13792 ENDIF
13793 CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL)
13794 IF (MINT(51).NE.0) RETURN
13795 220 CONTINUE
13796 230 CONTINUE
13797 ENDIF
13798
13799C...Generate trial additional interaction.
13800 MINT(36)=MINT(31)+1
13801 240 IF (MOD(MSTP(81),10).GE.1) THEN
13802 MINT(1)=96
13803C...Set up X remaining in BR.
13804 VINT(143)=1D0
13805 VINT(144)=1D0
13806 DO 250 JI=1,MINT(31)
13807 VINT(143)=VINT(143)-XMI(1,JI)
13808 VINT(144)=VINT(144)-XMI(2,JI)
13809 250 CONTINUE
13810C...Generate trial interaction
13811 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13812 IF (MINT(51).EQ.1) RETURN
13813 ENDIF
13814
13815C...And the winner is:
13816 IF (PT2MX.LT.PT2MIN) THEN
13817 GOTO 330
13818 ELSEIF (JSMX.EQ.0) THEN
13819C...Accept additional interaction (may still fail).
13820 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13821 IF(MINT(51).NE.0) RETURN
13822 IF (IFAIL.EQ.0) THEN
13823 SHAT(MINT(36))=VINT(44)
13824C...Decide on flavours (valence/sea/companion).
13825 DO 270 JS=1,2
13826 MINT(30)=JS
13827 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13828 IF(MINT(51).NE.0) RETURN
13829 270 CONTINUE
13830 ENDIF
13831 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
13832C...Reconstruct kinematics of acceptable ISR branching.
13833C...Set up shat, initiator x values, and x remaining in BR.
13834 MINT(30)=JSMX
13835 MINT(36)=MIMX
13836 VINT(44)=SHAT(MINT(36))
13837 VINT(141)=XMI(1,MINT(36))
13838 VINT(142)=XMI(2,MINT(36))
13839 VINT(143)=1D0
13840 VINT(144)=1D0
13841 DO 280 JI=1,MINT(31)
13842 IF (JI.EQ.MINT(36)) GOTO 280
13843 VINT(143)=VINT(143)-XMI(1,JI)
13844 VINT(144)=VINT(144)-XMI(2,JI)
13845 280 CONTINUE
13846 PT2NEW=PT2MX
13847 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
13848 IF (MINT(51).EQ.1) RETURN
13849 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
13850C...Bookeep joining. Cannot (yet) be constructed kinematically.
13851 MINT(354)=MINT(354)+1
13852 VINT(354)=VINT(354)+SQRT(PT2MX)
13853 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
13854 MJOIND(JSMX-2,MJN1MX)=MJN2MX
13855 MJOIND(JSMX-2,MJN2MX)=MJN1MX
13856 ENDIF
13857
13858C...Update PT2 iteration scale.
13859 PT2CMX=PT2MX
13860
13861C...Loop back to continue evolution.
13862 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13863 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
13864 ELSE
13865 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
13866 ENDIF
13867
13868C----------------------------------------------------------------------
13869C...MODE= 2: (Re-)store user information on hardest interaction etc.
13870 ELSEIF (MODE.EQ.2) THEN
13871
13872C...Revert to "ordinary" meanings of some parameters.
13873 290 DO 310 JS=1,2
13874 MINT(12+JS)=K(IMI(JS,1,1),2)
13875 VINT(140+JS)=XMI(JS,1)
13876 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
13877 VINT(142+JS)=1D0
13878 DO 300 MI=1,MINT(31)
13879 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
13880 300 CONTINUE
13881 310 CONTINUE
13882
13883C...Restore saved quantities for hardest interaction.
13884 MINT(1)=ISUBHD
13885 MINT(15)=M15SV
13886 MINT(16)=M16SV
13887 MINT(21)=M21SV
13888 MINT(22)=M22SV
13889 DO 320 J=11,80
13890 VINT(J)=VINTSV(J)
13891 320 CONTINUE
13892
13893 ENDIF
13894
13895 330 RETURN
13896 END
13897
13898C*********************************************************************
13899
13900C...PYSSPA
13901C...Generates spacelike parton showers.
13902
13903 SUBROUTINE PYSSPA(IPU1,IPU2)
13904
13905C...Double precision and integer declarations.
13906 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13907 IMPLICIT INTEGER(I-N)
13908 INTEGER PYK,PYCHGE,PYCOMP
13909 PARAMETER (MAXNUR=1000)
13910C...Commonblocks.
13911 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13912 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13913 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13914 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13915 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13916 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13917 COMMON/PYINT1/MINT(400),VINT(400)
13918 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13919 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13920 COMMON/PYCTAG/NCT,MCT(4000,2)
13921 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,
13922 &/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/
13923C...Local arrays and data.
13924 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
13925 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
13926 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
13927 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
13928 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
13929 DATA IS/2*0/
13930
13931C...Read out basic information; set global Q^2 scale.
13932 IPUS1=IPU1
13933 IPUS2=IPU2
13934 ISUB=MINT(1)
13935 Q2MX=VINT(56)
13936 VINT2R=VINT(2)*VINT(143)*VINT(144)
13937 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
13938 &MIN(VINT2R,PARP(67)*VINT(56))
13939 FCQ2MX=1D0
13940
13941C...Define which processes ME corrections have been implemented for.
13942 MECOR=0
13943 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13944 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
13945 & ISUB.EQ.144) MECOR=1
13946 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13947 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
13948 ENDIF
13949
13950C...Initialize QCD evolution and check phase space.
13951 Q2MNC=PARP(62)**2
13952 Q2MNCS(1)=Q2MNC
13953 Q2MNCS(2)=Q2MNC
13954 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
13955 Q0S=PARP(15)**2
13956 PS=VINT(3)**2
13957 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13958 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13959 Q2INT=SQRT(Q0S*Q2EFF)
13960 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
13961 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
13962 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
13963 ENDIF
13964 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
13965 Q0S=PARP(15)**2
13966 PS=VINT(4)**2
13967 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13968 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13969 Q2INT=SQRT(Q0S*Q2EFF)
13970 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
13971 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
13972 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
13973 ENDIF
13974 MCEV=0
13975 ALAMS=PARU(112)
13976 PARU(112)=PARP(61)
13977 FQ2C=1D0
13978 TCMX=0D0
13979 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
13980 MCEV=1
13981 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
13982 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
13983 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
13984 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
13985 & MCEV=0
13986 ENDIF
13987
13988C...Initialize QED evolution and check phase space.
13989 MEEV=0
13990 XEE=1D-10
13991 SPME=PMAS(11,1)**2
13992 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
13993 &SPME=PMAS(13,1)**2
13994 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
13995 &SPME=PMAS(15,1)**2
13996 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
13997 TEMX=0D0
13998 FWTE=10D0
13999 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
14000 MEEV=1
14001 TEMX=LOG(Q2MX/SPME)
14002 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
14003 ENDIF
14004 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
14005 MEEV=2
14006 TEMX=TCMX
14007 FWTE=1D0
14008 ENDIF
14009 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
14010
14011C...Loopback point in case of failure to reconstruct kinematics.
14012 NS=N
14013 NPARTS=NPART
14014 LOOP=0
14015 MNT352=MINT(352)
14016 MNT353=MINT(353)
14017 VNT352=VINT(352)
14018 VNT353=VINT(353)
14019 100 LOOP=LOOP+1
14020 IF(LOOP.GT.100) THEN
14021 MINT(51)=1
14022 RETURN
14023 ENDIF
14024 N=NS
14025 NPART=NPARTS
14026 MINT(352)=MNT352
14027 MINT(353)=MNT353
14028 VINT(352)=VNT352
14029 VINT(353)=VNT353
14030
14031C...Initial values: flavours, momenta, virtualities.
14032 DO 120 JT=1,2
14033 MORE(JT)=1
14034 KFBEAM(JT)=MINT(10+JT)
14035 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
14036 KFLS(JT)=MINT(14+JT)
14037 KFLS(JT+2)=KFLS(JT)
14038 XS(JT)=VINT(40+JT)
14039 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
14040 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
14041 ZS(JT)=1D0
14042 Q2S(JT)=FCQ2MX*Q2MX
14043 DQ2(JT)=0D0
14044 TEVCSV(JT)=TCMX
14045 ALAM(JT)=PARP(61)
14046 THE2(JT)=1D0
14047 TEVESV(JT)=TEMX
14048 MCESV(JT)=0
14049C...Calculate initial parton distribution weights.
14050 MINT(105)=MINT(102+JT)
14051 MINT(109)=MINT(106+JT)
14052 VINT(120)=VINT(2+JT)
14053C.... ALICE
14054C.... Store side in MINT(124)
14055 MINT(124) = JT
14056C....
14057 IF(XS(JT).LT.1D0-XEE) THEN
14058 IF(MINT(31).GE.2) MINT(30)=JT
14059 IF(MSTP(57).LE.1) THEN
14060 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
14061 ELSE
14062 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
14063 ENDIF
14064 ENDIF
14065 DO 110 KFL=-25,25
14066 XFS(JT,KFL)=XFB(KFL)
14067 110 CONTINUE
14068C...Special kinematics check for c/b quarks (that g -> c cbar or
14069C...b bbar kinematically possible).
14070 KFLCB=IABS(KFLS(JT))
14071 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14072 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
14073 MINT(51)=1
14074 RETURN
14075 ENDIF
14076 ENDIF
14077 120 CONTINUE
14078 DSH=VINT(44)
14079 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
14080
14081C...Find if interference with final state partons.
14082 MFIS=0
14083 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
14084 IF(MFIS.NE.0) THEN
14085 DO 140 I=1,2
14086 KCFI(I)=0
14087 KCA=PYCOMP(IABS(KFLS(I)))
14088 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
14089 NFIS(I)=0
14090 IF(KCFI(I).NE.0) THEN
14091 IF(I.EQ.1) IPFS=IPUS1
14092 IF(I.EQ.2) IPFS=IPUS2
14093 DO 130 J=1,2
14094 ICSI=MOD(K(IPFS,3+J),MSTU(5))
14095 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
14096 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
14097 NFIS(I)=NFIS(I)+1
14098 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
14099 & P(ICSI,2)**2))
14100 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
14101 ENDIF
14102 130 CONTINUE
14103 ENDIF
14104 140 CONTINUE
14105 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
14106 ENDIF
14107
14108C...Pick up leg with highest virtuality.
14109 JTOLD=1
14110 150 N=N+1
14111 JT=1
14112 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
14113 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
14114 IF(MORE(JT).EQ.0) JT=3-JT
14115 JTOLD=JT
14116 KFLB=KFLS(JT)
14117 XB=XS(JT)
14118 DO 160 KFL=-25,25
14119 XFB(KFL)=XFS(JT,KFL)
14120 160 CONTINUE
14121 DSHR=2D0*SQRT(DSH)
14122 DSHZ=DSH/ZS(JT)
14123
14124C...Check if allowed to branch.
14125 MCEV=0
14126 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
14127 MCEV=1
14128 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
14129 IF(XB.GE.1D0-2D0*XEC) MCEV=0
14130 ENDIF
14131 MEEV=0
14132 IF(MINT(44+JT).EQ.3) THEN
14133 MEEV=1
14134 IF(XB.GE.1D0-2D0*XEE) MEEV=0
14135 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
14136 & MEEV=0
14137C***Currently kill QED shower for resolved photoproduction.
14138 IF(MINT(18+JT).EQ.1) MEEV=0
14139C***Currently kill shower for W inside electron.
14140 IF(IABS(KFLB).EQ.24) THEN
14141 MCEV=0
14142 MEEV=0
14143 ENDIF
14144 ENDIF
14145 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
14146 &MEEV=2
14147 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
14148 Q2B=0D0
14149 GOTO 260
14150 ENDIF
14151
14152C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
14153 Q2B=Q2S(JT)
14154 TEVCB=TEVCSV(JT)
14155 TEVEB=TEVESV(JT)
14156 IF(MSTP(62).LE.1) THEN
14157 IF(ZS(JT).GT.0.99999D0) THEN
14158 Q2B=Q2S(JT)
14159 ELSE
14160 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
14161 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
14162 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
14163 ENDIF
14164 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14165 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
14166 ENDIF
14167 IF(MCEV.EQ.1) THEN
14168 ALSDUM=PYALPS(FQ2C*Q2B)
14169 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
14170 ALAM(JT)=PARU(117)
14171 B0=(33D0-2D0*MSTU(118))/6D0
14172 ENDIF
14173 IF(MEEV.EQ.2) TEVEB=TEVCB
14174 TEVCBS=TEVCB
14175 TEVEBS=TEVEB
14176
14177C...Select side for interference with final state partons.
14178 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
14179 IFI=N-NS
14180 ISFI(IFI)=0
14181 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
14182 ISFI(IFI)=1
14183 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
14184 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
14185 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
14186 ISFI(IFI)=1
14187 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
14188 ENDIF
14189 ENDIF
14190
14191C...Calculate preweighting factor for ME-corrected processes.
14192 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14193
14194C...Calculate Altarelli-Parisi weights.
14195 DO 170 KFL=-25,25
14196 WTAPC(KFL)=0D0
14197 WTAPE(KFL)=0D0
14198 WTSF(KFL)=0D0
14199 170 CONTINUE
14200C...q -> q (g or gamma emission), g -> q.
14201 IF(IABS(KFLB).LE.10) THEN
14202 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
14203 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
14204 EQ2=1D0/9D0
14205 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
14206 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
14207 & (XEC*(1D0-XEC)))
14208 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14209 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
14210 WTAPC(21)=WTGF*WTAPC(21)
14211 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
14212 ENDIF
14213C...f -> f, gamma -> f.
14214 ELSEIF(IABS(KFLB).LE.20) THEN
14215 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
14216 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
14217 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
14218 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
14219 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14220 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
14221 WTAPE(22)=WTGF*WTAPE(22)
14222 ENDIF
14223C...f -> g, g -> g.
14224 ELSEIF(KFLB.EQ.21) THEN
14225 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
14226 DO 180 KFL=1,MSTP(58)
14227 WTAPC(KFL)=WTAPQ
14228 WTAPC(-KFL)=WTAPQ
14229 180 CONTINUE
14230 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
14231 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14232 DO 190 KFL=1,MSTP(58)
14233 WTAPC(KFL)=WTFG*WTAPC(KFL)
14234 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
14235 190 CONTINUE
14236 WTAPC(21)=WTGG*WTAPC(21)
14237 ENDIF
14238C...f -> gamma, W+, W-.
14239 ELSEIF(KFLB.EQ.22) THEN
14240 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
14241 WTAPE(11)=WTAPF
14242 WTAPE(-11)=WTAPF
14243 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14244 WTAPE(11)=WTFG*WTAPE(11)
14245 WTAPE(-11)=WTFG*WTAPE(-11)
14246 ENDIF
14247 ELSEIF(KFLB.EQ.24) THEN
14248 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
14249 & (XEE*(XB+XEE)))/XB
14250 ELSEIF(KFLB.EQ.-24) THEN
14251 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
14252 & (XEE*(XB+XEE)))/XB
14253 ENDIF
14254
14255C...Calculate parton distribution weights and sum.
14256 NTRY=0
14257 200 NTRY=NTRY+1
14258 IF(NTRY.GT.500) THEN
14259 MINT(51)=1
14260 RETURN
14261 ENDIF
14262 WTSUMC=0D0
14263 WTSUME=0D0
14264 XFBO=MAX(1D-10,XFB(KFLB))
14265 DO 210 KFL=-25,25
14266 WTSF(KFL)=XFB(KFL)/XFBO
14267 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
14268 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
14269 210 CONTINUE
14270 WTSUMC=MAX(0.0001D0,WTSUMC)
14271 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
14272
14273C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
14274 NTRY2=0
14275 220 NTRY2=NTRY2+1
14276 IF(NTRY2.GT.500) THEN
14277 MINT(51)=1
14278 RETURN
14279 ENDIF
14280 IF(MCEV.EQ.1) THEN
14281 IF(MSTP(64).LE.0) THEN
14282 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
14283 ELSEIF(MSTP(64).EQ.1) THEN
14284 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
14285 ELSE
14286 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
14287 ENDIF
14288 ENDIF
14289 IF(MEEV.EQ.1) THEN
14290 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
14291 & (PARU(101)*FWTE*WTSUME*TEMX)))
14292 ELSEIF(MEEV.EQ.2) THEN
14293 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
14294 ENDIF
14295
14296C...Translate t into Q2 scale; choose between QCD and QED evolution.
14297 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
14298 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
14299 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
14300C...Ensure that Q2 is above threshold for charm/bottom.
14301 KFLCB=IABS(KFLB)
14302 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14303 &MCEV.EQ.1) THEN
14304 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
14305 Q2CB=1.1D0*PMAS(KFLCB,1)**2
14306 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14307 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
14308 ENDIF
14309 ENDIF
14310 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14311 &MEEV.EQ.2) THEN
14312 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
14313 ENDIF
14314 MCE=0
14315 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
14316 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
14317 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
14318 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
14319 IF(Q2EB.GT.Q2MNE) MCE=2
14320 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
14321 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
14322 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
14323 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
14324 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
14325 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
14326 MCE=1
14327 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
14328 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
14329 ELSE
14330 MCE=2
14331 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
14332 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
14333 ENDIF
14334
14335C...Evolution possibly ended. Update t values.
14336 IF(MCE.EQ.0) THEN
14337 Q2B=0D0
14338 GOTO 260
14339 ELSEIF(MCE.EQ.1) THEN
14340 Q2B=Q2CB
14341 Q2REF=FQ2C*Q2B
14342 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
14343 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14344 ELSE
14345 Q2B=Q2EB
14346 Q2REF=Q2B
14347 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14348 ENDIF
14349
14350C...Select flavour for branching parton.
14351 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
14352 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
14353 KFLA=-25
14354 240 KFLA=KFLA+1
14355 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
14356 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
14357 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
14358 IF(KFLA.EQ.25) THEN
14359 Q2B=0D0
14360 GOTO 260
14361 ENDIF
14362
14363C...Choose z value and corrective weight.
14364 WTZ=0D0
14365C...q -> q + g or q -> q + gamma.
14366 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
14367 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
14368 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
14369 WTZ=0.5D0*(1D0+Z**2)
14370C...q -> g + q.
14371 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
14372 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
14373 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14374C...f -> f + gamma.
14375 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14376 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
14377 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
14378 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
14379 ELSE
14380 Z=XB+XB*(XEE/(1D0-XEE))*
14381 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14382 ENDIF
14383 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
14384C...f -> gamma + f.
14385 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
14386 Z=XB+XB*(XEE/(1D0-XEE))*
14387 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14388 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
14389C...f -> W+- + f.
14390 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) THEN
14391 Z=XB+XB*(XEE/(1D0-XEE))*
14392 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14393 WTZ=0.5D0*(1D0+(1D0-Z)**2)*(XB*(Z-XB)/Z)*
14394 & (Q2B/(Q2B+PMAS(24,1)**2))
14395C...g -> q + qbar.
14396 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
14397 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
14398 WTZ=1D0-2D0*Z*(1D0-Z)
14399C...g -> g + g.
14400 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14401 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
14402 WTZ=(1D0-Z*(1D0-Z))**2
14403C...gamma -> f + fbar.
14404 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
14405 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
14406 WTZ=1D0-2D0*Z*(1D0-Z)
14407 ENDIF
14408 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
14409
14410C...Option with resummation of soft gluon emission as effective z shift.
14411 IF(MCE.EQ.1) THEN
14412 IF(MSTP(65).GE.1) THEN
14413 RSOFT=6D0
14414 IF(KFLB.NE.21) RSOFT=8D0/3D0
14415 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
14416 IF(Z.LE.XB) GOTO 220
14417 ENDIF
14418
14419C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
14420 IF(MSTP(64).GE.2) THEN
14421 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
14422 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
14423 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
14424 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
14425 ENDIF
14426 ENDIF
14427
14428C...Remove kinematically impossible branchings.
14429 UHAT=Q2B-DSH*(1D0-Z)/Z
14430 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
14431
14432C...Select phi angle of branching at random.
14433 PHIBR=PARU(2)*PYR(0)
14434
14435C...Matrix-element corrections for some processes.
14436 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14437 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14438 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
14439 WTZ=WTZ*WTME/WTFF
14440 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
14441 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
14442 WTZ=WTZ*WTME/WTGF
14443 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14444 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
14445 WTZ=WTZ*WTME/WTFG
14446 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14447 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
14448 WTZ=WTZ*WTME/WTGG
14449 ENDIF
14450 ENDIF
14451
14452C...Impose angular constraint in first branching from interference
14453C...with final state partons.
14454 IF(MCE.EQ.1) THEN
14455 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
14456 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
14457 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
14458 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
14459 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
14460 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
14461 ENDIF
14462 ENDIF
14463
14464C...Option with angular ordering requirement.
14465 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
14466 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
14467 IF(THE2T.GT.THE2(JT)) GOTO 220
14468 ENDIF
14469 ENDIF
14470
14471C...Weighting with new parton distributions.
14472 MINT(105)=MINT(102+JT)
14473 MINT(109)=MINT(106+JT)
14474 VINT(120)=VINT(2+JT)
14475 IF(MINT(31).GE.2) MINT(30)=JT
14476C.... ALICE
14477C.... Store side in MINT(124)
14478 MINT(124) = JT
14479C....
14480 IF(MSTP(57).LE.1) THEN
14481 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
14482 ELSE
14483 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
14484 ENDIF
14485 XFBN=XFN(KFLB)
14486 IF(XFBN.LT.1D-20) THEN
14487 IF(KFLA.EQ.KFLB) THEN
14488 TEVCB=TEVCBS
14489 TEVEB=TEVEBS
14490 WTAPC(KFLB)=0D0
14491 WTAPE(KFLB)=0D0
14492 GOTO 200
14493 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
14494 TEVCB=0.5D0*(TEVCBS+TEVCB)
14495 GOTO 230
14496 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
14497 TEVEB=0.5D0*(TEVEBS+TEVEB)
14498 GOTO 230
14499 ELSE
14500 XFBN=1D-10
14501 XFN(KFLB)=XFBN
14502 ENDIF
14503 ENDIF
14504 DO 250 KFL=-25,25
14505 XFB(KFL)=XFN(KFL)
14506 250 CONTINUE
14507 XA=XB/Z
14508C.... ALICE
14509C.... Store side in MINT(124)
14510 MINT(124) = JT
14511C....
14512 IF(MINT(31).GE.2) MINT(30)=JT
14513 IF(MSTP(57).LE.1) THEN
14514 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
14515 ELSE
14516 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
14517 ENDIF
14518 XFAN=XFA(KFLA)
14519 IF(XFAN.LT.1D-20) GOTO 200
14520 WTSFA=WTSF(KFLA)
14521 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
14522
14523C...Define two hard scatterers in their CM-frame.
14524 260 IF(N.EQ.NS+2) THEN
14525 DQ2(JT)=Q2B
14526 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
14527 DO 280 JR=1,2
14528 I=NS+JR
14529 IF(JR.EQ.1) IPO=IPUS1
14530 IF(JR.EQ.2) IPO=IPUS2
14531 DO 270 J=1,5
14532 K(I,J)=0
14533 P(I,J)=0D0
14534 V(I,J)=0D0
14535 270 CONTINUE
14536 K(I,1)=14
14537 K(I,2)=KFLS(JR+2)
14538 K(I,4)=IPO
14539 K(I,5)=IPO
14540 P(I,3)=DPLCM*(-1)**(JR+1)
14541 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
14542 P(I,5)=-SQRT(DQ2(JR))
14543 K(IPO,1)=14
14544 K(IPO,3)=I
14545 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
14546 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
14547 MCT(I,1)=MCT(IPO,1)
14548 MCT(I,2)=MCT(IPO,2)
14549 280 CONTINUE
14550
14551C...Find maximum allowed mass of timelike parton.
14552 ELSEIF(N.GT.NS+2) THEN
14553 JR=3-JT
14554 DQ2(3)=Q2B
14555 DPC(1)=P(IS(1),4)
14556 DPC(2)=P(IS(2),4)
14557 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
14558 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
14559 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
14560 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
14561 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
14562 IKIN=0
14563 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
14564 & 1D-10*DPD(1)) IKIN=1
14565 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
14566 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
14567 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
14568 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
14569
14570C...Generate timelike parton shower (if required).
14571 IT=N
14572 DO 290 J=1,5
14573 K(IT,J)=0
14574 P(IT,J)=0D0
14575 V(IT,J)=0D0
14576 290 CONTINUE
14577C...f -> f + g (gamma).
14578 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
14579 K(IT,2)=21
14580 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
14581C...f -> g (gamma, W+-) + f.
14582 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
14583 K(IT,2)=KFLB
14584 IF(KFLS(JT+2).EQ.24) THEN
14585 K(IT,2)=-12
14586 ELSEIF(KFLS(JT+2).EQ.-24) THEN
14587 K(IT,2)=12
14588 ENDIF
14589C...g (gamma) -> f + fbar, g + g.
14590 ELSE
14591 K(IT,2)=-KFLS(JT+2)
14592 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
14593 ENDIF
14594 K(IT,1)=3
14595 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
14596 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
14597 P(IT,5)=PYMASS(K(IT,2))
14598 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
14599 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
14600 MSTJ48=MSTJ(48)
14601 PARJ85=PARJ(85)
14602 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
14603 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
14604 IF(MSTP(63).EQ.1) THEN
14605 Q2TIM=DMSMA
14606 ELSEIF(MSTP(63).EQ.2) THEN
14607 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
14608 ELSE
14609 Q2TIM=DMSMA
14610 MSTJ(48)=1
14611 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14612 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
14613 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
14614 PARJ(85)=SQRT(MAX(0D0,DPT2))*
14615 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
14616 ENDIF
14617C...Only do timelike shower here if using PYSHOW
14618 IF (MSTJ(41).NE.11.AND.MSTJ(41).NE.12) THEN
14619 CALL PYSHOW(IT,0,SQRT(Q2TIM))
14620 ENDIF
14621 MSTJ(48)=MSTJ48
14622 PARJ(85)=PARJ85
14623 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
14624 ENDIF
14625
14626C...Reconstruct kinematics of branching: timelike parton shower.
14627 DMS=P(IT,5)**2
14628 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14629 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
14630 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
14631 & (4D0*DSH*DPC(3)**2)
14632 IF(DPT2.LT.0D0) GOTO 100
14633 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
14634 & DSHR)/DPC(3)-DPC(3)
14635 P(IT,1)=SQRT(DPT2)
14636 P(IT,3)=DPB(1)*(-1)**(JT+1)
14637 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
14638 IF(N.GE.IT+1) THEN
14639 DPB(1)=SQRT(DPB(1)**2+DPT2)
14640 DPB(2)=SQRT(DPB(1)**2+DMS)
14641 DPB(3)=P(IT+1,3)
14642 DPB(4)=SQRT(DPB(3)**2+DMS)
14643 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
14644 & DPB(1))
14645 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
14646 THE=PYANGL(P(IT,3),P(IT,1))
14647 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
14648 ENDIF
14649
14650C...Reconstruct kinematics of branching: spacelike parton.
14651 DO 300 J=1,5
14652 K(N+1,J)=0
14653 P(N+1,J)=0D0
14654 V(N+1,J)=0D0
14655 300 CONTINUE
14656 K(N+1,1)=14
14657 K(N+1,2)=KFLB
14658 P(N+1,1)=P(IT,1)
14659 P(N+1,3)=P(IT,3)+P(IS(JT),3)
14660 P(N+1,4)=P(IT,4)+P(IS(JT),4)
14661 P(N+1,5)=-SQRT(DQ2(3))
14662 MCT(N+1,1)=0
14663 MCT(N+1,2)=0
14664
14665C...Define colour flow of branching.
14666 K(IS(JT),3)=N+1
14667 K(IT,3)=N+1
14668 IM1=N+1
14669 IM2=N+1
14670C...f -> f + gamma (Z, W).
14671 IF(IABS(K(IT,2)).GE.22) THEN
14672 K(IT,1)=1
14673 ID1=IS(JT)
14674 ID2=IS(JT)
14675C...f -> gamma (Z, W) + f.
14676 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
14677 ID1=IT
14678 ID2=IT
14679C...gamma -> q + qbar, g + g.
14680 ELSEIF(K(N+1,2).EQ.22) THEN
14681 ID1=IS(JT)
14682 ID2=IT
14683 IM1=ID2
14684 IM2=ID1
14685C...q -> q + g.
14686 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
14687 ID1=IT
14688 ID2=IS(JT)
14689C...q -> g + q.
14690 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
14691 ID1=IS(JT)
14692 ID2=IT
14693C...qbar -> qbar + g.
14694 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
14695 ID1=IS(JT)
14696 ID2=IT
14697C...qbar -> g + qbar.
14698 ELSEIF(K(N+1,2).LT.0) THEN
14699 ID1=IT
14700 ID2=IS(JT)
14701C...g -> g + g; g -> q + qbar.
14702 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14703 ID1=IS(JT)
14704 ID2=IT
14705 ELSE
14706 ID1=IT
14707 ID2=IS(JT)
14708 ENDIF
14709 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
14710 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
14711 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14712 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14713 IF(ID1.NE.ID2) THEN
14714 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14715 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14716 ENDIF
14717 N=N+1
14718 IF(K(IT,1).EQ.1) THEN
14719 K(IT,4)=0
14720 K(IT,5)=0
14721 ENDIF
14722
14723C...Boost to new CM-frame.
14724 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
14725 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
14726 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
14727 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
14728 IR=N+(JT-1)*(IS(1)-N)
14729 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
14730 & 0D0,0D0,0D0)
14731
14732C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
14733 IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN
14734 NPART=NPART+1
14735 IPART(NPART)=IT
14736 PTPART(NPART)=SQRT(PARP(71)*DPT2)
14737 ENDIF
14738
14739C...Global statistics.
14740 MINT(352)=MINT(352)+1
14741 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14742 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14743
14744 ENDIF
14745
14746C...Update kinematics variables.
14747 IS(JT)=N
14748 DQ2(JT)=Q2B
14749 IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
14750 DSH=DSHZ
14751
14752C...Save quantities; loop back.
14753 Q2S(JT)=Q2B
14754 DPHI(JT)=PHIBR
14755 MCESV(JT)=MCE
14756 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
14757 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
14758 KFLS(JT+2)=KFLS(JT)
14759 KFLS(JT)=KFLA
14760 XS(JT)=XA
14761 ZS(JT)=Z
14762 DO 310 KFL=-25,25
14763 XFS(JT,KFL)=XFA(KFL)
14764 310 CONTINUE
14765 TEVCSV(JT)=TEVCB
14766 TEVESV(JT)=TEVEB
14767 ELSE
14768 MORE(JT)=0
14769 IF(JT.EQ.1) IPU1=N
14770 IF(JT.EQ.2) IPU2=N
14771 ENDIF
14772 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14773 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
14774 IF(MSTU(21).GE.1) N=NS
14775 IF(MSTU(21).GE.1) RETURN
14776 ENDIF
14777 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
14778
14779C...Boost hard scattering partons to frame of shower initiators.
14780 DO 320 J=1,3
14781 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
14782 320 CONTINUE
14783 K(N+2,1)=1
14784 DO 330 J=1,5
14785 P(N+2,J)=P(NS+1,J)
14786 330 CONTINUE
14787 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
14788 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
14789 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
14790 IMIN=MINT(83)+5
14791 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
14792 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
14793 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
14794
14795C...Store user information. Reset Lambda value.
14796 IF(MINT(31).LE.1) THEN
14797 K(IPU1,3)=MINT(83)+3
14798 K(IPU2,3)=MINT(83)+4
14799 ELSE
14800 K(IPU1,3)=MINT(83)+1
14801 K(IPU2,3)=MINT(83)+2
14802 ENDIF
14803 DO 340 JT=1,2
14804 MINT(12+JT)=KFLS(JT)
14805 VINT(140+JT)=XS(JT)
14806 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
14807 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
14808 340 CONTINUE
14809 PARU(112)=ALAMS
14810
14811 RETURN
14812 END
14813
14814C*********************************************************************
14815
14816C...PYPTIS
14817C...Generates pT-ordered spacelike initial-state parton showers and
14818C...trial joinings.
14819C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14820C... interaction initiators at PT2NOW.
14821C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14822C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14823C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14824C... is below PT2CUT.
14825C... (Also generate test joinings if MSTP(96)=1.)
14826C...MODE= 1: Accept stored shower branching. Update event record etc.
14827C...PT2NOW : Starting (max) PT2 scale for evolution.
14828C...PT2CUT : Lower limit for evolution.
14829C...PT2 : Result of evolution. Generated PT2 for trial emission.
14830C...IFAIL : Status return code. IFAIL=0 when all is well.
14831
14832 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14833
14834C...Double precision and integer declarations.
14835 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14836 IMPLICIT INTEGER(I-N)
14837 INTEGER PYK,PYCHGE,PYCOMP
14838C...Parameter statement for maximum size of showers.
14839 PARAMETER (MAXNUR=1000)
14840C...Commonblocks.
14841 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14842 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14843 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14844 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14845 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14846 COMMON/PYINT1/MINT(400),VINT(400)
14847 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14848 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14849 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14850 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14851 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14852 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14853 COMMON/PYCTAG/NCT,MCT(4000,2)
14854 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
14855 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
14856 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
14857C...Local variables
14858 DIMENSION ZSAV(2,240),PT2SAV(2,240),
14859 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
14860 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
14861 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
14862 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
14863 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
14864C...For check on excessive weights.
14865 CHARACTER CHWT*12
14866
14867C...Only give errors for very large weights, otherwise just warnings
14868 DATA WTEMAX /1.5D0/
14869C...Only give errors for large pT, otherwise just warnings
14870 DATA PTEMAX /5D0/
14871
14872 IFAIL=-1
14873
14874C----------------------------------------------------------------------
14875C...MODE=-1: Initialize initial state showers from scratch, i.e.
14876C...starting from the hardest interaction initiators.
14877 IF (MODE.EQ.-1) THEN
14878C...Set hard scattering SHAT.
14879 SHTNOW(1)=VINT(44)
14880C...Mass thresholds and Lambda for QCD evolution.
14881 AEM2PI=PARU(101)/PARU(2)
14882 RMB=PMAS(5,1)
14883 RMC=PMAS(4,1)
14884 ALAM4=PARP(61)
14885 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
14886 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
14887 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
14888 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
14889C...Optionally use Lambda_MC = Lambda_CMW
14890 IF (MSTP(64).EQ.3) THEN
14891 ALAM5 = ALAM5 * 1.569
14892 ALAM4 = ALAM4 * 1.618
14893 ALAM3 = ALAM3 * 1.661
14894 ENDIF
14895 RMB2=RMB**2
14896 RMC2=RMC**2
14897C...Massive quark forced creation threshold (in M**2).
14898 TMIN=1.01D0
14899C...Set upper limit for X (ensures some X left for beam remnant).
14900 XMXC=1D0-2D0*PARP(111)/VINT(1)
14901
14902 IF (MSTP(61).GE.1) THEN
14903C...Initial values: flavours, momenta, virtualities.
14904 DO 100 JS=1,2
14905 NISGEN(JS,1)=0
14906
14907C...Special kinematics check for c/b quarks (that g -> c cbar or
14908C...b bbar kinematically possible).
14909 KFLB=K(IMI(JS,1,1),2)
14910 KFLCB=IABS(KFLB)
14911 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14912C...Check PT2MAX > mQ^2
14913 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
14914 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14915 & 'No Q creation possible.')
14916 MINT(51)=1
14917 RETURN
14918 ELSE
14919C...Check for physical z values (m == MQ / sqrt(s))
14920C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14921 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
14922 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
14923 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
14924 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
14925 & 'Q creation.')
14926 MINT(51)=1
14927 RETURN
14928 ENDIF
14929 ENDIF
14930 ENDIF
14931 100 CONTINUE
14932 ENDIF
14933
14934 MINT(354)=0
14935C...Zero joining array
14936 DO 110 MJ=1,240
14937 MJOIND(1,MJ)=0
14938 MJOIND(2,MJ)=0
14939 110 CONTINUE
14940
14941C----------------------------------------------------------------------
14942C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14943C...MINT(30). Store if emission PT2 scale is largest so far.
14944C...Also generate test joinings if MSTP(96)=1.
14945 ELSEIF(MODE.EQ.0) THEN
14946 IFAIL=-1
14947 MECOR=0
14948 ISUB=MINT(1)
14949 JS=MINT(30)
14950C...No shower for structureless beam
14951 IF (MINT(44+JS).EQ.1) RETURN
14952 MI=MINT(36)
14953 SHAT=VINT(44)
14954C...Absolute shower max scale = VINT(56)
14955 IF (MSTP(67).NE.0) THEN
14956 PT2 = MIN(PT2NOW,VINT(56))
14957 ELSE
14958C...For MSTP(67)=0, adjust starting scale by PARP(67)
14959 PT2=MIN(PT2NOW,PARP(67)*VINT(56))
14960 ENDIF
14961 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
14962C...Define for which processes ME corrections have been implemented.
14963 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
14964 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
14965 & .142.OR.ISUB.EQ.144) MECOR=1
14966 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
14967 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
14968C...Calculate preweighting factor for ME-corrected processes.
14969 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14970 ENDIF
14971C...Basic info on daughter for which to find mother.
14972 KFLB=K(IMI(JS,MI,1),2)
14973 KFLBA=IABS(KFLB)
14974C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14975C...second companion.
14976 KSVCB=MAX(-1,IMI(JS,MI,2))
14977C...Treat "first" companion of a pair like an ordinary sea quark
14978C...(except that creation diagram is not allowed)
14979 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
14980C...X (rescaled to [0,1])
14981 XB=XMI(JS,MI)/VINT(142+JS)
14982C...Massive quarks (use physical masses.)
14983 RMQ2=0D0
14984 MQMASS=0
14985 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14986 RMQ2=RMC2
14987 IF (KFLBA.EQ.5) RMQ2=RMB2
14988C...Special threshold treatment for non-photon beams
14989 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
14990C...Check that not below mass threshold.
14991 IF(MQMASS.GT.0.AND.PT2.LT.TMIN*RMQ2) THEN
14992 CALL PYERRM(9,'(PYPTIS:) PT2 < 1.01 * MQ**2. '//
14993 & 'No Q creation possible.')
14994 MINT(51)=1
14995C...Special return code if failing before any evolution at all: bad event
14996 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
14997 RETURN
14998 ENDIF
14999
15000 ENDIF
15001
15002C...Flags for parton distribution calls.
15003 MINT(105)=MINT(102+JS)
15004 MINT(109)=MINT(106+JS)
15005 VINT(120)=VINT(2+JS)
15006
15007C.... ALICE
15008C.... Store side in MINT(124)
15009 MINT(124) = JS
15010C...Calculate initial parton distribution weights.
15011 IF(XB.GE.XMXC) THEN
15012 RETURN
15013 ELSEIF(MQMASS.EQ.0) THEN
15014 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
15015 ELSE
15016C...Initialize massive quark PT2 dependent pdf underestimate.
15017 PT20=PT2
15018 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
15019C.!.Tentative treatment of massive valence quarks.
15020 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
15021 XG0=XFB(21)
15022 TPM0=LOG(PT20/RMQ2)
15023 WPDF0=TPM0*XG0/XQ0
15024 ENDIF
15025 IF (KFLBA.LE.6) THEN
15026C...For quarks, only include respective sea, val, or cmp part.
15027 IF (KSVCB.LE.0) THEN
15028 XFB(KFLB)=XPSVC(KFLB,KSVCB)
15029 ELSE
15030C...Find companion's companion
15031 MISEA=0
15032 120 MISEA=MISEA+1
15033 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
15034 XS=XMI(JS,MISEA)
15035 XREM=VINT(142+JS)
15036 YS=XS/(XREM+XS)
15037C...Momentum fraction of the companion quark.
15038C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
15039 YB=XB*(1D0-YS)
15040 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
15041 ENDIF
15042 ENDIF
15043
15044C...Determine overestimated z range: switch at c and b masses.
15045 130 IF (PT2.GT.TMIN*RMB2) THEN
15046 IZRG=3
15047 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
15048 B0=23D0/6D0
15049 ALAM2=ALAM5**2
15050 ELSEIF(PT2.GT.TMIN*RMC2) THEN
15051 IZRG=2
15052 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
15053 B0=25D0/6D0
15054 ALAM2=ALAM4**2
15055 ELSE
15056 IZRG=1
15057 PT2MNE=PT2CUT
15058 B0=27D0/6D0
15059 ALAM2=ALAM3**2
15060 ENDIF
15061C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
15062 ALAM2=ALAM2/PARP(64)
15063C...Overestimated ZMAX:
15064 IF (MQMASS.EQ.0) THEN
15065C...Massless
15066 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
15067 & /PT2MNE)-1D0)
15068 ELSE
15069C...Massive (limit for bremsstrahlung diagram > creation)
15070 FMQ=SQRT(RMQ2/SHTNOW(MI))
15071 ZMAX=1D0/(1D0+FMQ)
15072 ENDIF
15073 ZMIN=XB/XMXC
15074
15075C...If kinematically impossible then do not evolve.
15076 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
15077
15078C...Reset Altarelli-Parisi and PDF weights.
15079 DO 140 KFL=-5,5
15080 WTAP(KFL)=0D0
15081 WTPDF(KFL)=0D0
15082 140 CONTINUE
15083 WTAP(21)=0D0
15084 WTPDF(21)=0D0
15085C...Zero joining weights and compute X(partner) and X(mother) values.
15086 NJN=0
15087 IF (MSTP(96).NE.0) THEN
15088 DO 150 MJ=1,MINT(31)
15089 WTAPJ(MJ)=0D0
15090 WTPDFJ(MJ)=0D0
15091 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
15092 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
15093 & +XMI(JS,MI))
15094 150 CONTINUE
15095 ENDIF
15096
15097C...Approximate Altarelli-Parisi weights (integrated AP dz).
15098C...q -> q, g -> q or q -> q + gamma (already set which).
15099 IF(KFLBA.LE.5) THEN
15100C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
15101 IF (KSVCB.LT.0) THEN
15102 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
15103 ELSE
15104 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
15105 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
15106 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
15107 ENDIF
15108 WTAP(21)=0.5D0*(ZMAX-ZMIN)
15109 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
15110 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
15111 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15112 WTAP(KFLB)=WTFF*WTAP(KFLB)
15113 WTAP(21)=WTGF*WTAP(21)
15114 WTAPE=WTFF*WTAPE
15115 ENDIF
15116 IF(MSTP(61).EQ.1) WTAPE=0D0
15117 IF (KSVCB.GE.1) THEN
15118C...Kill normal creation but add joining diagrams for cmp quark.
15119 WTAP(21)=0D0
15120 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
15121 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
15122 & " quark here. Not handled yet, giving up!")
15123 PT2=0D0
15124 MINT(51)=1
15125 RETURN
15126 ENDIF
15127C...Check for possible joinings
15128 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
15129C...Find companion's companion.
15130 MJ=0
15131 160 MJ=MJ+1
15132 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
15133 IF (MJOIND(JS,MJ).EQ.0) THEN
15134 Y(MI)=YB+YS
15135 Z=YB/Y(MI)
15136 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
15137 IF (WTAPJ(MJ).GT.1D-6) THEN
15138 NJN=1
15139 ELSE
15140 WTAPJ(MJ)=0D0
15141 ENDIF
15142 ENDIF
15143C...Add trial gluon joinings.
15144 DO 170 MJ=1,MINT(31)
15145 KFLC=K(IMI(JS,MJ,1),2)
15146 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
15147 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
15148 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
15149 IF (WTAPJ(MJ).GT.1D-6) THEN
15150 NJN=NJN+1
15151 ELSE
15152 WTAPJ(MJ)=0D0
15153 ENDIF
15154 170 CONTINUE
15155 ENDIF
15156 ELSEIF (IMI(JS,MI,2).GE.0) THEN
15157C...Kill creation diagram for val quarks and sea quarks with companions.
15158 WTAP(21)=0D0
15159 ELSEIF (MQMASS.EQ.0) THEN
15160C...Extra safety factor for massless sea quark creation.
15161 WTAP(21)=WTAP(21)*1.25D0
15162 ENDIF
15163
15164C... q -> g, g -> g.
15165 ELSEIF(KFLB.EQ.21) THEN
15166C...Here we decide later whether a quark picked up is valence or
15167C...sea, so we maintain the extra factor sqrt(z) since we deal
15168C...with the *sum* of sea and valence in this context.
15169 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
15170C...new: do not allow backwards evol to pick up heavy flavour.
15171 DO 180 KFL=1,MIN(3,MSTP(58))
15172 WTAP(KFL)=WTAPQ
15173 WTAP(-KFL)=WTAPQ
15174 180 CONTINUE
15175 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
15176 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15177 WTAPQ=WTFG*WTAPQ
15178 WTAP(21)=WTGG*WTAP(21)
15179 ENDIF
15180C...Check for possible joinings (companions handled separately above)
15181 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
15182 & THEN
15183 DO 190 MJ=1,MINT(31)
15184 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
15185 KSVCC=IMI(JS,MJ,2)
15186 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
15187 IF (KSVCC.GE.1) GOTO 190
15188 KFLC=K(IMI(JS,MJ,1),2)
15189C...Only try g -> g + g once.
15190 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
15191 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
15192 IF (KFLC.EQ.21) THEN
15193 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
15194 ELSE
15195 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
15196 ENDIF
15197 IF (WTAPJ(MJ).GT.1D-6) THEN
15198 NJN=NJN+1
15199 ELSE
15200 WTAPJ(MJ)=0D0
15201 ENDIF
15202 190 CONTINUE
15203 ENDIF
15204 ENDIF
15205
15206C...Initialize massive quark evolution
15207 IF (MQMASS.NE.0) THEN
15208 RML=(RMQ2+VINT(18))/ALAM2
15209 TML=LOG(RML)
15210 TPL=LOG((PT2+VINT(18))/ALAM2)
15211 TPM=LOG((PT2+VINT(18))/RMQ2)
15212 WN=WTAP(21)*WPDF0/B0
15213 ENDIF
15214
15215
15216C...Loopback point for iteration
15217 NTRY=0
15218 NTHRES=0
15219 200 NTRY=NTRY+1
15220 IF(NTRY.GT.500) THEN
15221 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
15222 MINT(51)=1
15223 RETURN
15224 ENDIF
15225
15226C... Calculate PDF weights and sum for evolution rate.
15227 WTSUM=0D0
15228 XFBO=MAX(1D-10,XFB(KFLB))
15229 DO 210 KFL=-5,5
15230 WTPDF(KFL)=XFB(KFL)/XFBO
15231 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
15232 210 CONTINUE
15233C...Only add gluon mother diagram for massless KFLB.
15234 IF(MQMASS.EQ.0) THEN
15235 WTPDF(21)=XFB(21)/XFBO
15236 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
15237 ENDIF
15238 WTSUM=MAX(0.0001D0,WTSUM)
15239 WTSUMS=WTSUM
15240C...Add joining diagrams where applicable.
15241 WTJOIN=0D0
15242 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
15243 DO 220 MJ=1,MINT(31)
15244 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
15245 WTPDFJ(MJ)=1D0/XFBO
15246C...x and x*pdf (+ sea/val) for parton C.
15247 KFLC=K(IMI(JS,MJ,1),2)
15248 KFLCA=IABS(KFLC)
15249 KSVCC=MAX(-1,IMI(JS,MJ,2))
15250 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
15251 MINT(30)=JS
15252 MINT(36)=MJ
15253C.... ALICE
15254C.... Store side in MINT(124)
15255 MINT(124) = JS
15256C....
15257
15258
15259 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
15260 MINT(36)=MI
15261 IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
15262 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
15263 ELSEIF (KSVCC.GE.1) THEN
15264 print*, 'error! parton C is companion!'
15265 ENDIF
15266 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
15267C...x and x*pdf (+ sea/val) for parton A.
15268 KFLA=21
15269 KSVCA=0
15270 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
15271 KFLA=KFLB
15272 KSVCA=KSVCB
15273 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15274 KFLA=KFLC
15275 KSVCA=KSVCC
15276 ENDIF
15277 MINT(30)=JS
15278C.... ALICE
15279C.... Store side in MINT(124)
15280 MINT(124) = JS
15281C ...
15282 IF (KSVCA.LE.0) THEN
15283C...Consider C the "evolved" parton if B is gluon. Val/sea
15284C...counting will then be done correctly in PYPDFU.
15285 IF (KFLBA.EQ.21) MINT(36)=MJ
15286 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15287 MINT(36)=MI
15288 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15289 ELSE
15290C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
15291 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
15292 ENDIF
15293 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
15294 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
15295 220 CONTINUE
15296 ENDIF
15297
15298C...Pick normal pT2 (in overestimated z range).
15299 230 PT2OLD=PT2
15300 WTSUM=WTSUMS
15301 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
15302 KFLC=21
15303
15304C...Evolve q -> q gamma separately, pick it if larger pT.
15305 IF(KFLBA.LE.5.AND.MSTP(61).GE.2) THEN
15306 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
15307 IF(PT2QED.GT.PT2) THEN
15308 PT2=PT2QED
15309 KFLC=22
15310 KFLA=KFLB
15311 ENDIF
15312 ENDIF
15313
15314C... Evolve massive quark creation separately.
15315 MCRQQ=0
15316 IF (MQMASS.NE.0) THEN
7a7ee8be 15317 IF (WN .EQ. 0.) THEN
15318 ARG = -1.
15319 ELSE
15320 ARG = TPM/(TPL*PYR(0)**(-TML/WN)-TPM)
15321 ENDIF
15322 PT2CR=(RMQ2+VINT(18))*(RML**ARG)-VINT(18)
92e27c01 15323C...If massive quark also on opposite side, ensure sufficient remaining
15324C...phase space also for creation of that quark
15325 TMINQQ = TMIN
15326 KFLOPP = K(IMI(3-JS,MI,1),2)
15327 IF (ABS(KFLOPP).EQ.4.OR.ABS(KFLOPP).EQ.5) TMINQQ = 1.05
15328C...Ensure mininimum PT2CR and force creation near threshold.
15329 IF (PT2CR.LT.TMINQQ*RMQ2) THEN
15330 NTHRES=NTHRES+1
15331 IF (NTHRES.GT.50) THEN
15332 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
15333 & 'massive quark creation. Gave up trying.')
15334 MINT(51)=1
15335C...Special return code if failing before any evolution at all: bad event
15336 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
15337 RETURN
15338 ENDIF
15339 PT2=0D0
15340 PT2CR=TMINQQ*RMQ2
15341C...Signal that massive quark creation is being forced
15342 MCRQQ=2
15343 ENDIF
15344C... Select largest PT2 (brems or creation):
15345 IF (PT2CR.GT.PT2) THEN
15346 MCRQQ=MAX(MCRQQ,1)
15347 WTSUM=0D0
15348 PT2=PT2CR
15349 KFLA=21
15350 ELSE
15351 MCRQQ=0
15352 KFLA=KFLB
15353 ENDIF
15354C... Compute logarithms for this PT2
15355 TPL=LOG((PT2+VINT(18))/ALAM2)
15356 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
15357 WTCRQQ=TPM/LOG(PT2/RMQ2)
15358 ENDIF
15359
15360C...Evolve joining separately
15361 MJOIN=0
15362 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
15363 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
15364 & -VINT(18)
15365 IF (PT2JN.GE.PT2) THEN
15366 MJOIN=1
15367 PT2=PT2JN
15368 ENDIF
15369 ENDIF
15370
15371C...Loopback if crossed c/b mass thresholds.
15372 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
15373 PT2=RMB2
15374 GOTO 130
15375 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
15376 PT2=RMC2
15377 GOTO 130
15378 ENDIF
15379
15380C...Speed up shower. Skip if higher-PT acceptable branching
15381C...already found somewhere else.
15382C...Also finish if below lower cutoff.
15383
15384 IF ((PT2-PT2MX).LT.-0.001.OR.PT2.LT.PT2CUT) RETURN
15385
15386C...Select parton A flavour (massive Q handled above.)
15387 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
15388 WTRAN=PYR(0)*WTSUM
15389 KFLA=-6
15390 240 KFLA=KFLA+1
15391 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
15392 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
15393 IF(KFLA.EQ.6) KFLA=21
15394 ELSEIF (MJOIN.EQ.1) THEN
15395C...Tentative joining accept/reject.
15396 WTRAN=PYR(0)*WTJOIN
15397 MJ=0
15398 250 MJ=MJ+1
15399 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
15400 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
15401 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
15402 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
15403 & ' Rejected.')
15404 GOTO 230
15405 ENDIF
15406C...x*pdf (+ sea/val) at new pT2 for parton B.
15407 IF (KSVCB.LE.0) THEN
15408 MINT(30)=JS
15409C.... ALICE
15410C.... Store side in MINT(124)
15411 MINT(124) = JS
15412C....
15413 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
15414 IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
15415 ELSE
15416C...Companion distributions do not evolve.
15417 XFB(KFLB)=XFBO
15418 ENDIF
15419 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
15420 KFLC=K(IMI(JS,MJ,1),2)
15421 KFLCA=IABS(KFLC)
15422 KSVCC=MAX(-1,IMI(JS,MJ,2))
15423 IF (KSVCB.GE.1) KSVCC=-1
15424C...x*pdf (+ sea/val) at new pT2 for parton C.
15425 MINT(30)=JS
15426 MINT(36)=MJ
15427C.... ALICE
15428C.... Store side in MINT(124)
15429 MINT(124) = JS
15430C....
15431 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
15432 MINT(36)=MI
15433 IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
15434 WTVETO=WTVETO/XFJ(KFLC)
15435C...x and x*pdf (+ sea/val) at new pT2 for parton A.
15436 KFLA=21
15437 KSVCA=0
15438 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
15439 KFLA=KFLB
15440 KSVCA=KSVCB
15441 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15442 KFLA=KFLC
15443 KSVCA=KSVCC
15444 ENDIF
15445 IF (KSVCA.LE.0) THEN
15446 MINT(30)=JS
15447C.... ALICE
15448C.... Store side in MINT(124)
15449 MINT(124) = JS
15450C....
15451 IF (KFLB.EQ.21) MINT(36)=MJ
15452 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15453 MINT(36)=MI
15454 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15455 ELSE
15456 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
15457 ENDIF
15458 WTVETO=WTVETO*XFJ(KFLA)
15459C...Monte Carlo veto.
15460 IF (WTVETO.LT.PYR(0)) GOTO 200
15461C...If accept, save PT2 of this joining.
15462 IF (PT2.GT.PT2MX) THEN
15463 PT2MX=PT2
15464 JSMX=2+JS
15465 MJN1MX=MJ
15466 MJN2MX=MI
15467 WTAPJ(MJ)=0D0
15468 NJN=0
15469 ENDIF
15470C...Exit and continue evolution.
15471 GOTO 390
15472 ENDIF
15473 KFLAA=IABS(KFLA)
15474
15475C...Choose z value (still in overestimated range) and corrective weight.
15476C...Unphysical z will be rejected below when Q2 has is computed.
15477 WTZ=0D0
15478
15479C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
15480C...q -> q + g or q -> q + gamma (already set which).
15481 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
15482 IF (KSVCB.LT.0) THEN
15483 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
15484 ELSE
15485 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
15486 Z=((1-ZFAC)/(1+ZFAC))**2
15487 ENDIF
15488 WTZ=0.5D0*(1D0+Z**2)
15489C...Massive weight correction.
15490 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
15491C...Valence quark weight correction (extra sqrt)
15492 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
15493
15494C...q -> g + q.
15495C...NB: MQ>0 not yet implemented. Forced absent above.
15496 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
15497 KFLC=KFLA
15498 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
15499 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
15500
15501C...g -> q + qbar.
15502 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
15503 KFLC=-KFLB
15504 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
15505 WTZ=Z**2+(1D0-Z)**2
15506C...Massive correction
15507 IF (MQMASS.NE.0) THEN
15508 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
15509C...Extra safety margin for light sea quark creation
15510 ELSEIF (KSVCB.LT.0) THEN
15511 WTZ=WTZ/1.25D0
15512 ENDIF
15513
15514C...g -> g + g.
15515 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15516 KFLC=21
15517 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
15518 & (ZMAX*(1D0-ZMIN)))**PYR(0))
15519 WTZ=(1D0-Z*(1D0-Z))**2
15520 ENDIF
15521
15522C...Derive Q2 from pT2.
15523 Q2B=PT2/(1D0-Z)
15524 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
15525
15526C...Loopback if outside allowed z range for given pT2.
15527 RM2C=PYMASS(KFLC)**2
15528 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
15529 IF (PT2ADJ.LT.1D-6) GOTO 230
15530
15531C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
15532C...No modification for very first emission if using ME correction
15533 MSTP67 = MSTP(67)
15534 IF (MECOR.GE.1.AND.NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) THEN
15535 MSTP67 = 0
15536 ENDIF
15537
15538C...For 1st branching, limit phase space by s-hat with color-partner
15539 IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15540 MSIDE=1
15541 IDIP=IMI(JS,MI,1)
15542C...Use anticolor tag for antiquark, or for gluon half the time
15543 IF ((KFLB.LT.0.AND.KFLBA.LT.10).OR.(
15544 & KFLB.EQ.21.AND.PYR(0).GT.0.5)) MSIDE=2
15545C...Tag
15546 MCTAG=MCT(IDIP,MSIDE)
15547C...Default is to set up phase space using the opposite incoming parton
15548 JDIP=IMI(3-JS,MI,1)
15549 NDIP=0
15550C...Alternatively, look for final-state color partner (pick first if several)
15551 DO 260 IFS=1,NPART
15552 IF (MCT(IPART(IFS),MSIDE).EQ.MCTAG.AND.NDIP.EQ.0) THEN
15553 JDIP=IPART(IFS)
15554 NDIP=NDIP+1
15555 ENDIF
15556 260 CONTINUE
15557C...Compute momentum transfer: sdip = -t = - (p1 - p2)^2
15558C...(also works for annihilation since incoming massless, so shat = -(p1 - p2)^2)
15559 SDIP=ABS(((P(IDIP,4)-P(JDIP,4))**2-(P(IDIP,3)-P(JDIP,3))**2
15560 & -(P(IDIP,2)-P(JDIP,2))**2-(P(IDIP,1)-P(JDIP,1))**2))
15561 IF (MSTP67.EQ.1) THEN
15562C...1 Option to completely kill radiation above s_dip * PARP(67)
15563 IF (4D0*PT2.GT.PARP(67)*SDIP) GOTO 230
15564 ELSE IF (MSTP67.EQ.2) THEN
15565C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
15566C... (-> improved power showers?)
15567 IF (4D0*PT2*PYR(0).GT.PARP(67)*SDIP) GOTO 230
15568 ENDIF
15569
15570C...For subsequent branchings, loopback if nonordered in angle/rapidity
15571 ELSE IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
15572 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
15573 & GOTO 230
15574 ENDIF
15575
15576C...Select phi angle of branching at random.
15577 PHI=PARU(2)*PYR(0)
15578
15579C...Matrix-element corrections for some processes.
15580 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15581 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
15582 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15583 WTZ=WTZ*WTME/WTFF
15584 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
15585 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15586 WTZ=WTZ*WTME/WTGF
15587 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
15588 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15589 WTZ=WTZ*WTME/WTFG
15590 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15591 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15592 WTZ=WTZ*WTME/WTGG
15593 ENDIF
15594 ENDIF
15595
15596C...Parton distributions at new pT2 but old x.
15597 MINT(30)=JS
15598C.... ALICE
15599C.... Store side in MINT(124)
15600 MINT(124) = JS
15601C....
15602 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
15603C...Treat val and cmp separately
15604 IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
15605 IF (KSVCB.GE.1)
15606 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
15607 XFBN=XFN(KFLB)
15608 IF(XFBN.LT.1D-20) THEN
15609 IF(KFLA.EQ.KFLB) THEN
15610 WTAP(KFLB)=0D0
15611 GOTO 200
15612 ELSE
15613 XFBN=1D-10
15614 XFN(KFLB)=XFBN
15615 ENDIF
15616 ENDIF
15617 DO 270 KFL=-5,5
15618 XFB(KFL)=XFN(KFL)
15619 270 CONTINUE
15620 XFB(21)=XFN(21)
15621
15622C...Parton distributions at new pT2 and new x.
15623 XA=XB/Z
15624 MINT(30)=JS
15625C.... ALICE
15626C.... Store side in MINT(124)
15627 MINT(124) = JS
15628C....
15629 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
15630 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
15631C...q -> q + g: only consider respective sea, val, or cmp content.
15632 IF (KSVCB.LE.0) THEN
15633 XFA(KFLA)=XPSVC(KFLA,KSVCB)
15634 ELSE
15635 YA=XA*(1D0-YS)
15636 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
15637 ENDIF
15638 ENDIF
15639 XFAN=XFA(KFLA)
15640 IF(XFAN.LT.1D-20) THEN
15641 GOTO 200
15642 ENDIF
15643
15644C...If weighting fails continue evolution.
15645 WTTOT=0D0
15646 IF (MCRQQ.EQ.0) THEN
15647 WTPDFA=1D0/WTPDF(KFLA)
15648 WTTOT=WTZ*XFAN/XFBN*WTPDFA
15649 ELSEIF(MCRQQ.EQ.1) THEN
15650 WTPDFA=TPM/WPDF0
15651 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
15652 XBEST=TPM/TPM0*XQ0
15653 ELSEIF(MCRQQ.EQ.2) THEN
15654C...Force massive quark creation.
15655 WTTOT=1D0
15656 ENDIF
15657
15658C...Loop back if trial emission fails.
15659 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
15660 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
15661 IF(WTTOT.LT.0D0) THEN
15662 WRITE(CHWT,'(1P,E12.4)') WTTOT
15663 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
15664 ELSEIF(WTTOT.GT.WTACC) THEN
15665 WRITE(CHWT,'(1P,E12.4)') WTTOT
15666 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
15667C...Too high weight: write out as error, but do not update error counter
15668 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
15669 CALL PYERRM(19,
15670 & '(PYPTIS:) Weight '//CHWT//' above unity')
15671 IF (PT2.GT.PTEMAX) PTEMAX=PT2
15672 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
15673 ELSE
15674 CALL PYERRM(9,
15675 & '(PYPTIS:) Weight '//CHWT//' above unity')
15676 ENDIF
15677C...Useful for debugging but commented out for distribution:
15678C print*, 'JS, MI',JS, MI
15679C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
15680C print*, 'A -> B C',KFLA, KFLB, KFLC
15681C XFAO=XFBO/WTPDFA
15682C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
15683 ENDIF
15684
15685C...Special for PT2 = PT2MX (e.g., if two incoming massive quarks
15686C...simultaneously reached their creation thresholds)
15687 IF (ABS(PT2-PT2MX).LT.0.001) THEN
15688 IF (PYR(0).GT.0.5) PT2=1.0001*PT2MX
15689 ENDIF
15690
15691C...Save acceptable branching.
15692 IF(PT2.GT.PT2MX) THEN
15693 MIMX=MINT(36)
15694 JSMX=JS
15695 PT2MX=PT2
15696 KFLAMX=KFLA
15697 KFLCMX=KFLC
15698 RM2CMX=RM2C
15699 Q2BMX=Q2B
15700 ZMX=Z
15701 PT2AMX=PT2ADJ
15702 PHIMX=PHI
15703 ENDIF
15704
15705C----------------------------------------------------------------------
15706C...MODE= 1: Accept stored shower branching. Update event record etc.
15707 ELSEIF (MODE.EQ.1) THEN
15708 MI=MIMX
15709 JS=JSMX
15710 SHAT=SHTNOW(MI)
15711 SIDE=3D0-2D0*JS
15712C...Shift down rest of event record to make room for insertion.
15713 IT=IMISEP(MI)+1
15714 IM=IT+1
15715 IS=IMI(JS,MI,1)
15716 DO 290 I=N,IT,-1
15717 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
15718 KT1=K(I,4)/MSTU(5)**2
15719 KT2=K(I,5)/MSTU(5)**2
15720 ID1=MOD(K(I,4),MSTU(5))
15721 ID2=MOD(K(I,5),MSTU(5))
15722 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
15723 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
15724 IF (ID1.GE.IT) ID1=ID1+2
15725 IF (ID2.GE.IT) ID2=ID2+2
15726 IF (IM1.GE.IT) IM1=IM1+2
15727 IF (IM2.GE.IT) IM2=IM2+2
15728 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
15729 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
15730 DO 280 IX=1,5
15731 K(I+2,IX)=K(I,IX)
15732 P(I+2,IX)=P(I,IX)
15733 V(I+2,IX)=V(I,IX)
15734 280 CONTINUE
15735 MCT(I+2,1)=MCT(I,1)
15736 MCT(I+2,2)=MCT(I,2)
15737 290 CONTINUE
15738 N=N+2
15739C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
15740 DO 300 JI=1,MINT(31)
15741 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
15742 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
15743 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
15744 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
15745 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
15746C...Also update companion pointers to the present mother.
15747 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
15748 300 CONTINUE
15749 DO 310 IFS=1,NPART
15750 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
15751 310 CONTINUE
15752C...Zero entries dedicated for new timelike and mother partons.
15753 DO 330 I=IT,IT+1
15754 DO 320 J=1,5
15755 K(I,J)=0
15756 P(I,J)=0D0
15757 V(I,J)=0D0
15758 320 CONTINUE
15759 MCT(I,1)=0
15760 MCT(I,2)=0
15761 330 CONTINUE
15762
15763C...Define timelike and new mother partons. History.
15764 K(IT,1)=3
15765 K(IT,2)=KFLCMX
15766 K(IM,1)=14
15767 K(IM,2)=KFLAMX
15768 K(IS,3)=IM
15769 K(IT,3)=IM
15770C...Set mother origin = side.
15771 K(IM,3)=MINT(83)+JS+2
15772 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
15773
15774C...Define colour flow of branching.
15775 IM1=IM
15776 IM2=IM
15777C...q -> q + gamma.
15778 IF(K(IT,2).EQ.22) THEN
15779 K(IT,1)=1
15780 ID1=IS
15781 ID2=IS
15782C...q -> q + g.
15783 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
15784 ID1=IT
15785 ID2=IS
15786C...q -> g + q.
15787 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
15788 ID1=IS
15789 ID2=IT
15790C...qbar -> qbar + g.
15791 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
15792 ID1=IS
15793 ID2=IT
15794C...qbar -> g + qbar.
15795 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
15796 ID1=IT
15797 ID2=IS
15798C...g -> g + g; g -> q + qbar..
15799 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
15800 ID1=IS
15801 ID2=IT
15802 ELSE
15803 ID1=IT
15804 ID2=IS
15805 ENDIF
15806 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
15807 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
15808 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
15809 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
15810 IF(ID1.NE.ID2) THEN
15811 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
15812 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
15813 ENDIF
15814 IF(K(IT,1).EQ.1) THEN
15815 K(IT,4)=0
15816 K(IT,5)=0
15817 ENDIF
15818C...Update IMI and colour tag arrays.
15819 IMI(JS,MI,1)=IM
15820 DO 340 MC=1,2
15821 MCT(IT,MC)=0
15822 MCT(IM,MC)=0
15823 340 CONTINUE
15824 DO 350 JCS=4,5
15825 KCS=JCS
15826C...If mother flag not yet set for spacelike parton, trace it.
15827 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
15828 IF(MINT(51).NE.0) RETURN
15829 350 CONTINUE
15830 DO 360 JCS=4,5
15831 KCS=JCS
15832C...If mother flag not yet set for timelike parton, trace it.
15833 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
15834 IF(MINT(51).NE.0) RETURN
15835 360 CONTINUE
15836
15837C...Boost recoiling parton to compensate for Q2 scale.
15838 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
15839 & (1D0+(1D0+Q2BMX/SHAT)**2)
15840 IR=IMI(3-JS,MI,1)
15841 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
15842
15843C...Define system to be rotated and boosted
15844C...(not including the 2 just added partons)
15845C...(but including the docu lines for first interaction)
15846 IMIN=IMISEP(MI-1)+1
15847 IF (MI.EQ.1) IMIN=MINT(83)+5
15848 IMAX=IMISEP(MI)-2
15849
15850C...Rotate back system in phi to compensate for subsequent rotation.
15851 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
15852
15853C...Define kinematics of new partons in old frame.
15854 IMAX=IMISEP(MI)
15855 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
15856 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
15857 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
15858 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
15859 P(IT,1)=P(IM,1)
15860 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
15861 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
15862 P(IT,5)=SQRT(RM2CMX)
15863
15864C...Update internal line, now spacelike
15865 P(IS,1)=P(IM,1)-P(IT,1)
15866 P(IS,2)=P(IM,2)-P(IT,2)
15867 P(IS,3)=P(IM,3)-P(IT,3)
15868 P(IS,4)=P(IM,4)-P(IT,4)
15869 P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
15870C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
15871 IF (P(IS,5).LT.0D0) THEN
15872 P(IS,5)=-SQRT(ABS(P(IS,5)))
15873 ELSE
15874 P(IS,5)=SQRT(P(IS,5))
15875 ENDIF
15876
15877C...Boost entire system and rotate to new frame.
15878C...(including docu lines)
15879 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
15880 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
15881 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
15882 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
15883 MINT(51)=1
15884 IFAIL=-1
15885 RETURN
15886 ENDIF
15887 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
15888 I1=IMI(1,MI,1)
15889 THETA=PYANGL(P(I1,3),P(I1,1))
15890 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
15891
15892C...Global statistics.
15893 MINT(352)=MINT(352)+1
15894 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
15895 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
15896
15897C...Add parton with relevant pT scale for timelike shower.
15898 IF (K(IT,2).NE.22) THEN
15899 NPART=NPART+1
15900 IPART(NPART)=IT
15901 PTPART(NPART)=SQRT(PT2AMX)
15902 ENDIF
15903
15904C...Update saved variables.
15905 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15906 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15907 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15908 PT2SAV(JSMX,MIMX)=PT2MX
15909 ZSAV(JS,MIMX)=ZMX
15910
15911 KSA=IABS(K(IS,2))
15912 KMA=IABS(K(IM,2))
15913 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15914C...Gluon reconstructs to quark.
15915C...Decide whether newly created quark is valence or sea:
15916 MINT(30)=JS
15917 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15918 IF(MINT(51).NE.0) RETURN
15919 ENDIF
15920 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15921C...Quark reconstructs to gluon.
15922C...Now some guy may have lost his companion. Check.
15923 ICMP=IMI(JS,MI,2)
15924 IF (ICMP.GT.0) THEN
15925 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15926 & //' away. Cannot handle that yet. Giving up.')
15927 MINT(51)=1
15928 RETURN
15929 ELSEIF(ICMP.LT.0) THEN
15930C...A sea quark with companion still in BR was reconstructed to a gluon.
15931C...Companion should now be removed from the beam remnant.
15932C...(Momentum integral is automatically updated in next call to PYPDFU.)
15933 ICMP=-ICMP
15934 IFL=-K(IS,2)
15935 DO 380 JCMP=ICMP,NVC(JS,IFL)-1
15936 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15937 DO 370 JI=1,MINT(31)
15938 KMI=-IMI(JS,JI,2)
15939 JFL=-K(IMI(JS,JI,1),2)
15940 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15941 & ,2)+1
15942 370 CONTINUE
15943 380 CONTINUE
15944 NVC(JS,IFL)=NVC(JS,IFL)-1
15945 ENDIF
15946C...Set gluon IMI(JS,MI,2) = 0.
15947 IMI(JS,MI,2)=0
15948 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15949C...Quark reconstructing to quark. If sea with companion still in BR
15950C...then update associated x value.
15951C...(Momentum integral is automatically updated in next call to PYPDFU.)
15952 IF (IMI(JS,MI,2).LT.0) THEN
15953 ICMP=-IMI(JS,MI,2)
15954 IFL=-K(IS,2)
15955 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15956 ENDIF
15957 ENDIF
15958
15959 ENDIF
15960
15961C...If reached this point, normal exit.
15962 390 IFAIL=0
15963
15964 RETURN
15965 END
15966
15967C*********************************************************************
15968
15969C...PYMEMX
15970C...Generates maximum ME weight in some initial-state showers.
15971C...Inparameter MECOR: kind of hard scattering process
15972C...Outparameter WTFF: maximum weight for fermion -> fermion
15973C... WTGF: maximum weight for gluon/photon -> fermion
15974C... WTFG: maximum weight for fermion -> gluon/photon
15975C... WTGG: maximum weight for gluon -> gluon
15976
15977 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15978
15979C...Double precision and integer declarations.
15980 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15981 IMPLICIT INTEGER(I-N)
15982 INTEGER PYK,PYCHGE,PYCOMP
15983C...Commonblocks.
15984 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15985 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15986 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15987 COMMON/PYINT1/MINT(400),VINT(400)
15988 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15989 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15990
15991C...Default maximum weight.
15992 WTFF=1D0
15993 WTGF=1D0
15994 WTFG=1D0
15995 WTGG=1D0
15996
15997C...Select maximum weight by process.
15998 IF(MECOR.EQ.1) THEN
15999 WTFF=1D0
16000 WTGF=3D0
16001 ELSEIF(MECOR.EQ.2) THEN
16002 WTFG=1D0
16003 WTGG=1D0
16004 ENDIF
16005
16006 RETURN
16007 END
16008
16009C*********************************************************************
16010
16011C...PYMEWT
16012C...Calculates actual ME weight in some initial-state showers.
16013C...Inparameter MECOR: kind of hard scattering process
16014C... IFLCB: flavour combination of branching,
16015C... 1 for fermion -> fermion,
16016C... 2 for gluon/photon -> fermion
16017C... 3 for fermion -> gluon/photon,
16018C... 4 for gluon -> gluon
16019C... Q2: Q2 value of shower branching
16020C... Z: Z value of branching
16021C...In+outparameter PHIBR: azimuthal angle of branching
16022C...Outparameter WTME: actual ME weight
16023
16024 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
16025
16026C...Double precision and integer declarations.
16027 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16028 IMPLICIT INTEGER(I-N)
16029 INTEGER PYK,PYCHGE,PYCOMP
16030C...Commonblocks.
16031 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16032 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16033 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16034 COMMON/PYINT1/MINT(400),VINT(400)
16035 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16036 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
16037
16038C...Default output.
16039 WTME=1D0
16040
16041C...Define kinematics of shower branching in Mandelstam variables.
16042 SQM=VINT(44)
16043 SH=SQM/Z
16044 TH=-Q2
16045 UH=Q2-SQM*(1D0-Z)/Z
16046
16047C...Matrix-element corrections for f + fbar -> s-channel vector boson.
16048 IF(MECOR.EQ.1) THEN
16049 IF(IFLCB.EQ.1) THEN
16050 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
16051 ELSEIF(IFLCB.EQ.2) THEN
16052 WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
16053 ENDIF
16054
16055C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
16056 ELSEIF(MECOR.EQ.2) THEN
16057 IF(IFLCB.EQ.3) THEN
16058 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
16059 ELSEIF(IFLCB.EQ.4) THEN
16060 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
16061 ENDIF
16062
16063C...Matrix-element corrections for q + qbar -> Higgs (h0)
16064 ELSEIF(MECOR.EQ.3) THEN
16065 IF(IFLCB.EQ.2) THEN
16066 WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
16067 1 (SH**2+2D0*SQM*(SQM-SH))
16068 ENDIF
16069 ENDIF
16070
16071 RETURN
16072 END
16073
16074C*********************************************************************
16075
16076C...PYPTMI
16077C...Handles the generation of additional interactions in the new
16078C...multiple interactions framework.
16079C...MODE=-1 : Initalize MI from scratch.
16080C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
16081C... Sudakov for PT2, abort if below PT2CUT.
16082C...MODE= 1 : Accept interaction at PT2NOW and store variables.
16083C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
16084C...PT2NOW : Starting (max) PT2 scale for evolution.
16085C...PT2CUT : Lower limit for evolution.
16086C...PT2 : Result of evolution. Generated PT2 for trial interaction.
16087C...IFAIL : Status return code.
16088C... = 0: All is well.
16089C... < 0: Phase space exhausted, generation to be terminated.
16090C... > 0: Additional interaction vetoed, but continue evolution.
16091
16092 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
16093C...Double precision and integer declarations.
16094 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16095 IMPLICIT INTEGER(I-N)
16096 INTEGER PYK,PYCHGE,PYCOMP
16097C...Parameter statement for maximum size of showers.
16098 PARAMETER (MAXNUR=1000)
16099C...Commonblocks.
16100 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16101 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16102 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16103 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16104 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16105 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16106 COMMON/PYINT1/MINT(400),VINT(400)
16107 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16108 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
16109 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
16110 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
16111 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
16112 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
16113 & XMI(2,240),PT2MI(240),IMISEP(0:240)
16114 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
16115 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
16116 COMMON/PYCTAG/NCT,MCT(4000,2)
16117C...Local arrays and saved variables.
16118 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
16119
16120 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
16121 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
16122 & /PYISMX/,/PYCTAG/
16123 SAVE NCHN,XT2FAC,SIGS
16124
16125 IFAIL=0
16126C...Set MI subprocess = QCD 2 -> 2.
16127 ISUB=96
16128
16129C----------------------------------------------------------------------
16130C...MODE=-1: Initialize from scratch
16131 IF (MODE.EQ.-1) THEN
16132C...Initialize PT2 array.
16133 PT2MI(1)=VINT(54)
16134C...Initialize list of incoming beams and partons from two sides.
16135 DO 110 JS=1,2
16136 DO 100 MI=1,240
16137 IMI(JS,MI,1)=0
16138 IMI(JS,MI,2)=0
16139 100 CONTINUE
16140 NMI(JS)=1
16141 IMI(JS,1,1)=MINT(84)+JS
16142 IMI(JS,1,2)=0
16143 XMI(JS,1)=VINT(40+JS)
16144C...Rescale x values to fractions of photon energy.
16145 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
16146C...Hard reset: hard interaction initiators motherless by definition.
16147 K(MINT(84)+JS,3)=2+JS
16148 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
16149 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
16150 110 CONTINUE
16151 IMISEP(0)=MINT(84)
16152 IMISEP(1)=N
16153 IF (MOD(MSTP(81),10).GE.1) THEN
16154 IF(MSTP(82).LE.1) THEN
16155 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
16156 & ,5))
16157 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
16158 & VINT(317)/(VINT(318)*VINT(320))
16159 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
16160 ELSE
16161 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
16162 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
16163 ENDIF
16164 ENDIF
16165C...Zero entries relating to scatterings beyond the first.
16166 DO 120 MI=2,240
16167 IMI(1,MI,1)=0
16168 IMI(2,MI,1)=0
16169 IMI(1,MI,2)=0
16170 IMI(2,MI,2)=0
16171 IMISEP(MI)=IMISEP(1)
16172 PT2MI(MI)=0D0
16173 XMI(1,MI)=0D0
16174 XMI(2,MI)=0D0
16175 120 CONTINUE
16176C...Initialize factors for PDF reshaping.
16177 DO 140 JS=1,2
16178 KFBEAM(JS)=MINT(10+JS)
16179 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
16180 KFABM=IABS(KFBEAM(JS))
16181 KFSBM=ISIGN(1,KFBEAM(JS))
16182
16183C...Zero flavour content of incoming beam particle.
16184 KFIVAL(JS,1)=0
16185 KFIVAL(JS,2)=0
16186 KFIVAL(JS,3)=0
16187C... Flavour content of baryon.
16188 IF(KFABM.GT.1000) THEN
16189 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
16190 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
16191 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
16192C... Flavour content of pi+-, K+-.
16193 ELSEIF(KFABM.EQ.211) THEN
16194 KFIVAL(JS,1)=KFSBM*2
16195 KFIVAL(JS,2)=-KFSBM
16196 ELSEIF(KFABM.EQ.321) THEN
16197 KFIVAL(JS,1)=-KFSBM*3
16198 KFIVAL(JS,2)=KFSBM*2
16199C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
16200 ENDIF
16201
16202C...Zero initial valence and companion content.
16203 DO 130 IFL=-6,6
16204 NVC(JS,IFL)=0
16205 130 CONTINUE
16206 140 CONTINUE
16207C...Set up colour line tags starting from hard interaction initiators.
16208 NCT=0
16209C...Reset colour tag array and colour processing flags.
16210 DO 150 I=IMISEP(0)+1,N
16211 MCT(I,1)=0
16212 MCT(I,2)=0
16213 K(I,4)=MOD(K(I,4),MSTU(5)**2)
16214 K(I,5)=MOD(K(I,5),MSTU(5)**2)
16215 150 CONTINUE
16216C... Consider each side in turn.
16217 DO 170 JS=1,2
16218 I1=IMI(JS,1,1)
16219 I2=IMI(3-JS,1,1)
16220 DO 160 JCS=4,5
16221 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
16222 & GOTO 160
16223 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
16224 KCS=JCS
16225 CALL PYCTTR(I1,KCS,I2)
16226 IF(MINT(51).NE.0) RETURN
16227 160 CONTINUE
16228 170 CONTINUE
16229
16230C...Range checking for companion quark pdf large-x param.
16231 IF (MSTP(87).LT.0) THEN
16232 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
16233 & ' MSTP(87)=0')
16234 MSTP(87)=0
16235 ELSEIF (MSTP(87).GT.4) THEN
16236 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
16237 & ' MSTP(87)=4')
16238 MSTP(87)=4
16239 ENDIF
16240
16241C----------------------------------------------------------------------
16242C...MODE=0: Generate trial interaction. Return codes:
16243C...IFAIL < 0: Phase space exhausted, generation to be terminated.
16244C...IFAIL = 0: Additional interaction generated at PT2.
16245C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
16246 ELSEIF (MODE.EQ.0) THEN
16247C...Abolute MI max scale = VINT(62)
16248 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
16249 180 IF(MSTP(82).LE.1) THEN
16250 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
16251 IF(XT2.LT.VINT(149)) IFAIL=-2
16252 ELSE
16253 IF(XT2.LE.0.01001D0*VINT(149)) THEN
16254 IFAIL=-3
16255 ELSE
16256 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
16257 & LOG(PYR(0)))-VINT(149)
16258 ENDIF
16259 ENDIF
16260C...Also exit if below lower limit or if higher trial branching
16261C...already found.
16262 PT2=0.25D0*VINT(2)*XT2
16263 IF (PT2.LE.PT2CUT) IFAIL=-4
16264 IF (PT2.LE.PT2MX) IFAIL=-5
16265 IF (IFAIL.NE.0) THEN
16266 PT2=0D0
16267 RETURN
16268 ENDIF
16269 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
16270 VINT(25)=4D0*PT2/VINT(2)
16271 XT2=VINT(25)
16272
16273C...Choose tau and y*. Calculate cos(theta-hat).
16274 IF(PYR(0).LE.COEF(ISUB,1)) THEN
16275 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
16276 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
16277 ELSE
16278 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
16279 ENDIF
16280 VINT(21)=TAU
16281C...New: require shat > 1.
16282 IF(TAU*VINT(2).LT.1D0) GOTO 180
16283 CALL PYKLIM(2)
16284 RYST=PYR(0)
16285 MYST=1
16286 IF(RYST.GT.COEF(ISUB,8)) MYST=2
16287 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
16288 CALL PYKMAP(2,MYST,PYR(0))
16289 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
16290
16291C...Check that x not used up. Accept or reject kinematical variables.
16292 X1M=SQRT(TAU)*EXP(VINT(22))
16293 X2M=SQRT(TAU)*EXP(-VINT(22))
16294 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
16295 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
16296 NCHN=0
16297 CALL PYSIGH(NCHN,SIGS)
16298 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
16299 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
16300 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
16301
16302C...Save if highest PT so far.
16303 IF (PT2.GT.PT2MX) THEN
16304 JSMX=0
16305 MIMX=MINT(31)+1
16306 PT2MX=PT2
16307 ENDIF
16308
16309C----------------------------------------------------------------------
16310C...MODE=1: Generate and save accepted scattering.
16311 ELSEIF (MODE.EQ.1) THEN
16312 PT2=PT2NOW
16313C...Reset K, P, V, and MCT vectors.
16314 DO 200 I=N+1,N+4
16315 DO 190 J=1,5
16316 K(I,J)=0
16317 P(I,J)=0D0
16318 V(I,J)=0D0
16319 190 CONTINUE
16320 MCT(I,1)=0
16321 MCT(I,2)=0
16322 200 CONTINUE
16323
16324 NTRY=0
16325C...Choose flavour of reacting partons (and subprocess).
16326 210 NTRY=NTRY+1
16327 IF (NTRY.GT.50) THEN
16328 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
16329 & //'interaction. Giving up!')
16330 MINT(51)=1
16331 RETURN
16332 ENDIF
16333 RSIGS=SIGS*PYR(0)
16334 DO 220 ICHN=1,NCHN
16335 KFL1=ISIG(ICHN,1)
16336 KFL2=ISIG(ICHN,2)
16337 ICONMI=ISIG(ICHN,3)
16338 RSIGS=RSIGS-SIGH(ICHN)
16339 IF(RSIGS.LE.0D0) GOTO 230
16340 220 CONTINUE
16341
16342C...Reassign to appropriate process codes.
16343 230 ISUBMI=ICONMI/10
16344 ICONMI=MOD(ICONMI,10)
16345
16346C...Choose new quark flavour for annihilation graphs
16347 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
16348 SH=VINT(21)*VINT(2)
16349 CALL PYWIDT(21,SH,WDTP,WDTE)
16350 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
16351 DO 250 I=1,MDCY(21,3)
16352 KFLF=KFDP(I+MDCY(21,2)-1,1)
16353 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
16354 IF(RKFL.LE.0D0) GOTO 260
16355 250 CONTINUE
16356 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
16357 IF(KFLF.GE.4) GOTO 240
16358 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
16359 KFLF=4
16360 ICONMI=ICONMI-2
16361 ELSEIF(ISUBMI.EQ.53) THEN
16362 KFLF=5
16363 ICONMI=ICONMI-4
16364 ENDIF
16365 ENDIF
16366
16367C...Final state flavours and colour flow: default values
16368 JS=1
16369 KFL3=KFL1
16370 KFL4=KFL2
16371 KCC=20
16372 KCS=ISIGN(1,KFL1)
16373
16374 IF(ISUBMI.EQ.11) THEN
16375C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
16376 KCC=ICONMI
16377 IF(KFL1*KFL2.LT.0) KCC=KCC+2
16378
16379 ELSEIF(ISUBMI.EQ.12) THEN
16380C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
16381 KFL3=ISIGN(KFLF,KFL1)
16382 KFL4=-KFL3
16383 KCC=4
16384
16385 ELSEIF(ISUBMI.EQ.13) THEN
16386C...f + fbar -> g + g; th arbitrary
16387 KFL3=21
16388 KFL4=21
16389 KCC=ICONMI+4
16390
16391 ELSEIF(ISUBMI.EQ.28) THEN
16392C...f + g -> f + g; th = (p(f)-p(f))**2
16393 IF(KFL1.EQ.21) JS=2
16394 KCC=ICONMI+6
16395 IF(KFL1.EQ.21) KCC=KCC+2
16396 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
16397 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
16398
16399 ELSEIF(ISUBMI.EQ.53) THEN
16400C...g + g -> f + fbar; th arbitrary
16401 KCS=(-1)**INT(1.5D0+PYR(0))
16402 KFL3=ISIGN(KFLF,KCS)
16403 KFL4=-KFL3
16404 KCC=ICONMI+10
16405
16406 ELSEIF(ISUBMI.EQ.68) THEN
16407C...g + g -> g + g; th arbitrary
16408 KCC=ICONMI+12
16409 KCS=(-1)**INT(1.5D0+PYR(0))
16410 ENDIF
16411
16412C...Check that massive sea quarks have non-zero phase space for g -> Q Q
16413 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
16414 & .OR.IABS(KFL4).EQ.5) THEN
16415 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
16416 IF (PT2.LE.1.05*RMMAX2) THEN
16417 IF (NTRY.EQ.2) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
16418 & //' too close to threshold (2nd try).')
16419 GOTO 210
16420 ENDIF
16421 ENDIF
16422
16423C...Store flavours of scattering.
16424 MINT(13)=KFL1
16425 MINT(14)=KFL2
16426 MINT(15)=KFL1
16427 MINT(16)=KFL2
16428 MINT(21)=KFL3
16429 MINT(22)=KFL4
16430
16431C...Set flavours and mothers of scattering partons.
16432 K(N+1,1)=14
16433 K(N+2,1)=14
16434 K(N+3,1)=3
16435 K(N+4,1)=3
16436 K(N+1,2)=KFL1
16437 K(N+2,2)=KFL2
16438 K(N+3,2)=KFL3
16439 K(N+4,2)=KFL4
16440 K(N+1,3)=MINT(83)+1
16441 K(N+2,3)=MINT(83)+2
16442 K(N+3,3)=N+1
16443 K(N+4,3)=N+2
16444
16445C...Store colour connection indices.
16446 DO 270 J=1,2
16447 JC=J
16448 IF(KCS.EQ.-1) JC=3-J
16449 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
16450 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
16451 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
16452 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
16453 270 CONTINUE
16454
16455C...Store incoming and outgoing partons in their CM-frame.
16456 SHR=SQRT(VINT(21))*VINT(1)
16457 P(N+1,3)=0.5D0*SHR
16458 P(N+1,4)=0.5D0*SHR
16459 P(N+2,3)=-0.5D0*SHR
16460 P(N+2,4)=0.5D0*SHR
16461 P(N+3,5)=PYMASS(K(N+3,2))
16462 P(N+4,5)=PYMASS(K(N+4,2))
16463 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
16464 IFAIL=1
16465 RETURN
16466 ENDIF
16467 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
16468 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
16469 P(N+4,4)=SHR-P(N+3,4)
16470 P(N+4,3)=-P(N+3,3)
16471
16472C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
16473 PHI=PARU(2)*PYR(0)
16474 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
16475
16476C...Global statistics.
16477 MINT(351)=MINT(351)+1
16478 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
16479 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
16480
16481C...Keep track of loose colour ends and information on scattering.
16482 MINT(31)=MINT(31)+1
16483 MINT(36)=MINT(31)
16484 PT2MI(MINT(36))=PT2
16485 IMISEP(MINT(31))=N+4
16486 DO 280 JS=1,2
16487 IMI(JS,MINT(31),1)=N+JS
16488 IMI(JS,MINT(31),2)=0
16489 XMI(JS,MINT(31))=VINT(40+JS)
16490 NMI(JS)=NMI(JS)+1
16491C...Update cumulative counters
16492 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
16493 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
16494 280 CONTINUE
16495
16496C...Add to list of final state partons
16497 IPART(NPART+1)=N+3
16498 IPART(NPART+2)=N+4
16499 PTPART(NPART+1)=SQRT(PT2)
16500 PTPART(NPART+2)=SQRT(PT2)
16501 NPART=NPART+2
16502
16503C...Initialize ISR
16504 NISGEN(1,MINT(31))=0
16505 NISGEN(2,MINT(31))=0
16506
16507C...Update ER
16508 N=N+4
16509 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
16510 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
16511 MINT(51)=1
16512 RETURN
16513 ENDIF
16514
16515C...Finally, assign colour tags to new partons
16516 DO 300 JS=1,2
16517 I1=IMI(JS,MINT(31),1)
16518 I2=IMI(3-JS,MINT(31),1)
16519 DO 290 JCS=4,5
16520 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
16521 & GOTO 290
16522 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
16523 KCS=JCS
16524 CALL PYCTTR(I1,KCS,I2)
16525 IF(MINT(51).NE.0) RETURN
16526 290 CONTINUE
16527 300 CONTINUE
16528
16529C----------------------------------------------------------------------
16530C...MODE=2: Decide whether quarks in last scattering were valence,
16531C...companion, or sea.
16532 ELSEIF (MODE.EQ.2) THEN
16533 JS=MINT(30)
16534 MI=MINT(36)
16535 PT2=PT2NOW
16536 KFSBM=ISIGN(1,MINT(10+JS))
16537 IFL=K(IMI(JS,MI,1),2)
16538 IMI(JS,MI,2)=0
16539 IF (IABS(IFL).GE.6) THEN
16540 IF (IABS(IFL).EQ.6) THEN
16541 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
16542 ENDIF
16543 RETURN
16544 ENDIF
16545C...Get PDFs at X(rescaled) and PT2 of the current initiator.
16546C...(Do not include the parton itself in the X rescaling.)
16547 X=XMI(JS,MI)
16548 XRSC=X/(VINT(142+JS)+X)
16549C...Note: XPSVC = x*pdf.
16550 MINT(30)=JS
16551C.... ALICE
16552C.... Store side in MINT(124)
16553 MINT(124) = JS
16554 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
16555 SEA=XPSVC(IFL,-1)
16556 VAL=XPSVC(IFL,0)
16557C...Ensure that pdfs are positive definite
16558 IF (SEA.LT.0D0) THEN
16559 CALL PYERRM(9,'(PYPTMI:) Sea distribution negative.')
16560 SEA=MAX(0D0,SEA)
16561 ELSEIF (VAL.LT.0D0) THEN
16562 CALL PYERRM(9,'(PYPTMI:) Val distribution negative.')
16563 VAL=MAX(0D0,VAL)
16564 ENDIF
16565 CMP=0D0
16566 DO 310 IVC=1,NVC(JS,IFL)
16567 CMP=CMP+XPSVC(IFL,IVC)
16568 310 CONTINUE
16569
16570 NTRY=0
16571C...Decide (Extra factor x cancels in the dvision).
16572 320 RVCS=PYR(0)*(SEA+VAL+CMP)
16573 IVNOW=1
16574 NTRY=NTRY+1
16575 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
16576C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
16577 IVNOW=0
16578 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
16579 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
16580 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
16581 IF(KFIVAL(JS,1).EQ.0) THEN
16582 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
16583 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
16584 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
16585 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
16586 ELSE
16587C...Count down valence remaining. Do not count current scattering.
16588 DO 340 I1=1,NMI(JS)
16589 IF (I1.EQ.MINT(36)) GOTO 340
16590 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
16591 & IVNOW=IVNOW-1
16592 340 CONTINUE
16593 ENDIF
16594 IF(IVNOW.EQ.0) GOTO 330
16595C...Mark valence.
16596 IMI(JS,MI,2)=0
16597C...Sets valence content of gamma, pi0, K0S, K0L if not done.
16598 IF(KFIVAL(JS,1).EQ.0) THEN
16599 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
16600 KFIVAL(JS,1)=IFL
16601 KFIVAL(JS,2)=-IFL
16602 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
16603 KFIVAL(JS,1)=IFL
16604 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
16605 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
16606 ENDIF
16607 ENDIF
16608
16609 ELSEIF (RVCS.LE.VAL+SEA) THEN
16610C...If sea, add opposite sign companion parton. Store X and I.
16611 NVC(JS,-IFL)=NVC(JS,-IFL)+1
16612 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
16613C...Set pointer to companion
16614 IMI(JS,MI,2)=-NVC(JS,-IFL)
16615
16616 ELSE
16617C...If companion, check whether we've got any in the books
16618 IF (NVC(JS,IFL).EQ.0) THEN
16619 CMP=0D0
16620C...Only report error first time for this event
16621 IF (NTRY.EQ.1)
16622 & CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
16623C...Try a few times
16624 IF (NTRY.LE.10) THEN
16625 GOTO 320
16626C... But if it stil fails, abort this event
16627 ELSE
16628 MINT(51)=1
16629 RETURN
16630 ENDIF
16631 ENDIF
16632C...If several possibilities, decide which one
16633 CMPSUM=VAL+SEA
16634 ISEL=0
16635 350 ISEL=ISEL+1
16636 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
16637 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
16638C...Find original sea (anti-)quark. Do not consider current scattering.
16639 IASSOC=0
16640 DO 360 I1=1,NMI(JS)
16641 IF (I1.EQ.MINT(36)) GOTO 360
16642 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
16643 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
16644 IMI(JS,MI,2)=IMI(JS,I1,1)
16645 IMI(JS,I1,2)=IMI(JS,MI,1)
16646 ENDIF
16647 360 CONTINUE
16648C...Mark companion "out-kicked".
16649 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
16650 ENDIF
16651
16652 ENDIF
16653 RETURN
16654 END
16655
16656C*********************************************************************
16657
16658C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
16659C...Giving the x*f pdf of a companion quark, with its partner at XS,
16660C...using an approximate gluon density like (1-X)^NPOW/X. The value
16661C...corresponds to an unrescaled range between 0 and 1-X.
16662
16663 FUNCTION PYFCMP(XC,XS,NPOW)
16664 IMPLICIT NONE
16665 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
16666 INTEGER NPOW
16667
16668 PYFCMP=0D0
16669C...Parent gluon momentum fraction
16670 Y=XC+XS
16671 IF (Y.GE.1D0) RETURN
16672C...Common factor (includes factor XC, since PYFCMP=x*f)
16673 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
16674C...Store normalized companion x*f distribution.
16675 IF (NPOW.LE.0) THEN
16676 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
16677 ELSEIF (NPOW.EQ.1) THEN
16678 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
16679 ELSEIF (NPOW.EQ.2) THEN
16680 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
16681 & +3D0*XS*(1D0+XS)*LOG(XS)))
16682 ELSEIF (NPOW.EQ.3) THEN
16683 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
16684 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16685 ELSEIF (NPOW.GE.4) THEN
16686 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
16687 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
16688 ENDIF
16689 RETURN
16690 END
16691
16692C*********************************************************************
16693
16694C...PYPCMP: Auxiliary to PYPDFU.
16695C...Giving the momentum integral of a companion quark, with its
16696C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
16697C...The value corresponds to an unrescaled range between 0 and 1-XS.
16698
16699 FUNCTION PYPCMP(XS,NPOW)
16700 IMPLICIT NONE
16701 DOUBLE PRECISION XS, PYPCMP
16702 INTEGER NPOW
16703 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
16704 PYPCMP=0D0
16705 ELSEIF (NPOW.LE.0) THEN
16706 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
16707 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
16708 ELSEIF (NPOW.EQ.1) THEN
16709 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
16710 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
16711 ELSEIF (NPOW.EQ.2) THEN
16712 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
16713 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
16714 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
16715 & -3D0*XS*LOG(XS)*(1+XS)))
16716 ELSEIF (NPOW.EQ.3) THEN
16717 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
16718 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
16719 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
16720 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16721 ELSE
16722 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
16723 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
16724 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
16725 & -6D0*XS*LOG(XS)*(1D0+XS)))
16726 ENDIF
16727 RETURN
16728 END
16729
16730C*********************************************************************
16731
16732C...PYUPRE
16733C...Rearranges contents of the HEPEUP commonblock so that
16734C...mothers precede daughters and daughters of a decay are
16735C...listed consecutively.
16736
16737 SUBROUTINE PYUPRE
16738
16739C...Double precision and integer declarations.
16740 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16741 IMPLICIT INTEGER(I-N)
16742
16743C...User process event common block.
16744 INTEGER MAXNUP
16745 PARAMETER (MAXNUP=500)
16746 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
16747 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
16748 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
16749 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
16750 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
16751 SAVE /HEPEUP/
16752
16753C...Local arrays.
16754 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
16755 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
16756 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
16757
16758C...Check whether a rearrangement is required.
16759 NEED=0
16760 DO 100 IUP=1,NUP
16761 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
16762 100 CONTINUE
16763 DO 110 IUP=2,NUP
16764 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
16765 110 CONTINUE
16766
16767 IF(NEED.NE.0) THEN
16768C...Find the new order that particles should have.
16769 NEWPOS(0)=0
16770 NNEW=0
16771 INEW=-1
16772 120 INEW=INEW+1
16773 DO 130 IUP=1,NUP
16774 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
16775 NNEW=NNEW+1
16776 NEWPOS(NNEW)=IUP
16777 ENDIF
16778 130 CONTINUE
16779 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
16780 IF(NNEW.NE.NUP) THEN
16781 CALL PYERRM(2,
16782 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
16783 RETURN
16784 ENDIF
16785
16786C...Copy old info into temporary storage.
16787 DO 150 I=1,NUP
16788 IDUPT(I)=IDUP(I)
16789 ISTUPT(I)=ISTUP(I)
16790 MOTUPT(1,I)=MOTHUP(1,I)
16791 MOTUPT(2,I)=MOTHUP(2,I)
16792 ICOUPT(1,I)=ICOLUP(1,I)
16793 ICOUPT(2,I)=ICOLUP(2,I)
16794 DO 140 J=1,5
16795 PUPT(J,I)=PUP(J,I)
16796 140 CONTINUE
16797 VTIUPT(I)=VTIMUP(I)
16798 SPIUPT(I)=SPINUP(I)
16799 150 CONTINUE
16800
16801C...Copy info back into HEPEUP in right order.
16802 DO 180 I=1,NUP
16803 IOLD=NEWPOS(I)
16804 IDUP(I)=IDUPT(IOLD)
16805 ISTUP(I)=ISTUPT(IOLD)
16806 MOTHUP(1,I)=0
16807 MOTHUP(2,I)=0
16808 DO 160 IMOT=1,I-1
16809 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
16810 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
16811 160 CONTINUE
16812 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
16813 MOTHSW=MOTHUP(1,I)
16814 MOTHUP(1,I)=MOTHUP(2,I)
16815 MOTHUP(2,I)=MOTHSW
16816 ENDIF
16817 ICOLUP(1,I)=ICOUPT(1,IOLD)
16818 ICOLUP(2,I)=ICOUPT(2,IOLD)
16819 DO 170 J=1,5
16820 PUP(J,I)=PUPT(J,IOLD)
16821 170 CONTINUE
16822 VTIMUP(I)=VTIUPT(IOLD)
16823 SPINUP(I)=SPIUPT(IOLD)
16824 180 CONTINUE
16825 ENDIF
16826
16827c...If incoming particles are massive recalculate to put them massless.
16828 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
16829 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
16830 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
16831 PUP(4,1)=0.5D0*PPLUS
16832 PUP(3,1)=PUP(4,1)
16833 PUP(5,1)=0D0
16834 PUP(4,2)=0.5D0*PMINUS
16835 PUP(3,2)=-PUP(4,2)
16836 PUP(5,2)=0D0
16837 ENDIF
16838
16839 RETURN
16840 END
16841
16842C*********************************************************************
16843
16844C...PYADSH
16845C...Administers the generation of successive final-state showers
16846C...in external processes.
16847
16848 SUBROUTINE PYADSH(NFIN)
16849
16850C...Double precision and integer declarations.
16851 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16852 IMPLICIT INTEGER(I-N)
16853 INTEGER PYK,PYCHGE,PYCOMP
16854C...Parameter statement for maximum size of showers.
16855 PARAMETER (MAXNUR=1000)
16856C...Commonblocks.
16857 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16858 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16859 COMMON/PYCTAG/NCT,MCT(4000,2)
16860 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16861 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16862 COMMON/PYINT1/MINT(400),VINT(400)
16863 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
16864C...Local array.
16865 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
16866
16867C...Set primary vertex.
16868 DO 100 J=1,5
16869 V(MINT(83)+5,J)=0D0
16870 V(MINT(83)+6,J)=0D0
16871 V(MINT(84)+1,J)=0D0
16872 V(MINT(84)+2,J)=0D0
16873 100 CONTINUE
16874
16875C...Isolate systems of particles with the same mother.
16876 NSYS=0
16877 IMS=-1
16878 DO 140 I=MINT(84)+3,NFIN
16879 IM=K(I,3)
16880 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
16881 IF(IM.NE.IMS) THEN
16882 NSYS=NSYS+1
16883 IBEG(NSYS)=I
16884 IMS=IM
16885 ENDIF
16886
16887C...Set production vertices.
16888 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
16889 & THEN
16890 DO 110 J=1,4
16891 V(I,J)=0D0
16892 110 CONTINUE
16893 ELSE
16894 DO 120 J=1,4
16895 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
16896 120 CONTINUE
16897 ENDIF
16898 IF(MSTP(125).GE.1) THEN
16899 IDOC=I-MSTP(126)+4
16900 DO 130 J=1,5
16901 V(IDOC,J)=V(I,J)
16902 130 CONTINUE
16903 ENDIF
16904 140 CONTINUE
16905
16906C...End loop over systems. Return if no showers to be performed.
16907 IBEG(NSYS+1)=NFIN+1
16908 IF(MSTP(71).LE.0) RETURN
16909
16910C...Loop through systems of particles; check that sensible size.
16911 DO 270 ISYS=1,NSYS
16912 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
16913 IF(MINT(35).LE.2) THEN
16914 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
16915 GOTO 270
16916 ELSEIF(NSIZ.LE.1) THEN
16917 CALL PYERRM(2,'(PYADSH:) only one particle in system')
16918 GOTO 270
16919 ELSEIF(NSIZ.GT.80) THEN
16920 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
16921 GOTO 270
16922 ENDIF
16923 ENDIF
16924
16925C...Save status codes and daughters of showering particles; reset them.
16926 DO 150 J=1,4
16927 PSUM(J)=0D0
16928 150 CONTINUE
16929 DO 170 II=1,NSIZ
16930 I=IBEG(ISYS)-1+II
16931 KSAV(II,1)=K(I,1)
16932 IF(K(I,1).GT.10) THEN
16933 K(I,1)=1
16934 IF(KSAV(II,1).EQ.14) K(I,1)=3
16935 ENDIF
16936 IF(KSAV(II,1).LE.10) THEN
16937 ELSEIF(K(I,1).EQ.1) THEN
16938 KSAV(II,4)=K(I,4)
16939 KSAV(II,5)=K(I,5)
16940 K(I,4)=0
16941 K(I,5)=0
16942 ELSE
16943 KSAV(II,4)=MOD(K(I,4),MSTU(5))
16944 KSAV(II,5)=MOD(K(I,5),MSTU(5))
16945 K(I,4)=K(I,4)-KSAV(II,4)
16946 K(I,5)=K(I,5)-KSAV(II,5)
16947 ENDIF
16948 DO 160 J=1,4
16949 PSUM(J)=PSUM(J)+P(I,J)
16950 160 CONTINUE
16951 170 CONTINUE
16952
16953C...Perform shower.
16954 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16955 & PSUM(3)**2))
16956 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16957 NSAV=N
16958 IF(MINT(35).LE.2) THEN
16959 IF(NSIZ.EQ.2) THEN
16960 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16961 ELSE
16962 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16963 ENDIF
16964
16965C...For external processes, first call, also ISR partons radiate.
16966C...Can use existing PYPART list, removing partons that radiate later.
16967 ELSEIF(ISYS.EQ.1) THEN
16968 NPARTN=0
16969 DO 175 II=1,NPART
16970 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16971 NPARTN=NPARTN+1
16972 IPART(NPARTN)=IPART(II)
16973 PTPART(NPARTN)=PTPART(II)
16974 ENDIF
16975 175 CONTINUE
16976 NPART=NPARTN
16977 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16978 ELSE
16979C...For subsequent calls use the systems excluded above.
16980 NPART=NSIZ
16981 NPARTD=0
16982 DO 180 II=1,NSIZ
16983 I=IBEG(ISYS)-1+II
16984 IPART(II)=I
16985 PTPART(II)=0.5D0*QMAX
16986 180 CONTINUE
16987 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16988 ENDIF
16989
16990C...Look up showered copies of original showering particles.
16991 DO 260 II=1,NSIZ
16992 I=IBEG(ISYS)-1+II
16993 IMV=I
16994C...Particles without daughters need not be studied.
16995 IF(KSAV(II,1).LE.10) GOTO 260
16996 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16997 ELSEIF(K(I,1).EQ.11) THEN
16998 190 IMV=MOD(K(IMV,4),MSTU(5))
16999 IF(K(IMV,1).EQ.11) GOTO 190
17000 ELSE
17001 KDA1=MOD(K(I,4),MSTU(5))
17002 IF(KDA1.GT.0) THEN
17003 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17004 ENDIF
17005 KDA2=MOD(K(I,5),MSTU(5))
17006 IF(KDA2.GT.0) THEN
17007 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17008 ENDIF
17009 DO 200 I3=I+1,N
17010 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
17011 & THEN
17012 IMV=I3
17013 KDA1=MOD(K(I3,4),MSTU(5))
17014 IF(KDA1.GT.0) THEN
17015 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17016 ENDIF
17017 KDA2=MOD(K(I3,5),MSTU(5))
17018 IF(KDA2.GT.0) THEN
17019 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17020 ENDIF
17021 ENDIF
17022 200 CONTINUE
17023 ENDIF
17024
17025C...Restore daughter info of original partons to showered copies.
17026 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
17027 IF(KSAV(II,1).LE.10) THEN
17028 ELSEIF(K(I,1).EQ.1) THEN
17029 K(IMV,4)=KSAV(II,4)
17030 K(IMV,5)=KSAV(II,5)
17031 ELSE
17032 K(IMV,4)=K(IMV,4)+KSAV(II,4)
17033 K(IMV,5)=K(IMV,5)+KSAV(II,5)
17034 ENDIF
17035
17036C...Reset mother info of existing daughters to showered copies.
17037 DO 210 I3=IBEG(ISYS+1),NFIN
17038 IF(K(I3,3).EQ.I) K(I3,3)=IMV
17039 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
17040 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
17041 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
17042 ENDIF
17043 210 CONTINUE
17044
17045C...Boost all original daughters to new frame of showered copy.
17046C...Also update their colour tags.
17047 IF(IMV.NE.I) THEN
17048 DO 220 J=1,3
17049 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
17050 220 CONTINUE
17051 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
17052 DO 230 J=1,3
17053 BETA(J)=FAC*BETA(J)
17054 230 CONTINUE
17055 DO 250 I3=IBEG(ISYS+1),NFIN
17056 IMO=I3
17057 240 IMO=K(IMO,3)
17058 IF(MSTP(128).LE.0) THEN
17059 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
17060 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
17061 & THEN
17062 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
17063 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
17064 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
17065 ENDIF
17066 ELSE
17067 IF(IMO.EQ.IMV) THEN
17068 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
17069 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
17070 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
17071 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
17072 GOTO 240
17073 ENDIF
17074 ENDIF
17075 250 CONTINUE
17076 ENDIF
17077 260 CONTINUE
17078
17079C...End of loop over showering systems
17080 270 CONTINUE
17081
17082 RETURN
17083 END
17084
17085C*********************************************************************
17086
17087C...PYVETO
17088C...Interface to UPVETO, which allows user to veto event generation
17089C...on the parton level, after parton showers but before multiple
17090C...interactions, beam remnants and hadronization is added.
17091
17092 SUBROUTINE PYVETO(IVETO)
17093
17094C...All real arithmetic in double precision.
17095 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17096C...Three Pythia functions return integers, so need declaring.
17097 INTEGER PYK,PYCHGE,PYCOMP
17098
17099C...PYTHIA commonblocks.
17100 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
17101 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17102 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17103 COMMON/PYINT1/MINT(400),VINT(400)
17104 SAVE /PYJETS/,/PYPARS/,/PYINT1/
17105C...HEPEVT commonblock.
17106 PARAMETER (NMXHEP=4000)
17107 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17108 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
17109 DOUBLE PRECISION PHEP,VHEP
17110 SAVE /HEPEVT/
17111C...Local array.
17112 DIMENSION IRESO(100)
17113
17114C...Define longitudinal boost from initiator rest frame to cm frame.
17115 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
17116 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
17117
17118C...Presentation is different if using pT-ordered shower
17119 IF(MINT(35).EQ.3) THEN
17120 GAMMA=1D0
17121 GABEZ=0D0
17122 ENDIF
17123
17124C... Reset counters.
17125 NEVHEP=0
17126 NHEP=0
17127 NRESO=0
17128
17129C...Oth pass: identify beam and incoming partons
17130 DO 140 I=MINT(83)+1,MINT(83)+6
17131 ISTORE=0
17132 IF(K(I,2).EQ.94) THEN
17133
17134 ELSE
17135 NRESO=NRESO+1
17136 IRESO(NRESO)=I
17137 IMOTH=K(I,3)
17138 ENDIF
17139 140 CONTINUE
17140
17141C...First pass: identify final locations of resonances
17142C...and of their daughters before showering.
17143 DO 150 I=MINT(84)+3,N
17144 ISTORE=0
17145 IMOTH=0
17146
17147C...Skip shower CM frame documentation lines.
17148 IF(K(I,2).EQ.94) THEN
17149
17150C... Store a new intermediate product, when mother in documentation.
17151 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
17152 & K(I,3).LE.MINT(84)) THEN
17153 ISTORE=1
17154 NHEP=NHEP+1
17155 II=NHEP
17156 NRESO=NRESO+1
17157 IRESO(NRESO)=I
17158 IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
17159
17160C... Store a new intermediate product, when mother in main section.
17161 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
17162 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
17163 ISTORE=1
17164 NHEP=NHEP+1
17165 II=NHEP
17166 NRESO=NRESO+1
17167 IRESO(NRESO)=I
17168 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
17169 ENDIF
17170
17171 IF(ISTORE.EQ.1) THEN
17172C...Copy parton info, boosting momenta along z axis to cm frame.
17173 ISTHEP(II)=2
17174 IDHEP(II)=K(I,2)
17175 PHEP(1,II)=P(I,1)
17176 PHEP(2,II)=P(I,2)
17177 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
17178 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
17179 PHEP(5,II)=P(I,5)
17180C...Store one mother. Rest of history and vertex info zeroed.
17181 JMOHEP(1,II)=IMOTH
17182 JMOHEP(2,II)=0
17183 JDAHEP(1,II)=0
17184 JDAHEP(2,II)=0
17185 VHEP(1,II)=0D0
17186 VHEP(2,II)=0D0
17187 VHEP(3,II)=0D0
17188 VHEP(4,II)=0D0
17189 ENDIF
17190 150 CONTINUE
17191
17192C...Second pass: identify current set of "final" partons.
17193 DO 200 I=MINT(84)+3,N
17194 ISTORE=0
17195 IMOTH=0
17196
17197C...Store a final parton.
17198 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
17199 ISTORE=1
17200 NHEP=NHEP+1
17201 II=NHEP
17202C..Trace it back through shower, to check if from documented particle.
17203 IHIST=I
17204 ISAVE=IHIST
17205 160 CONTINUE
17206 IF(IHIST.GT.MINT(84)) THEN
17207 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
17208 DO 170 IRI=1,NRESO
17209 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
17210 170 CONTINUE
17211 ISAVE=IHIST
17212 IHIST=K(IHIST,3)
17213 IF(IMOTH.EQ.0) GOTO 160
17214 IMOTH=MAX(0,IMOTH-6)
17215 ELSEIF(IHIST.LE.4) THEN
17216 IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
17217 ISTORE=0
17218 NHEP=NHEP-1
17219 ELSE
17220 IMOTH=0
17221 ENDIF
17222 ENDIF
17223 ENDIF
17224
17225 IF(ISTORE.EQ.1) THEN
17226C...Copy parton info, boosting momenta along z axis to cm frame.
17227 ISTHEP(II)=1
17228 IDHEP(II)=K(I,2)
17229 PHEP(1,II)=P(I,1)
17230 PHEP(2,II)=P(I,2)
17231 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
17232 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
17233 PHEP(5,II)=P(I,5)
17234C...Store one mother. Rest of history and vertex info zeroed.
17235 JMOHEP(1,II)=IMOTH
17236 JMOHEP(2,II)=0
17237 JDAHEP(1,II)=0
17238 JDAHEP(2,II)=0
17239 VHEP(1,II)=0D0
17240 VHEP(2,II)=0D0
17241 VHEP(3,II)=0D0
17242 VHEP(4,II)=0D0
17243 ENDIF
17244 200 CONTINUE
17245C...Call user-written routine to decide whether to keep events.
17246 CALL UPVETO(IVETO)
17247 RETURN
17248 END
17249C*********************************************************************
17250
17251C...PYRESD
17252C...Allows resonances to decay (including parton showers for hadronic
17253C...channels).
17254
17255 SUBROUTINE PYRESD(IRES)
17256
17257C...Double precision and integer declarations.
17258 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17259 IMPLICIT INTEGER(I-N)
17260 INTEGER PYK,PYCHGE,PYCOMP
17261C...Parameter statement to help give large particle numbers.
17262 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
17263 &KEXCIT=4000000,KDIMEN=5000000)
17264C...Parameter statement for maximum size of showers.
17265 PARAMETER (MAXNUR=1000)
17266C...Commonblocks.
17267 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
17268 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
17269 COMMON/PYCTAG/NCT,MCT(4000,2)
17270 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17271 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
17272 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
17273 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
17274 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17275 COMMON/PYINT1/MINT(400),VINT(400)
17276 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
17277 COMMON/PYINT4/MWID(500),WIDS(500,5)
17278 COMMON/PYPUED/IUED(0:99),RUED(0:99)
17279 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
17280 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/
17281C...Local arrays and complex and character variables.
17282 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
17283 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(4),ILIN(6),
17284 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
17285 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),VDCY(4),
17286 &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(4),ITRI(4),IOCT(4),KCQ4(3),
17287 &KFL4(3)
17288 COMPLEX FGK,HA(6,6),HC(6,6)
17289 REAL TIR,UIR
17290 CHARACTER CODE*9,MASS*9
17291C...Local arrays.
17292 DIMENSION PV(10,5),RORD(10),UE(3),BE(3),WTCOR(10)
17293 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
17294
17295C...Functions: momentum in two-particle decays and four-product.
17296 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
17297
17298C...The F, Xi and Xj functions of Gunion and Kunszt
17299C...(Phys. Rev. D33, 665, plus errata from the authors).
17300 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
17301 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
17302 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
17303 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
17304 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
17305 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
17306 &2D0*(D34/D56+D56/D34))
17307
17308C...Some general constants.
17309 XW=PARU(102)
17310 XWV=XW
17311 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
17312 XW1=1D0-XW
17313 SQMZ=PMAS(23,1)**2
17314
17315 GMMZ=PMAS(23,1)*PMAS(23,2)
17316 SQMW=PMAS(24,1)**2
17317 GMMW=PMAS(24,1)*PMAS(24,2)
17318 SH=VINT(44)
17319
17320C...Boost and rotate to rest frame of incoming partons,
17321C...to get proper amount of smearing of decay angles.
17322 IBST=0
17323 IF(IRES.EQ.0) THEN
17324 IBST=1
17325 IIN1=MINT(84)+1
17326 IIN2=MINT(84)+2
17327C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons
17328C...(101,102) are off shell and can have inconsistent momenta, resulting
17329C...in boosts larger than unity. However, the corresponding docu partons
17330C...(5,6) are kept on shell, and have consistent momenta that can be used
17331C...to derive this boost instead. Ultimately, should change the way the new
17332C...shower stores intermediate partons, but just using partons (5,6) for now
17333C...does define the boost and furnishes a quick and much needed solution.
17334 IF (MINT(35).EQ.3) THEN
17335 IIN1=MINT(83)+5
17336 IIN2=MINT(83)+6
17337 ENDIF
17338 ETOTIN=P(IIN1,4)+P(IIN2,4)
17339 BEXIN=(P(IIN1,1)+P(IIN2,1))/ETOTIN
17340 BEYIN=(P(IIN1,2)+P(IIN2,2))/ETOTIN
17341 BEZIN=(P(IIN1,3)+P(IIN2,3))/ETOTIN
17342 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
17343 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
17344 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
17345 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
17346 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
17347 ENDIF
17348
17349C...Reset original resonance configuration.
17350 DO 100 JT=1,8
17351 IREF(1,JT)=0
17352 100 CONTINUE
17353
17354C...Define initial one, two or three objects for subprocess.
17355 IHDEC=0
17356 IF(IRES.EQ.0) THEN
17357 ISUB=MINT(1)
17358 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
17359 IREF(1,1)=MINT(84)+2+ISET(ISUB)
17360 IREF(1,4)=MINT(83)+6+ISET(ISUB)
17361 JTMAX=1
17362 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
17363 IREF(1,1)=MINT(84)+1+ISET(ISUB)
17364 IREF(1,2)=MINT(84)+2+ISET(ISUB)
17365 IREF(1,4)=MINT(83)+5+ISET(ISUB)
17366 IREF(1,5)=MINT(83)+6+ISET(ISUB)
17367 JTMAX=2
17368 ELSEIF(ISET(ISUB).EQ.5) THEN
17369 IREF(1,1)=MINT(84)+3
17370 IREF(1,2)=MINT(84)+4
17371 IREF(1,3)=MINT(84)+5
17372 IREF(1,4)=MINT(83)+7
17373 IREF(1,5)=MINT(83)+8
17374 IREF(1,6)=MINT(83)+9
17375 JTMAX=3
17376 ENDIF
17377
17378C...Define original resonance for odd cases.
17379 ELSE
17380 ISUB=0
17381 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
17382 & IHDEC=1
17383 IF(IHDEC.EQ.1) ISUB=3
17384 IREF(1,1)=IRES
17385 IREF(1,4)=K(IRES,3)
17386 IRESTM=IRES
17387 IF(IREF(1,4).GT.MINT(84)) THEN
17388 110 ITMPMO=IREF(1,4)
17389 IF(K(ITMPMO,2).EQ.94) THEN
17390 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
17391 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
17392 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
17393 IRESTM=ITMPMO
17394C...Explicitly check that reference particle exists, otherwise stop recursion
17395 IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
17396 IREF(1,4)=K(ITMPMO,3)
17397 GOTO 110
17398 ENDIF
17399 ENDIF
17400 ENDIF
17401 IF(IREF(1,4).GT.MINT(84)) THEN
17402 EMATCH=1D10
17403 IREF14=IREF(1,4)
17404 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
17405 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
17406 & EMATCH) THEN
17407 IREF(1,4)=II
17408 EMATCH=ABS(P(II,4)-P(IREF14,4))
17409 ENDIF
17410 120 CONTINUE
17411 ENDIF
17412 JTMAX=1
17413 ENDIF
17414
17415C...Check if initial resonance has been moved (in resonance + jet).
17416 DO 140 JT=1,3
17417 IF(IREF(1,JT).GT.0) THEN
17418 IF(K(IREF(1,JT),1).GT.10) THEN
17419 KFA=IABS(K(IREF(1,JT),2))
17420 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
17421 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17422 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17423 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17424 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17425 ENDIF
17426 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17427 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17428 ENDIF
17429 DO 130 I=IREF(1,JT)+1,N
17430 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
17431 & I.EQ.KDA2)) THEN
17432 IREF(1,JT)=I
17433 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17434 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17435 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17436 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17437 ENDIF
17438 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17439 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17440 ENDIF
17441 ENDIF
17442 130 CONTINUE
17443 ELSE
17444 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
17445 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
17446 ENDIF
17447 ENDIF
17448 ENDIF
17449 140 CONTINUE
17450
17451C...Set decay vertex for initial resonances
17452 DO 160 JT=1,JTMAX
17453 DO 150 I=1,4
17454 V(IREF(1,JT),I)=0D0
17455 150 CONTINUE
17456 160 CONTINUE
17457
17458C...Loop over decay history.
17459 NP=1
17460 IP=0
17461 170 IP=IP+1
17462 NINH=0
17463 JTMAX=2
17464 IF(IREF(IP,2).EQ.0) JTMAX=1
17465 IF(IREF(IP,3).NE.0) JTMAX=3
17466 IT4=0
17467 NSAV=N
17468
17469C...Check for Higgs which appears as decay product of user-process.
17470 IF(ISUB.EQ.0) THEN
17471 IHDEC=0
17472 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17473 & .EQ.36) IHDEC=1
17474 IF(IHDEC.EQ.1) ISUB=3
17475 ENDIF
17476
17477C...Start treatment of one, two or three resonances in parallel.
17478 180 N=NSAV
17479 DO 340 JT=1,JTMAX
17480 ID=IREF(IP,JT)
17481 KDCY(JT)=0
17482 KFL1(JT)=0
17483 KFL2(JT)=0
17484 KFL3(JT)=0
17485 KFL4(JT)=0
17486 KEQL(JT)=0
17487 NSD(JT)=ID
17488 ITJUNC(JT)=0
17489
17490C...Check whether particle can/is allowed to decay.
17491 IF(ID.EQ.0) GOTO 330
17492 KFA=IABS(K(ID,2))
17493 KCA=PYCOMP(KFA)
17494 IF(MWID(KCA).EQ.0) GOTO 330
17495 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
17496 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
17497 & KFA.EQ.18) IT4=IT4+1
17498 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
17499 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
17500
17501C...Choose lifetime and determine decay vertex.
17502 IF(K(ID,1).EQ.5) THEN
17503 V(ID,5)=0D0
17504 ELSEIF(K(ID,1).NE.4) THEN
17505 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
17506 ENDIF
17507 DO 190 J=1,4
17508 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
17509 190 CONTINUE
17510
17511C...Determine whether decay allowed or not.
17512 MOUT=0
17513 IF(MSTJ(22).EQ.2) THEN
17514 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
17515 ELSEIF(MSTJ(22).EQ.3) THEN
17516 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
17517 ELSEIF(MSTJ(22).EQ.4) THEN
17518 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
17519 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
17520 ENDIF
17521 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
17522 K(ID,1)=4
17523 GOTO 330
17524 ENDIF
17525
17526C...Info for selection of decay channel: sign, pairings.
17527 IF(KCHG(KCA,3).EQ.0) THEN
17528 IPM=2
17529 ELSE
17530 IPM=(5-ISIGN(1,K(ID,2)))/2
17531 ENDIF
17532 KFB=0
17533 IF(JTMAX.EQ.2) THEN
17534 KFB=IABS(K(IREF(IP,3-JT),2))
17535 ELSEIF(JTMAX.EQ.3) THEN
17536 JT2=JT+1-3*(JT/3)
17537 KFB=IABS(K(IREF(IP,JT2),2))
17538 IF(KFB.NE.KFA) THEN
17539 JT2=JT+2-3*((JT+1)/3)
17540 KFB=IABS(K(IREF(IP,JT2),2))
17541 ENDIF
17542 ENDIF
17543
17544C...Select decay channel.
17545 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
17546 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
17547 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
17548 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
17549 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
17550 IF(WDTE0S.LE.0D0) GOTO 330
17551 RKFL=WDTE0S*PYR(0)
17552 IDL=0
17553 200 IDL=IDL+1
17554 IDC=IDL+MDCY(KCA,2)-1
17555 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
17556 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
17557 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
17558
17559 NPROD=0
17560C...Read out flavours and colour charges of decay channel chosen.
17561 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
17562 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
17563 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
17564 KFC1A=PYCOMP(IABS(KFL1(JT)))
17565 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
17566 NPROD=NPROD+1
17567 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
17568 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
17569 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
17570 KFC2A=PYCOMP(IABS(KFL2(JT)))
17571 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
17572 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
17573 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
17574 NPROD=NPROD+1
17575 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
17576 KCQ3(JT)=0
17577 KFL4(JT)=KFDP(IDC,4)*ISIGN(1,K(ID,2))
17578 KCQ4(JT)=0
17579 IF(KFL3(JT).NE.0) THEN
17580 KFC3A=PYCOMP(IABS(KFL3(JT)))
17581 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
17582 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
17583 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
17584 NPROD=NPROD+1
17585 IF(KFL4(JT).NE.0) THEN
17586 KFC4A=PYCOMP(IABS(KFL4(JT)))
17587 IF(KCHG(KFC4A,3).EQ.0) KFL4(JT)=IABS(KFL4(JT))
17588 KCQ4(JT)=KCHG(KFC4A,2)*ISIGN(1,KFL4(JT))
17589 IF(KCQ4(JT).EQ.-2) KCQ4(JT)=2
17590 NPROD=NPROD+1
17591 ENDIF
17592 ENDIF
17593
17594C...Set/save further info on channel.
17595 KDCY(JT)=1
17596 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
17597 NSD(JT)=N
17598 HGZ(JT,1)=VINT(111)
17599 HGZ(JT,2)=VINT(112)
17600 HGZ(JT,3)=VINT(114)
17601 JTZ=JT
17602
17603 PXSUM=0D0
17604C...Select masses; to begin with assume resonances narrow.
17605 DO 220 I=1,4
17606 P(N+I,5)=0D0
17607 PMMN(I)=0D0
17608 IF(I.EQ.1) THEN
17609 KFLW=IABS(KFL1(JT))
17610 KCW=KFC1A
17611 ELSEIF(I.EQ.2) THEN
17612 KFLW=IABS(KFL2(JT))
17613 KCW=KFC2A
17614 ELSEIF(I.EQ.3) THEN
17615 IF(KFL3(JT).EQ.0) GOTO 220
17616 KFLW=IABS(KFL3(JT))
17617 KCW=KFC3A
17618 ELSEIF(I.EQ.4) THEN
17619 IF(KFL4(JT).EQ.0) GOTO 220
17620 KFLW=IABS(KFL4(JT))
17621 KCW=KFC4A
17622 ENDIF
17623 P(N+I,5)=PMAS(KCW,1)
17624 PXSUM=PXSUM+P(N+I,5)
17625CMRENNA++
17626C...This prevents SUSY/t particles from becoming too light.
17627 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
17628 PMMN(I)=PMAS(KCW,1)
17629 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
17630 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
17631 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
17632 & PMAS(PYCOMP(KFDP(IDC,2)),1)
17633 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
17634 & PMAS(PYCOMP(KFDP(IDC,3)),1)
17635 IF(KFDP(IDC,4).NE.0) PMSUM=PMSUM+
17636 & PMAS(PYCOMP(KFDP(IDC,4)),1)
17637 PMMN(I)=MIN(PMMN(I),PMSUM)
17638 ENDIF
17639 210 CONTINUE
17640C MRENNA--
17641 ELSEIF(KFLW.EQ.6) THEN
17642 PMMN(I)=PMAS(24,1)+PMAS(5,1)
17643 ENDIF
17644C...UED: select a graviton mass from continuous distribution
17645C...(stored in PMAS(39,1) so no value returned)
17646 IF (IUED(1).EQ.1.AND.IUED(2).EQ.1.AND.KFLW.EQ.39)
17647 & CALL PYGRAM(1)
17648 220 CONTINUE
17649
17650C...Check which two out of three are widest.
17651 IWID1=1
17652 IWID2=2
17653 PWID1=PMAS(KFC1A,2)
17654 PWID2=PMAS(KFC2A,2)
17655 KFLW1=IABS(KFL1(JT))
17656 KFLW2=IABS(KFL2(JT))
17657 IF(KFL3(JT).NE.0) THEN
17658 PWID3=PMAS(KFC3A,2)
17659 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
17660 IWID1=3
17661 PWID1=PWID3
17662 KFLW1=IABS(KFL3(JT))
17663 ELSEIF(PWID3.GT.PWID2) THEN
17664 IWID2=3
17665 PWID2=PWID3
17666 KFLW2=IABS(KFL3(JT))
17667 ENDIF
17668 ENDIF
17669 IF(KFL4(JT).NE.0) THEN
17670 PWID4=PMAS(KFC4A,2)
17671 IF(PWID4.GT.PWID1.AND.PWID2.GE.PWID1) THEN
17672 IWID1=4
17673 PWID1=PWID4
17674 KFLW1=IABS(KFL4(JT))
17675 ELSEIF(PWID4.GT.PWID2) THEN
17676 IWID2=4
17677 PWID2=PWID4
17678 KFLW2=IABS(KFL4(JT))
17679 ENDIF
17680 ENDIF
17681
17682C...If all narrow then only check that masses consistent.
17683 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
17684 & PWID2.LT.PARP(41))) THEN
17685CMRENNA++
17686C....Handle near degeneracy cases.
17687 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
17688 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17689 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
17690 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
17691 ENDIF
17692 ENDIF
17693CMRENNA--
17694 IF(PXSUM.GT.P(ID,5)) THEN
17695 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
17696 MINT(51)=1
17697 GOTO 720
17698 ELSEIF(PXSUM+PARJ(64).GT.P(ID,5)) THEN
17699 CALL PYERRM(3,'(PYRESD:) masses+PARJ(64) too large')
17700 MINT(51)=1
17701 GOTO 720
17702 ENDIF
17703
17704C...For three wide resonances select narrower of three
17705C...according to BW decoupled from rest.
17706 ELSE
17707 PMTOT=P(ID,5)
17708 IF(KFL3(JT).NE.0) THEN
17709 IWID3=6-IWID1-IWID2
17710 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
17711 & KFLW1-KFLW2
17712 LOOP=0
17713 230 LOOP=LOOP+1
17714 P(N+IWID3,5)=PYMASS(KFLW3)
17715 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
17716 PMTOT=PMTOT-P(N+IWID3,5)
17717 ENDIF
17718C...Select other two correlated within remaining phase space.
17719 IF(IP.EQ.1) THEN
17720 CKIN45=CKIN(45)
17721 CKIN47=CKIN(47)
17722 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
17723 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
17724 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17725 & P(N+IWID2,5))
17726 CKIN(45)=CKIN45
17727 CKIN(47)=CKIN47
17728 ELSE
17729 CKIN(49)=PMMN(IWID1)
17730 CKIN(50)=PMMN(IWID2)
17731 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17732 & P(N+IWID2,5))
17733 CKIN(49)=0D0
17734 CKIN(50)=0D0
17735 ENDIF
17736 IF(MINT(51).EQ.1) GOTO 720
17737 ENDIF
17738
17739C...Begin fill decay products, with colour flow for coloured objects.
17740 MSTU10=MSTU(10)
17741 MSTU(10)=1
17742 MSTU(19)=1
17743
17744
17745C...Three-body decays
17746 IF(KFL3(JT).NE.0.OR.KFL4(JT).NE.0) THEN
17747 DO 250 I=N+1,N+NPROD
17748 DO 240 J=1,5
17749 K(I,J)=0
17750 V(I,J)=0D0
17751 240 CONTINUE
17752 MCT(I,1)=0
17753 MCT(I,2)=0
17754 250 CONTINUE
17755 K(N+1,1)=1
17756 K(N+1,2)=KFL1(JT)
17757 K(N+2,1)=1
17758 K(N+2,2)=KFL2(JT)
17759 K(N+3,1)=1
17760 K(N+3,2)=KFL3(JT)
17761 IF(KFL4(JT).NE.0) THEN
17762 K(N+4,1)=1
17763 K(N+4,2)=KFL4(JT)
17764 ENDIF
17765 IDIN=ID
17766
17767C...Generate kinematics (default is flat)
17768 IF(KFL4(JT).EQ.0) THEN
17769 CALL PYTBDY(IDIN)
17770 ELSE
17771 PS=P(N+1,5)+P(N+2,5)+P(N+3,5)+P(N+4,5)
17772 ND=4
17773 PV(1,1)=0D0
17774 PV(1,2)=0D0
17775 PV(1,3)=0D0
17776 PV(1,4)=P(IDIN,5)
17777 PV(1,5)=P(IDIN,5)
17778C...Calculate maximum weight ND-particle decay.
17779 PV(ND,5)=P(N+ND,5)
17780 WTMAX=1D0/WTCOR(ND-2)
17781 PMAX=PV(1,5)-PS+P(N+ND,5)
17782 PMIN=0D0
17783 DO 381 IL=ND-1,1,-1
17784 PMAX=PMAX+P(N+IL,5)
17785 PMIN=PMIN+P(N+IL+1,5)
17786 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
17787 381 CONTINUE
17788
17789C...M-generator gives weight. If rejected, try again.
17790
17791 411 RORD(1)=1D0
17792 DO 441 IL1=2,ND-1
17793 RSAV=PYR(0)
17794 DO 421 IL2=IL1-1,1,-1
17795 IF(RSAV.LE.RORD(IL2)) GOTO 431
17796 RORD(IL2+1)=RORD(IL2)
17797 421 CONTINUE
17798 431 RORD(IL2+1)=RSAV
17799 441 CONTINUE
17800 RORD(ND)=0D0
17801 WT=1D0
17802 DO 451 IL=ND-1,1,-1
17803 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
17804 & (PV(1,5)-PS)
17805 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
17806 451 CONTINUE
17807 IF(WT.LT.PYR(0)*WTMAX) GOTO 411
17808
17809C...Perform two-particle decays in respective CM frame.
17810 DO 481 IL=1,ND-1
17811 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
17812 UE(3)=2D0*PYR(0)-1D0
17813 PHIX=PARU(2)*PYR(0)
17814 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHIX)
17815 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHIX)
17816 DO 471 J=1,3
17817 P(N+IL,J)=PA*UE(J)
17818 PV(IL+1,J)=-PA*UE(J)
17819 471 CONTINUE
17820 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
17821 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
17822 481 CONTINUE
17823
17824C...Lorentz transform decay products to lab frame.
17825 DO 491 J=1,4
17826 P(N+ND,J)=PV(ND,J)
17827 491 CONTINUE
17828 DO 531 IL=ND-1,1,-1
17829 DO 501 J=1,3
17830 BE(J)=PV(IL,J)/PV(IL,4)
17831 501 CONTINUE
17832 GA=PV(IL,4)/PV(IL,5)
17833 DO 521 I=N+IL,N+ND
17834 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
17835 DO 511 J=1,3
17836 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
17837 511 CONTINUE
17838 P(I,4)=GA*(P(I,4)+BEP)
17839 521 CONTINUE
17840 531 CONTINUE
17841
17842 ENDIF
17843
17844C...Set generic colour flows whenever unambiguous,
17845C...(independently of the order of the decay products)
17846C...Sum up total colour content
17847 NANT=0
17848 NTRI=0
17849 NOCT=0
17850 KCQ(0)=KCQM(JT)
17851 KCQ(1)=KCQ1(JT)
17852 KCQ(2)=KCQ2(JT)
17853 KCQ(3)=KCQ3(JT)
17854 KCQ(4)=KCQ4(JT)
17855 DO 255 J=0,NPROD
17856 IF (KCQ(J).EQ.-1) THEN
17857 NANT=NANT+1
17858 IANT(NANT)=N+J
17859 ELSEIF (KCQ(J).EQ.1) THEN
17860 NTRI=NTRI+1
17861 ITRI(NTRI)=N+J
17862 ELSEIF (KCQ(J).EQ.2) THEN
17863 NOCT=NOCT+1
17864 IOCT(NOCT)=N+J
17865 ENDIF
17866 255 CONTINUE
17867
17868C...Set color flow for generic 1 -> N processes (N arbitrary)
17869 IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
17870C...All singlets: do nothing
17871
17872 ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
17873C...Two octets, zero triplets, n singlets:
17874 IF (KCQ(0).EQ.2) THEN
17875C...8 -> 8 + n(1)
17876 K(ID,4)=K(ID,4)+IOCT(2)
17877 K(ID,5)=K(ID,5)+IOCT(2)
17878 K(IOCT(2),1)=3
17879 K(IOCT(2),4)=MSTU(5)*ID
17880 K(IOCT(2),5)=MSTU(5)*ID
17881 MCT(IOCT(2),1)=MCT(ID,1)
17882 MCT(IOCT(2),2)=MCT(ID,2)
17883 ELSE
17884C...1 -> 8 + 8 + n(1)
17885 K(IOCT(1),1)=3
17886 K(IOCT(1),4)=MSTU(5)*IOCT(2)
17887 K(IOCT(1),5)=MSTU(5)*IOCT(2)
17888 K(IOCT(2),1)=3
17889 K(IOCT(2),4)=MSTU(5)*IOCT(1)
17890 K(IOCT(2),5)=MSTU(5)*IOCT(1)
17891 NCT=NCT+1
17892 MCT(IOCT(1),1)=NCT
17893 MCT(IOCT(2),2)=NCT
17894 NCT=NCT+1
17895 MCT(IOCT(2),1)=NCT
17896 MCT(IOCT(1),2)=NCT
17897 ENDIF
17898
17899 ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
17900C...Two triplets, zero octets, n singlets.
17901 IF (KCQ(0).EQ.1) THEN
17902C...3 -> 3 + n(1)
17903 K(ID,4)=K(ID,4)+ITRI(2)
17904 K(ITRI(2),1)=3
17905 K(ITRI(2),4)=MSTU(5)*ID
17906 MCT(ITRI(2),1)=MCT(ID,1)
17907 ELSEIF (KCQ(0).EQ.-1) THEN
17908C...3bar -> 3bar + n(1)
17909 K(ID,5)=K(ID,5)+IANT(2)
17910 K(IANT(2),1)=3
17911 K(IANT(2),5)=MSTU(5)*ID
17912 MCT(IANT(2),2)=MCT(ID,2)
17913 ELSE
17914C...1 -> 3 + 3bar + n(1)
17915 K(ITRI(1),1)=3
17916 K(ITRI(1),4)=MSTU(5)*IANT(1)
17917 K(IANT(1),1)=3
17918 K(IANT(1),5)=MSTU(5)*ITRI(1)
17919 NCT=NCT+1
17920 MCT(ITRI(1),1)=NCT
17921 MCT(IANT(1),2)=NCT
17922 ENDIF
17923
17924 ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
17925C...Two triplets, one octet, n singlets.
17926 IF (KCQ(0).EQ.2) THEN
17927C...8 -> 3 + 3bar + n(1)
17928 K(ID,4)=K(ID,4)+ITRI(1)
17929 K(ID,5)=K(ID,5)+IANT(1)
17930 K(ITRI(1),1)=3
17931 K(ITRI(1),4)=MSTU(5)*ID
17932 K(IANT(1),1)=3
17933 K(IANT(1),5)=MSTU(5)*ID
17934 MCT(ITRI(1),1)=MCT(ID,1)
17935 MCT(IANT(1),2)=MCT(ID,2)
17936 ELSEIF (KCQ(0).EQ.1) THEN
17937C...3 -> 8 + 3 + n(1)
17938 K(ID,4)=K(ID,4)+IOCT(1)
17939 K(IOCT(1),1)=3
17940 K(IOCT(1),4)=MSTU(5)*ID
17941 K(IOCT(1),5)=MSTU(5)*ITRI(2)
17942 K(ITRI(2),1)=3
17943 K(ITRI(2),4)=MSTU(5)*IOCT(1)
17944 MCT(IOCT(1),1)=MCT(ID,1)
17945 NCT=NCT+1
17946 MCT(IOCT(1),2)=NCT
17947 MCT(ITRI(2),1)=NCT
17948 ELSEIF (KCQ(0).EQ.-1) THEN
17949C...3bar -> 8 + 3bar + n(1)
17950 K(ID,5)=K(ID,5)+IOCT(1)
17951 K(IOCT(1),1)=3
17952 K(IOCT(1),5)=MSTU(5)*ID
17953 K(IOCT(1),4)=MSTU(5)*IANT(2)
17954 K(IANT(2),1)=3
17955 K(IANT(2),5)=MSTU(5)*IOCT(1)
17956 MCT(IOCT(1),2)=MCT(ID,2)
17957 NCT=NCT+1
17958 MCT(IOCT(1),1)=NCT
17959 MCT(IANT(2),2)=NCT
17960 ELSE
17961C...1 -> 3 + 3bar + 8 + n(1)
17962 K(ITRI(1),1)=3
17963 K(ITRI(1),4)=MSTU(5)*IOCT(1)
17964 K(IOCT(1),1)=3
17965 K(IOCT(1),5)=MSTU(5)*ITRI(1)
17966 K(IOCT(1),4)=MSTU(5)*IANT(1)
17967 K(IANT(1),1)=3
17968 K(IANT(1),5)=MSTU(5)*IOCT(1)
17969 NCT=NCT+1
17970 MCT(ITRI(1),1)=NCT
17971 MCT(IOCT(1),2)=NCT
17972 NCT=NCT+1
17973 MCT(IOCT(1),1)=NCT
17974 MCT(IANT(1),2)=NCT
17975 ENDIF
17976 ELSEIF(NTRI+NANT.EQ.4) THEN
17977C...
17978 IF (KCQ(0).EQ.1) THEN
17979C...3 -> 3 + n(1) -> 3 + 3bar
17980 K(ID,4)=K(ID,4)+ITRI(2)
17981 K(ITRI(2),1)=3
17982 K(ITRI(2),4)=MSTU(5)*ID
17983 MCT(ITRI(2),1)=MCT(ID,1)
17984 K(ITRI(3),1)=3
17985 K(ITRI(3),4)=MSTU(5)*IANT(1)
17986 K(IANT(1),1)=3
17987 K(IANT(1),5)=MSTU(5)*ITRI(3)
17988 NCT=NCT+1
17989 MCT(ITRI(3),1)=NCT
17990 MCT(IANT(1),2)=NCT
17991 ELSEIF (KCQ(0).EQ.-1) THEN
17992C...3bar -> 3bar + n(1) -> 3 + 3bar
17993 K(ID,5)=K(ID,5)+IANT(2)
17994 K(IANT(2),1)=3
17995 K(IANT(2),5)=MSTU(5)*ID
17996 MCT(IANT(2),2)=MCT(ID,2)
17997 K(ITRI(1),1)=3
17998 K(ITRI(1),4)=MSTU(5)*IANT(3)
17999 K(IANT(3),1)=3
18000 K(IANT(3),5)=MSTU(5)*ITRI(1)
18001 NCT=NCT+1
18002 MCT(ITRI(1),1)=NCT
18003 MCT(IANT(3),2)=NCT
18004 ENDIF
18005 ELSEIF(KFL4(JT).NE.0) THEN
18006 CALL PYERRM(21,'(PYRESD:) unknown 4-bdy decay')
18007CPS-- End of generic cases
18008C...(could three octets also be handled?)
18009C...(could (some of) the RPV cases be made generic as well?)
18010
18011C...Special cases (= old treatment)
18012C...Set colour flow for t -> W + b + Z.
18013 ELSEIF(KFA.EQ.6) THEN
18014 K(N+2,1)=3
18015 ISID=4
18016 IF(KCQM(JT).EQ.-1) ISID=5
18017 IDAU=N+2
18018 K(ID,ISID)=K(ID,ISID)+IDAU
18019 K(IDAU,ISID)=MSTU(5)*ID
18020
18021C...Set colour flow in three-body decays - programmed as special cases.
18022
18023 ELSEIF(KFC2A.LE.6) THEN
18024 K(N+2,1)=3
18025 K(N+3,1)=3
18026 ISID=4
18027 IF(KFL2(JT).LT.0) ISID=5
18028 K(N+2,ISID)=MSTU(5)*(N+3)
18029 K(N+3,9-ISID)=MSTU(5)*(N+2)
18030C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
18031 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
18032 & .AND.KFL3(JT).NE.0) THEN
18033 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
18034C...3-body decays of squarks to colour singlets plus one quark
18035 IF (KQSUMA.EQ.1) THEN
18036C...Find quark
18037 IQ=0
18038 IF (KCQ1(JT).NE.0) IQ=1
18039 IF (KCQ2(JT).NE.0) IQ=2
18040 IF (KCQ3(JT).NE.0) IQ=3
18041 ISID=4
18042 IF (K(N+IQ,2).LT.0) ISID=5
18043 K(N+IQ,1)=3
18044 K(ID,ISID)=K(ID,ISID)+(N+IQ)
18045 K(N+IQ,ISID)=MSTU(5)*ID
18046 ENDIF
18047C...PS--
18048 ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
18049 K(N+1,1)=3
18050 K(N+2,1)=3
18051 K(N+3,1)=3
18052 ISID=4
18053 IF(KFL2(JT).LT.0) ISID=5
18054 K(N+1,ISID)=MSTU(5)*(N+2)
18055 K(N+1,9-ISID)=MSTU(5)*(N+3)
18056 K(N+2,ISID)=MSTU(5)*(N+1)
18057 K(N+3,9-ISID)=MSTU(5)*(N+1)
18058 ELSEIF(KFA.EQ.KSUSY1+21) THEN
18059 K(N+2,1)=3
18060 K(N+3,1)=3
18061 ISID=4
18062 IF(KFL2(JT).LT.0) ISID=5
18063 K(ID,ISID)=K(ID,ISID)+(N+2)
18064 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
18065 K(N+2,ISID)=MSTU(5)*ID
18066 K(N+3,9-ISID)=MSTU(5)*ID
18067CMRENNA--
18068
18069 ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
18070 & IABS(KCQ2(JT)).EQ.1) THEN
18071 K(N+2,1)=3
18072 K(N+3,1)=3
18073 ISID=4
18074 IF(KFL2(JT).LT.0) ISID=5
18075 K(N+2,ISID)=MSTU(5)*(N+3)
18076 K(N+3,9-ISID)=MSTU(5)*(N+2)
18077 ENDIF
18078
18079 NSAV=N
18080
18081C...Set colour flow in three-body decays with baryon number violation.
18082C...Neutralino and chargino decays first.
18083 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
18084 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
18085 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
18086 K(N+4,4)=ITJUNC(JT)*MSTU(5)
18087C...Insert junction to keep track of colours.
18088 IF(KCQ1(JT).NE.0) K(N+1,1)=3
18089 IF(KCQ2(JT).NE.0) K(N+2,1)=3
18090 IF(KCQ3(JT).NE.0) K(N+3,1)=3
18091C...Set special junction codes:
18092 K(N+4,1)=42
18093 K(N+4,2)=88
18094
18095C...Order decay products by invariant mass. (will be used in PYSTRF).
18096 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)-
18097 & P(N+1,3)*P(N+2,3)
18098 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)-
18099 & P(N+1,3)*P(N+3,3)
18100 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)-
18101 & P(N+2,3)*P(N+3,3)
18102 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
18103 K(N+4,4)=N+3+K(N+4,4)
18104 K(N+4,5)=N+1+MSTU(5)*(N+2)
18105 ELSEIF(PM13.LT.PM23) THEN
18106 K(N+4,4)=N+2+K(N+4,4)
18107 K(N+4,5)=N+1+MSTU(5)*(N+3)
18108 ELSE
18109 K(N+4,4)=N+1+K(N+4,4)
18110 K(N+4,5)=N+2+MSTU(5)*(N+3)
18111 ENDIF
18112 DO 260 J=1,5
18113 P(N+4,J)=0D0
18114 V(N+4,J)=0D0
18115 260 CONTINUE
18116C...Connect daughters to junction.
18117 DO 270 II=N+1,N+3
18118 K(II,4)=0
18119 K(II,5)=0
18120 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
18121 270 CONTINUE
18122C...Particle counter should be stepped up one extra for junction.
18123 N=N+1
18124
18125C...Gluino decays.
18126 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
18127 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
18128 K(N+4,4)=ITJUNC(JT)*MSTU(5)
18129C...Insert junction to keep track of colours.
18130 IF(KCQ1(JT).NE.0) K(N+1,1)=3
18131 IF(KCQ2(JT).NE.0) K(N+2,1)=3
18132 IF(KCQ3(JT).NE.0) K(N+3,1)=3
18133 K(N+4,1)=42
18134 K(N+4,2)=88
18135 DO 280 J=1,5
18136 P(N+4,J)=0D0
18137 V(N+4,J)=0D0
18138 280 CONTINUE
18139 CTMSUM=0D0
18140 DO 290 II=N+1,N+3
18141 K(II,4)=0
18142 K(II,5)=0
18143C...Start by connecting all daughters to junction.
18144 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
18145C...Only consider colour topologies with off shell resonances.
18146 RMQ1=PMAS(PYCOMP(K(II,2)),1)
18147 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
18148 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
18149 IF (RMGLU-RMQ1.LT.RMRES) THEN
18150C...Calculate propagators for each colour topology.
18151 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
18152 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
18153 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
18154 ELSE
18155 CTM2(II-N)=0D0
18156 ENDIF
18157 CTMSUM=CTMSUM+CTM2(II-N)
18158 290 CONTINUE
18159 CTMSUM=PYR(0)*CTMSUM
18160C...Select colour topology J, with most off shell least likely.
18161 J=0
18162 300 J=J+1
18163 CTMSUM=CTMSUM-CTM2(J)
18164 IF (CTMSUM.GT.0D0) GOTO 300
18165C...The lucky winner gets its colour (anti-colour) directly from gluino.
18166 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
18167 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
18168C...The other gluino colour is connected to junction
18169 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
18170 & MSTU(5)
18171 K(N+4,4)=K(N+4,4)+ID
18172C...Lastly, connect junction to remaining daughters.
18173 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
18174C...Particle counter should be stepped up one extra for junction.
18175 N=N+1
18176 ENDIF
18177
18178C...Update particle counter.
18179 N=N+NPROD
18180
18181C...2) Everything else two-body decay.
18182 ELSE
18183 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
18184 MCT(N-1,1)=0
18185 MCT(N-1,2)=0
18186 MCT(N,1)=0
18187 MCT(N,2)=0
18188C...First set colour flow as if mother colour singlet.
18189 IF(KCQ1(JT).NE.0) THEN
18190 K(N-1,1)=3
18191 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
18192 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
18193 ENDIF
18194 IF(KCQ2(JT).NE.0) THEN
18195 K(N,1)=3
18196 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
18197 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
18198 ENDIF
18199C...Then redirect colour flow if mother (anti)triplet.
18200 IF(KCQM(JT).EQ.0) THEN
18201 ELSEIF(KCQM(JT).NE.2) THEN
18202 ISID=4
18203 IF(KCQM(JT).EQ.-1) ISID=5
18204 IDAU=N-1
18205 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
18206 K(ID,ISID)=K(ID,ISID)+IDAU
18207 K(IDAU,ISID)=MSTU(5)*ID
18208C...Then redirect colour flow if mother octet.
18209 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
18210 IDAU=N-1
18211 IF(KCQ1(JT).EQ.0) IDAU=N
18212 K(ID,4)=K(ID,4)+IDAU
18213 K(ID,5)=K(ID,5)+IDAU
18214 K(IDAU,4)=MSTU(5)*ID
18215 K(IDAU,5)=MSTU(5)*ID
18216 ELSE
18217 ISID=4
18218 IF(KCQ1(JT).EQ.-1) ISID=5
18219 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
18220 K(ID,ISID)=K(ID,ISID)+(N-1)
18221 K(ID,9-ISID)=K(ID,9-ISID)+N
18222 K(N-1,ISID)=MSTU(5)*ID
18223 K(N,9-ISID)=MSTU(5)*ID
18224 ENDIF
18225
18226C...Insert junction
18227 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
18228 N=N+1
18229C...~q* mother: type 3 junction. ~q mother: type 4.
18230 ITJUNC(JT)=(7+KCQM(JT))/2
18231C...Specify junction KF and set colour flow from junction
18232 K(N,1)=42
18233 K(N,2)=88
18234 K(N,3)=ID
18235C...Junction type encoded together with mother:
18236 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
18237 K(N,5)=N-1+MSTU(5)*(N-2)
18238C...Zero P and V for junction (V filled later)
18239 DO 310 J=1,5
18240 P(N,J)=0D0
18241 V(N,J)=0D0
18242 310 CONTINUE
18243C...Set colour flow from mother to junction
18244 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
18245C...Set colour flow from daughters to junction
18246 DO 320 II=N-2,N-1
18247 K(II,4) = 0
18248 K(II,5) = 0
18249C...(Anti-)colour mother is junction.
18250 K(II,1+ITJUNC(JT)) = MSTU(5)*N
18251 320 CONTINUE
18252 ENDIF
18253 ENDIF
18254
18255C...End loop over resonances for daughter flavour and mass selection.
18256 MSTU(10)=MSTU10
18257 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
18258 & NINH=NINH+1
18259 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
18260 & KFL1(JT).EQ.0) THEN
18261 WRITE(CODE,'(I9)') K(ID,2)
18262 WRITE(MASS,'(F9.3)') P(ID,5)
18263 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
18264 & CODE//' with mass'//MASS)
18265 MINT(51)=1
18266 GOTO 720
18267 ENDIF
18268 340 CONTINUE
18269
18270C...Check for allowed combinations. Skip if no decays.
18271 IF(JTMAX.EQ.1) THEN
18272 IF(KDCY(1).EQ.0) GOTO 710
18273 ELSEIF(JTMAX.EQ.2) THEN
18274 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
18275 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
18276 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
18277 ELSEIF(JTMAX.EQ.3) THEN
18278 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
18279 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
18280 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
18281 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
18282 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
18283 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
18284 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
18285 ENDIF
18286
18287C...Special case: matrix element option for Z0 decay to quarks.
18288 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
18289 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
18290
18291C...Check consistency of MSTJ options set.
18292 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
18293 CALL PYERRM(6,
18294 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
18295 MSTJ(110)=1
18296 ENDIF
18297 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
18298 CALL PYERRM(6,
18299 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
18300
18301 MSTJ(111)=0
18302 ENDIF
18303
18304C...Select alpha_strong behaviour.
18305 MST111=MSTU(111)
18306 PAR112=PARU(112)
18307 MSTU(111)=MSTJ(108)
18308 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
18309 & MSTU(111)=1
18310 PARU(112)=PARJ(121)
18311 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
18312
18313C...Find axial fraction in total cross section for scalar gluon model.
18314 PARJ(171)=0D0
18315 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
18316 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
18317 POLL=1D0-PARJ(131)*PARJ(132)
18318 SFF=1D0/(16D0*XW*XW1)
18319 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
18320 & (PARJ(123)*PARJ(124))**2)
18321 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
18322 VE=4D0*XW-1D0
18323 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
18324 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
18325 & (PARJ(132)-PARJ(131)))
18326 KFLC=IABS(KFL1(1))
18327 PMQ=PYMASS(KFLC)
18328 QF=KCHG(KFLC,1)/3D0
18329 VQ=1D0
18330 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
18331 & 1D0-(2D0*PMQ/P(ID,5))**2))
18332 VF=SIGN(1D0,QF)-4D0*QF*XW
18333 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
18334 & VF**2*HF1W)+VQ**3*HF1W
18335 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
18336 ENDIF
18337
18338C...Choice of jet configuration.
18339 CALL PYXJET(P(ID,5),NJET,CUT)
18340 KFLC=IABS(KFL1(1))
18341 KFLN=21
18342 IF(NJET.EQ.4) THEN
18343 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
18344 ELSEIF(NJET.EQ.3) THEN
18345 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
18346 ELSE
18347 MSTJ(120)=1
18348 ENDIF
18349
18350C...Fill jet configuration; return if incorrect kinematics.
18351 NC=N-2
18352 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
18353 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
18354 ELSEIF(NJET.EQ.2) THEN
18355 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
18356 ELSEIF(NJET.EQ.3) THEN
18357 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
18358 ELSEIF(KFLN.EQ.21) THEN
18359 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
18360 & X12,X14)
18361 ELSE
18362 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
18363 & X12,X14)
18364 ENDIF
18365 IF(MSTU(24).NE.0) THEN
18366 MINT(51)=1
18367 MSTU(111)=MST111
18368 PARU(112)=PAR112
18369 GOTO 720
18370 ENDIF
18371
18372C...Angular orientation according to matrix element.
18373 IF(MSTJ(106).EQ.1) THEN
18374 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
18375 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
18376 CTHE(1)=COS(THEZ)
18377 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
18378 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
18379 ENDIF
18380
18381C...Boost partons to Z0 rest frame.
18382 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
18383 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
18384
18385C...Mark decayed resonance and add documentation lines,
18386 K(ID,1)=K(ID,1)+10
18387 IDOC=MINT(83)+MINT(4)
18388 DO 360 I=NC+1,N
18389 I1=MINT(83)+MINT(4)+1
18390 K(I,3)=I1
18391 IF(MSTP(128).GE.1) K(I,3)=ID
18392 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18393 MINT(4)=MINT(4)+1
18394 K(I1,1)=21
18395 K(I1,2)=K(I,2)
18396 K(I1,3)=IREF(IP,4)
18397 DO 350 J=1,5
18398 P(I1,J)=P(I,J)
18399 350 CONTINUE
18400 ENDIF
18401 360 CONTINUE
18402
18403C...Generate parton shower.
18404 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
18405 CALL PYSHOW(N-1,N,P(ID,5))
18406 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
18407 NPART=2
18408 IPART(1)=N-1
18409 IPART(2)=N
18410 PTPART(1)=0.5D0*P(ID,5)
18411 PTPART(2)=PTPART(1)
18412 NCT=NCT+1
18413 IF(K(N-1,2).GT.0) THEN
18414 MCT(N-1,1)=NCT
18415 MCT(N,2)=NCT
18416 ELSE
18417 MCT(N-1,2)=NCT
18418 MCT(N,1)=NCT
18419 ENDIF
18420 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
18421 ENDIF
18422
18423C... End special case for Z0: skip ahead.
18424 MSTU(111)=MST111
18425 PARU(112)=PAR112
18426 GOTO 700
18427 ENDIF
18428
18429C...Order incoming partons and outgoing resonances.
18430 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
18431 &NINH.EQ.0) THEN
18432 ILIN(1)=MINT(84)+1
18433 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
18434 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
18435 & ILIN(1)=2*MINT(84)+3-ILIN(1)
18436 ILIN(2)=2*MINT(84)+3-ILIN(1)
18437 IMIN=1
18438 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
18439 & .EQ.36) IMIN=3
18440 IMAX=2
18441 IORD=1
18442 IF(K(IREF(IP,1),2).EQ.23) IORD=2
18443 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
18444 IAKIPD=IABS(K(IREF(IP,IORD),2))
18445 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
18446 IF(KDCY(IORD).EQ.0) IORD=3-IORD
18447
18448C...Order decay products of resonances.
18449 DO 370 JT=IORD,3-IORD,3-2*IORD
18450 IF(KDCY(JT).EQ.0) THEN
18451 ILIN(IMAX+1)=NSD(JT)
18452 IMAX=IMAX+1
18453 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
18454 ILIN(IMAX+1)=N+2*JT-1
18455 ILIN(IMAX+2)=N+2*JT
18456 IMAX=IMAX+2
18457 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18458 K(N+2*JT,2)=K(NSD(JT)+2,2)
18459 ELSE
18460 ILIN(IMAX+1)=N+2*JT
18461
18462 ILIN(IMAX+2)=N+2*JT-1
18463 IMAX=IMAX+2
18464 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18465 K(N+2*JT,2)=K(NSD(JT)+2,2)
18466 ENDIF
18467 370 CONTINUE
18468
18469C...Find charge, isospin, left- and righthanded couplings.
18470 DO 390 I=IMIN,IMAX
18471 DO 380 J=1,4
18472 COUP(I,J)=0D0
18473 380 CONTINUE
18474 KFA=IABS(K(ILIN(I),2))
18475 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
18476 COUP(I,1)=KCHG(KFA,1)/3D0
18477 COUP(I,2)=(-1)**MOD(KFA,2)
18478 COUP(I,4)=-2D0*COUP(I,1)*XWV
18479 COUP(I,3)=COUP(I,2)+COUP(I,4)
18480 390 CONTINUE
18481
18482C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
18483 IF(ISUB.EQ.22) THEN
18484 DO 420 I=3,5,2
18485 I1=IORD
18486 IF(I.EQ.5) I1=3-IORD
18487 DO 410 J1=1,2
18488 DO 400 J2=1,2
18489 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
18490 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
18491 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
18492 & COUP(I,J2+2)**2
18493 400 CONTINUE
18494 410 CONTINUE
18495 420 CONTINUE
18496 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18497 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
18498 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
18499 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
18500
18501 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
18502 ENDIF
18503 ENDIF
18504
18505C...Select angular orientation type - Z'/W' only.
18506 MZPWP=0
18507 IF(ISUB.EQ.141) THEN
18508 IF(PYR(0).LT.PARU(130)) MZPWP=1
18509 IF(IP.EQ.2) THEN
18510 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
18511 IAKIR=IABS(K(IREF(2,2),2))
18512 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18513 IF(IAKIR.LE.20) MZPWP=2
18514 ENDIF
18515 IF(IP.GE.3) MZPWP=2
18516 ELSEIF(ISUB.EQ.142) THEN
18517 IF(PYR(0).LT.PARU(136)) MZPWP=1
18518 IF(IP.EQ.2) THEN
18519 IAKIR=IABS(K(IREF(2,2),2))
18520 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18521 IF(IAKIR.LE.20) MZPWP=2
18522 ENDIF
18523 IF(IP.GE.3) MZPWP=2
18524 ENDIF
18525
18526C...Select random angles (begin of weighting procedure).
18527 430 DO 440 JT=1,JTMAX
18528 IF(KDCY(JT).EQ.0) GOTO 440
18529 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
18530 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
18531 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
18532 PHI(JT)=VINT(24)
18533 ELSE
18534 CTHE(JT)=2D0*PYR(0)-1D0
18535 PHI(JT)=PARU(2)*PYR(0)
18536 ENDIF
18537 440 CONTINUE
18538
18539 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
18540C...Construct massless four-vectors.
18541 DO 460 I=N+1,N+4
18542 K(I,1)=1
18543 DO 450 J=1,5
18544 P(I,J)=0D0
18545 V(I,J)=0D0
18546 450 CONTINUE
18547 460 CONTINUE
18548 DO 470 JT=1,JTMAX
18549 IF(KDCY(JT).EQ.0) GOTO 470
18550 ID=IREF(IP,JT)
18551 P(N+2*JT-1,3)=0.5D0*P(ID,5)
18552 P(N+2*JT-1,4)=0.5D0*P(ID,5)
18553 P(N+2*JT,3)=-0.5D0*P(ID,5)
18554 P(N+2*JT,4)=0.5D0*P(ID,5)
18555 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
18556 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
18557 470 CONTINUE
18558
18559C...Store incoming and outgoing momenta, with random rotation to
18560C...avoid accidental zeroes in HA expressions.
18561 IF(ISUB.NE.0) THEN
18562 DO 490 I=IMIN,IMAX
18563 K(N+4+I,1)=1
18564 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
18565 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
18566 P(N+4+I,5)=P(ILIN(I),5)
18567 DO 480 J=1,3
18568 P(N+4+I,J)=P(ILIN(I),J)
18569 480 CONTINUE
18570 490 CONTINUE
18571 500 THERR=ACOS(2D0*PYR(0)-1D0)
18572 PHIRR=PARU(2)*PYR(0)
18573 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
18574 DO 520 I=IMIN,IMAX
18575 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
18576 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
18577 DO 510 J=1,4
18578 PK(I,J)=P(N+4+I,J)
18579 510 CONTINUE
18580 520 CONTINUE
18581 ENDIF
18582
18583C...Calculate internal products.
18584 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
18585 & ISUB.EQ.142) THEN
18586 DO 540 I1=IMIN,IMAX-1
18587 DO 530 I2=I1+1,IMAX
18588 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
18589 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
18590 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
18591 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
18592 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
18593 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
18594 HC(I1,I2)=CONJG(HA(I1,I2))
18595 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
18596 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
18597 HA(I2,I1)=-HA(I1,I2)
18598 HC(I2,I1)=-HC(I1,I2)
18599 530 CONTINUE
18600 540 CONTINUE
18601 ENDIF
18602
18603C...Calculate four-products.
18604 IF(ISUB.NE.0) THEN
18605 DO 560 I=1,2
18606 DO 550 J=1,4
18607 PK(I,J)=-PK(I,J)
18608 550 CONTINUE
18609 560 CONTINUE
18610 DO 580 I1=IMIN,IMAX-1
18611 DO 570 I2=I1+1,IMAX
18612 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
18613 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
18614 PKK(I2,I1)=PKK(I1,I2)
18615 570 CONTINUE
18616 580 CONTINUE
18617 ENDIF
18618 ENDIF
18619
18620 KFAGM=IABS(IREF(IP,7))
18621 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
18622C...Isotropic decay selected by user.
18623 WT=1D0
18624 WTMAX=1D0
18625
18626 ELSEIF(JTMAX.EQ.3) THEN
18627C...Isotropic decay when three mother particles.
18628 WT=1D0
18629 WTMAX=1D0
18630
18631 ELSEIF(IT4.GE.1) THEN
18632C... Isotropic decay t -> b + W etc for 4th generation q and l.
18633 WT=1D0
18634 WTMAX=1D0
18635
18636 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
18637 & IREF(IP,7).EQ.36) THEN
18638C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
18639C...CP-odd case added by Kari Ertresvag Myklevoll.
18640C...Now also with mixed Higgs CP-states
18641 ETA=PARP(25)
18642 IF(IP.EQ.1) WTMAX=SH**2
18643 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
18644 KFA=IABS(K(IREF(IP,1),2))
18645 KFT=IABS(K(IREF(IP,2),2))
18646
18647 IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
18648 & MSTP(25).GE.3) THEN
18649C...For mixed CP states need epsilon product.
18650 P10=PK(3,4)
18651 P20=PK(4,4)
18652 P30=PK(5,4)
18653 P40=PK(6,4)
18654 P11=PK(3,1)
18655 P21=PK(4,1)
18656 P31=PK(5,1)
18657 P41=PK(6,1)
18658 P12=PK(3,2)
18659 P22=PK(4,2)
18660 P32=PK(5,2)
18661 P42=PK(6,2)
18662 P13=PK(3,3)
18663 P23=PK(4,3)
18664 P33=PK(5,3)
18665 P43=PK(6,3)
18666 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
18667 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
18668 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
18669 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
18670 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
18671 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
18672 & P22*P30*P41+P13*P22*P31*P40
18673C...For mixed CP states need gauge boson masses.
18674 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
18675 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
18676 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
18677 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
18678 XMV=PMAS(KFA,1)
18679 ENDIF
18680
18681C...Z decay
18682 IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
18683 KFLF1A=IABS(KFL1(1))
18684 EF1=KCHG(KFLF1A,1)/3D0
18685 AF1=SIGN(1D0,EF1+0.1D0)
18686 VF1=AF1-4D0*EF1*XWV
18687 KFLF2A=IABS(KFL1(2))
18688 EF2=KCHG(KFLF2A,1)/3D0
18689 AF2=SIGN(1D0,EF2+0.1D0)
18690 VF2=AF2-4D0*EF2*XWV
18691 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
18692 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18693 & THEN
18694C...CP-even decay
18695 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
18696 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
18697 ELSEIF(MSTP(25).LE.2) THEN
18698C...CP-odd decay
18699 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18700 & -2*PKK(3,4)*PKK(5,6)
18701 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18702 & (PKK(3,4)*PKK(5,6))
18703 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18704 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
18705 ELSE
18706C...Mixed CP states.
18707 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
18708 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
18709 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
18710 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
18711 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18712 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18713 & +PKK(3,4)*PKK(5,6)
18714 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18715 & +VA12AS*PKK(3,4)*PKK(5,6)
18716 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18717 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18718 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18719 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
18720 ENDIF
18721
18722C...W decay
18723 ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
18724 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18725 & THEN
18726C...CP-even decay
18727 WT=16D0*PKK(3,5)*PKK(4,6)
18728 ELSEIF(MSTP(25).LE.2) THEN
18729C...CP-odd decay
18730 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18731 & -2*PKK(3,4)*PKK(5,6)
18732 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18733 & (PKK(3,4)*PKK(5,6))
18734 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18735 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
18736 ELSE
18737C...Mixed CP states.
18738 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
18739 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
18740 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18741 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18742 & +PKK(3,4)*PKK(5,6)
18743 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18744 & +PKK(3,4)*PKK(5,6)
18745 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18746 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18747 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18748 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
18749 ENDIF
18750
18751C...No angular correlations in other Higgs decays.
18752 ELSE
18753 WT=WTMAX
18754 ENDIF
18755
18756 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
18757 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
18758 & THEN
18759C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
18760 I1=IREF(IP,8)
18761 IF(MOD(KFAGM,2).EQ.0) THEN
18762 I2=N+1
18763 I3=N+2
18764 ELSE
18765 I2=N+2
18766 I3=N+1
18767 ENDIF
18768 I4=IREF(IP,2)
18769 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
18770 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
18771 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
18772 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
18773
18774 ELSEIF(ISUB.EQ.1) THEN
18775C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
18776 EI=KCHG(IABS(MINT(15)),1)/3D0
18777 AI=SIGN(1D0,EI+0.1D0)
18778 VI=AI-4D0*EI*XWV
18779 EF=KCHG(IABS(KFL1(1)),1)/3D0
18780 AF=SIGN(1D0,EF+0.1D0)
18781
18782 VF=AF-4D0*EF*XWV
18783 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
18784 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18785 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
18786 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18787 & (VI**2+AI**2)*VINT(114)*VF**2)
18788 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
18789 & 4D0*VI*AI*VINT(114)*VF*AF)
18790 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18791 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18792 WTMAX=2D0*(WT1+ABS(WT3))
18793
18794 ELSEIF(ISUB.EQ.2) THEN
18795C...Angular weight for W+/- -> 2 quarks/leptons.
18796 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
18797 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
18798 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18799 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18800 WTMAX=4D0
18801
18802 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
18803C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
18804C...-> gluon/gamma + 2 quarks/leptons.
18805 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18806 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18807 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18808 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18809 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18810 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18811 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18812 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18813 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18814 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18815 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18816 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18817 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
18818 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
18819 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18820 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
18821
18822 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
18823C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
18824C...-> gluon/gamma + 2 quarks/leptons.
18825 WT=PKK(1,3)**2+PKK(2,4)**2
18826 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
18827
18828 ELSEIF(ISUB.EQ.22) THEN
18829C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
18830 S34=P(IREF(IP,IORD),5)**2
18831 S56=P(IREF(IP,3-IORD),5)**2
18832 TI=PKK(1,3)+PKK(1,4)+S34
18833 UI=PKK(1,5)+PKK(1,6)+S56
18834 TIR=REAL(TI)
18835 UIR=REAL(UI)
18836 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
18837 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
18838 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
18839 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
18840 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
18841 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
18842 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
18843 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
18844
18845 WT=
18846 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
18847 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
18848 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
18849 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
18850 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18851 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
18852 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
18853 & 1D0/UI**2))
18854
18855 ELSEIF(ISUB.EQ.23) THEN
18856C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
18857 D34=P(IREF(IP,IORD),5)**2
18858 D56=P(IREF(IP,3-IORD),5)**2
18859 DT=PKK(1,3)+PKK(1,4)+D34
18860 DU=PKK(1,5)+PKK(1,6)+D56
18861 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
18862 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18863 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18864 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
18865
18866 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
18867 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
18868 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
18869 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18870 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
18871 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
18872
18873 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
18874C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
18875C...(or H0, or A0).
18876 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
18877 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
18878 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
18879 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
18880 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18881
18882 ELSEIF(ISUB.EQ.25) THEN
18883C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
18884 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
18885 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
18886 D34=P(IREF(IP,IORD),5)**2
18887 D56=P(IREF(IP,3-IORD),5)**2
18888 DT=PKK(1,3)+PKK(1,4)+D34
18889 DU=PKK(1,5)+PKK(1,6)+D56
18890 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
18891 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
18892 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
18893 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
18894 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
18895 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
18896 & REAL(CBWW)*FGK(1,2,5,6,3,4))
18897 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18898 IF(MSTP(50).LE.0) THEN
18899 WT=FGK135**2+(CCWW*FGK253)**2
18900 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
18901 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
18902 & DJGK(DT,DU)))
18903 ELSE
18904 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
18905 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
18906 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
18907 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
18908 ENDIF
18909
18910 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
18911C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
18912C...(or H0, or A0).
18913 WT=PKK(1,3)*PKK(2,4)
18914 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18915
18916 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
18917C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
18918C...-> f + 2 quarks/leptons.
18919 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18920 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18921 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18922 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18923 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18924 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18925 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18926 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18927 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18928 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18929 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18930 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18931 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
18932 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
18933 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
18934 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
18935 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18936 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
18937
18938 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
18939C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
18940 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
18941 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
18942 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
18943
18944 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
18945 & ISUB.EQ.77) THEN
18946C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
18947 WT=16D0*PKK(3,5)*PKK(4,6)
18948 WTMAX=SH**2
18949
18950 ELSEIF(ISUB.EQ.110) THEN
18951C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
18952 WT=1D0
18953 WTMAX=1D0
18954
18955 ELSEIF(ISUB.EQ.141) THEN
18956C...Special case: if only branching ratios known then isotropic decay.
18957 IF(MWID(32).EQ.2) THEN
18958 WT=1D0
18959 WTMAX=1D0
18960 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18961C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
18962C...Couplings of incoming flavour.
18963 KFAI=IABS(MINT(15))
18964 EI=KCHG(KFAI,1)/3D0
18965 AI=SIGN(1D0,EI+0.1D0)
18966 VI=AI-4D0*EI*XWV
18967 KFAIC=1
18968 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
18969 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
18970 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
18971 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
18972 VPI=PARU(119+2*KFAIC)
18973 API=PARU(120+2*KFAIC)
18974 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
18975 VPI=PARJ(178+2*KFAIC)
18976 API=PARJ(179+2*KFAIC)
18977 ELSE
18978 VPI=PARJ(186+2*KFAIC)
18979 API=PARJ(187+2*KFAIC)
18980 ENDIF
18981C...Couplings of final flavour.
18982 KFAF=IABS(KFL1(1))
18983 EF=KCHG(KFAF,1)/3D0
18984 AF=SIGN(1D0,EF+0.1D0)
18985 VF=AF-4D0*EF*XWV
18986 KFAFC=1
18987 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
18988 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
18989 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
18990 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
18991 VPF=PARU(119+2*KFAFC)
18992 APF=PARU(120+2*KFAFC)
18993 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
18994 VPF=PARJ(178+2*KFAFC)
18995 APF=PARJ(179+2*KFAFC)
18996 ELSE
18997 VPF=PARJ(186+2*KFAFC)
18998 APF=PARJ(187+2*KFAFC)
18999 ENDIF
19000C...Asymmetry and weight.
19001 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
19002 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
19003 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
19004 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
19005 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
19006 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
19007 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
19008 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
19009 WTMAX=2D0+ABS(ASYM)
19010 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
19011C...Angular weight for f + fbar -> Z' -> W+ + W-.
19012 RM1=P(NSD(1)+1,5)**2/SH
19013 RM2=P(NSD(1)+2,5)**2/SH
19014 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
19015 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
19016 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
19017 & (RM2-RM1)**2)
19018 WT=CFLAT+CCOS2*CTHE(1)**2
19019 WTMAX=CFLAT+MAX(0D0,CCOS2)
19020 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
19021 & IABS(KFL1(1)).EQ.37)) THEN
19022C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
19023 WT=1D0-CTHE(1)**2
19024 WTMAX=1D0
19025 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
19026C...Angular weight for f + fbar -> Z' -> Z0 + h0.
19027 RM1=P(NSD(1)+1,5)**2/SH
19028 RM2=P(NSD(1)+2,5)**2/SH
19029 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
19030 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
19031 WTMAX=1D0+FLAM2/(8D0*RM1)
19032 ELSEIF(MZPWP.EQ.0) THEN
19033C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
19034C...(W:s like if intermediate Z).
19035 D34=P(IREF(IP,IORD),5)**2
19036 D56=P(IREF(IP,3-IORD),5)**2
19037 DT=PKK(1,3)+PKK(1,4)+D34
19038 DU=PKK(1,5)+PKK(1,6)+D56
19039 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
19040 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
19041 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
19042 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
19043 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
19044 ELSEIF(MZPWP.EQ.1) THEN
19045C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
19046C...(W:s approximately longitudinal, like if intermediate H).
19047 WT=16D0*PKK(3,5)*PKK(4,6)
19048 WTMAX=SH**2
19049 ELSE
19050C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
19051C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
19052 WT=1D0
19053 WTMAX=1D0
19054 ENDIF
19055
19056 ELSEIF(ISUB.EQ.142) THEN
19057C...Special case: if only branching ratios known then isotropic decay.
19058 IF(MWID(34).EQ.2) THEN
19059 WT=1D0
19060 WTMAX=1D0
19061 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
19062C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
19063 KFAI=IABS(MINT(15))
19064 KFAIC=1
19065 IF(KFAI.GT.10) KFAIC=2
19066 VI=PARU(129+2*KFAIC)
19067 AI=PARU(130+2*KFAIC)
19068 KFAF=IABS(KFL1(1))
19069 KFAFC=1
19070 IF(KFAF.GT.10) KFAFC=2
19071 VF=PARU(129+2*KFAFC)
19072 AF=PARU(130+2*KFAFC)
19073 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
19074 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
19075 WTMAX=2D0+ABS(ASYM)
19076 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
19077C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
19078 RM1=P(NSD(1)+1,5)**2/SH
19079 RM2=P(NSD(1)+2,5)**2/SH
19080 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
19081 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
19082 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
19083 & (RM2-RM1)**2)
19084 WT=CFLAT+CCOS2*CTHE(1)**2
19085 WTMAX=CFLAT+MAX(0D0,CCOS2)
19086 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
19087C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
19088 RM1=P(NSD(1)+1,5)**2/SH
19089 RM2=P(NSD(1)+2,5)**2/SH
19090 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
19091 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
19092 WTMAX=1D0+FLAM2/(8D0*RM1)
19093 ELSEIF(MZPWP.EQ.0) THEN
19094C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
19095C...(W/Z like if intermediate W).
19096 D34=P(IREF(IP,IORD),5)**2
19097 D56=P(IREF(IP,3-IORD),5)**2
19098 DT=PKK(1,3)+PKK(1,4)+D34
19099 DU=PKK(1,5)+PKK(1,6)+D56
19100 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
19101 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
19102 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
19103 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
19104 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
19105 ELSEIF(MZPWP.EQ.1) THEN
19106C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
19107C...(W/Z approximately longitudinal, like if intermediate H).
19108 WT=16D0*PKK(3,5)*PKK(4,6)
19109 WTMAX=SH**2
19110 ELSE
19111C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
19112C...t + bbar -> t + W + bbar.
19113 WT=1D0
19114 WTMAX=1D0
19115 ENDIF
19116
19117 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
19118 & THEN
19119C...Isotropic decay of leptoquarks (assumed spin 0).
19120 WT=1D0
19121 WTMAX=1D0
19122
19123 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
19124C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
19125 SIDE=1D0
19126 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
19127 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
19128 WT=1D0+SIDE*CTHE(1)
19129 WTMAX=2D0
19130 ELSEIF(IP.EQ.1) THEN
19131
19132 RM1=P(NSD(1)+1,5)**2/SH
19133 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
19134 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
19135 ELSE
19136C...W/Z decay assumed isotropic, since not known.
19137 WT=1D0
19138 WTMAX=1D0
19139 ENDIF
19140
19141 ELSEIF(ISUB.EQ.149) THEN
19142C...Isotropic decay of techni-eta.
19143 WT=1D0
19144 WTMAX=1D0
19145
19146 ELSEIF(ISUB.EQ.191) THEN
19147 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
19148C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
19149C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
19150 WT=1D0-CTHE(1)**2
19151 WTMAX=1D0
19152 ELSEIF(IP.EQ.1) THEN
19153C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
19154 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
19155 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
19156 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19157 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19158 KFAI=IABS(MINT(15))
19159 EI=KCHG(KFAI,1)/3D0
19160 AI=SIGN(1D0,EI+0.1D0)
19161 VI=AI-4D0*EI*XWV
19162 VALI=0.5D0*(VI+AI)
19163 VARI=0.5D0*(VI-AI)
19164 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
19165 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
19166 KFAF=IABS(KFL1(1))
19167 EF=KCHG(KFAF,1)/3D0
19168 AF=SIGN(1D0,EF+0.1D0)
19169 VF=AF-4D0*EF*XWV
19170 VALF=0.5D0*(VF+AF)
19171 VARF=0.5D0*(VF-AF)
19172 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
19173 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
19174 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
19175 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
19176 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
19177 WTMAX=4D0*MAX(ASAME,AFLIP)
19178 ELSE
19179C...Isotropic decay of W/pi_tc produced in rho_tc decay.
19180 WT=1D0
19181 WTMAX=1D0
19182 ENDIF
19183
19184 ELSEIF(ISUB.EQ.192) THEN
19185 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
19186C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
19187C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
19188 WT=1D0-CTHE(1)**2
19189 WTMAX=1D0
19190 ELSEIF(IP.EQ.1) THEN
19191C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
19192 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
19193 WT=(1D0+CTHESG)**2
19194 WTMAX=4D0
19195 ELSE
19196C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
19197 WT=1D0
19198 WTMAX=1D0
19199 ENDIF
19200
19201 ELSEIF(ISUB.EQ.193) THEN
19202 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
19203C...Angular weight for f + fbar -> omega_tc0 ->
19204C...gamma pi_tc0 or Z0 pi_tc0.
19205 WT=1D0+CTHE(1)**2
19206 WTMAX=2D0
19207 ELSEIF(IP.EQ.1) THEN
19208C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
19209 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
19210 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19211 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19212 KFAI=IABS(MINT(15))
19213 EI=KCHG(KFAI,1)/3D0
19214 AI=SIGN(1D0,EI+0.1D0)
19215 VI=AI-4D0*EI*XWV
19216 VALI=0.5D0*(VI+AI)
19217 VARI=0.5D0*(VI-AI)
19218 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
19219 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
19220 KFAF=IABS(KFL1(1))
19221 EF=KCHG(KFAF,1)/3D0
19222 AF=SIGN(1D0,EF+0.1D0)
19223 VF=AF-4D0*EF*XWV
19224 VALF=0.5D0*(VF+AF)
19225 VARF=0.5D0*(VF-AF)
19226 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
19227 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
19228 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
19229 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
19230 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
19231 WTMAX=4D0*MAX(BSAME,BFLIP)
19232 ELSE
19233C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
19234 WT=1D0
19235 WTMAX=1D0
19236 ENDIF
19237
19238 ELSEIF(ISUB.EQ.353) THEN
19239C...Angular weight for Z_R0 -> 2 quarks/leptons.
19240 EI=KCHG(IABS(MINT(15)),1)/3D0
19241 AI=SIGN(1D0,EI+0.1D0)
19242 VI=AI-4D0*EI*XWV
19243 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
19244 AF=SIGN(1D0,EF+0.1D0)
19245 VF=AF-4D0*EF*XWV
19246 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
19247 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
19248 WT2=RMF*(VI**2+AI**2)*VF**2
19249 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
19250 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
19251 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
19252 WTMAX=2D0*(WT1+ABS(WT3))
19253
19254 ELSEIF(ISUB.EQ.354) THEN
19255C...Angular weight for W_R+/- -> 2 quarks/leptons.
19256 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
19257 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
19258 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19259 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
19260 WTMAX=4D0
19261
19262 ELSEIF(ISUB.EQ.391) THEN
19263C...Angular weight for f + fbar -> G* -> f + fbar
19264 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
19265 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
19266 WTMAX=2D0
19267C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
19268C...implemented by M.-C. Lemaire
19269 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
19270 & IABS(KFL1(1)).EQ.22)) THEN
19271 WT=1D0-CTHE(1)**4
19272 WTMAX=1D0
19273C...Other G* decays not yet implemented angular distributions.
19274 ELSE
19275 WT=1D0
19276 WTMAX=1D0
19277 ENDIF
19278
19279 ELSEIF(ISUB.EQ.392) THEN
19280C...Angular weight for g + g -> G* -> f + fbar
19281 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
19282 WT=1D0-CTHE(1)**4
19283 WTMAX=1D0
19284C...Angular weight for g + g -> G* -> gamma +gamma or g + g
19285C...implemented by M.-C. Lemaire
19286 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
19287 & IABS(KFL1(1)).EQ.22)) THEN
19288 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
19289 WTMAX=8D0
19290C...Other G* decays not yet implemented angular distributions.
19291 ELSE
19292 WT=1D0
19293 WTMAX=1D0
19294 ENDIF
19295
19296C...Obtain correct angular distribution by rejection techniques.
19297 ELSE
19298 WT=1D0
19299 WTMAX=1D0
19300 ENDIF
19301 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
19302
19303C...Construct massive four-vectors using angles chosen.
19304 590 DO 690 JT=1,JTMAX
19305 IF(KDCY(JT).EQ.0) GOTO 690
19306 ID=IREF(IP,JT)
19307 DO 600 J=1,5
19308 DPMO(J)=P(ID,J)
19309 600 CONTINUE
19310 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
19311CMRENNA++
19312 NPROD=2
19313 IF(KFL3(JT).NE.0) NPROD=3
19314 IF(KFL4(JT).NE.0) NPROD=4
19315 CALL PYROBO(NSD(JT)+1,NSD(JT)+NPROD,ACOS(CTHE(JT)),PHI(JT),
19316 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
19317 N0=NSD(JT)+NPROD
19318
19319 DO 610 J=1,4
19320 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
19321 610 CONTINUE
19322C...Fill in position of decay vertex.
19323 DO 630 I=NSD(JT)+1,N0
19324 DO 620 J=1,4
19325 V(I,J)=VDCY(J)
19326 620 CONTINUE
19327 V(I,5)=0D0
19328
19329 630 CONTINUE
19330CMRENNA--
19331
19332C...Mark decayed resonances; trace history.
19333 K(ID,1)=K(ID,1)+10
19334 KFA=IABS(K(ID,2))
19335 KCA=PYCOMP(KFA)
19336 IF(KCQM(JT).NE.0) THEN
19337C...Do not kill colour flow through coloured resonance!
19338 ELSE
19339 K(ID,4)=NSD(JT)+1
19340 K(ID,5)=NSD(JT)+NPROD
19341 IF(ITJUNC(JT).NE.0) K(ID,5)=K(ID,5)+1
19342C...If 3-body or 2-body with junction:
19343c IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
19344C...If 3-body with junction:
19345c IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
19346 ENDIF
19347
19348C...Add documentation lines.
19349 ISUBRG=MAX(1,MIN(500,MINT(1)))
19350 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
19351 IDOC=MINT(83)+MINT(4)
19352CMRENNA+++
19353 IHI=NSD(JT)+NPROD
19354c IF(KFL3(JT).NE.0) IHI=IHI+1
19355 DO 650 I=NSD(JT)+1,IHI
19356CMRENNA---
19357 I1=MINT(83)+MINT(4)+1
19358 K(I,3)=I1
19359 IF(MSTP(128).GE.1) K(I,3)=ID
19360 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
19361 MINT(4)=MINT(4)+1
19362 K(I1,1)=21
19363 K(I1,2)=K(I,2)
19364 K(I1,3)=IREF(IP,JT+3)
19365 DO 640 J=1,5
19366 P(I1,J)=P(I,J)
19367 640 CONTINUE
19368 ENDIF
19369 650 CONTINUE
19370 ELSE
19371 K(NSD(JT)+1,3)=ID
19372 K(NSD(JT)+2,3)=ID
19373C...If 3-body or 2-body with junction:
19374 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
19375C...If 3-body with junction:
19376 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
19377C...If 4-body or 3-body with junction:
19378 IF(KFL4(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
19379C...If 4-body with junction:
19380 IF(KFL4(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+5,3)=ID
19381 ENDIF
19382
19383C...Do showering of two or three objects.
19384 NSHBEF=N
19385 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
19386 IF(KFL3(JT).EQ.0) THEN
19387 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
19388 ELSE
19389 CALL PYSHOW(NSD(JT)+1,-NPROD,P(ID,5))
19390 ENDIF
19391
19392c...For pT-ordered shower need set up first, especially colour tags.
19393C...(Need to set up colour tags even if MSTP(71) = 0)
19394 ELSEIF(MINT(35).GE.2) THEN
19395 NPART=NPROD
19396c IF(KFL3(JT).NE.0) NPART=3
19397 IPART(1)=NSD(JT)+1
19398 IPART(2)=NSD(JT)+2
19399 IPART(3)=NSD(JT)+3
19400 IPART(4)=NSD(JT)+4
19401 PTPART(1)=0.5D0*P(ID,5)
19402 PTPART(2)=PTPART(1)
19403 PTPART(3)=PTPART(1)
19404 PTPART(4)=PTPART(1)
19405 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
19406 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
19407 IF(MOTHER.LE.NSD(JT)) THEN
19408 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
19409 ELSE
19410 NCT=NCT+1
19411 MCT(NSD(JT)+1,1)=NCT
19412 MCT(MOTHER,2)=NCT
19413 ENDIF
19414 ENDIF
19415 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
19416 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
19417 IF(MOTHER.LE.NSD(JT)) THEN
19418 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
19419 ELSE
19420 NCT=NCT+1
19421 MCT(NSD(JT)+1,2)=NCT
19422 MCT(MOTHER,1)=NCT
19423 ENDIF
19424 ENDIF
19425 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
19426 & KCQ2(JT).EQ.2)) THEN
19427 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
19428 IF(MOTHER.LE.NSD(JT)) THEN
19429 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
19430 ELSE
19431 NCT=NCT+1
19432 MCT(NSD(JT)+2,1)=NCT
19433 MCT(MOTHER,2)=NCT
19434 ENDIF
19435 ENDIF
19436 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
19437 & KCQ2(JT).EQ.2)) THEN
19438 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
19439 IF(MOTHER.LE.NSD(JT)) THEN
19440 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
19441 ELSE
19442 NCT=NCT+1
19443 MCT(NSD(JT)+2,2)=NCT
19444 MCT(MOTHER,1)=NCT
19445 ENDIF
19446 ENDIF
19447 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
19448 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
19449 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
19450 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
19451 ENDIF
19452 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
19453 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
19454 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
19455 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
19456 ENDIF
19457 IF(NPART.EQ.4.AND.MCT(NSD(JT)+4,1).EQ.0.AND.
19458 & (KCQ4(JT).EQ.1.OR. KCQ4(JT).EQ.2)) THEN
19459 MOTHER=K(NSD(JT)+4,4)/MSTU(5)
19460 MCT(NSD(JT)+4,1)=MCT(MOTHER,1)
19461 ENDIF
19462 IF(NPART.EQ.4.AND.MCT(NSD(JT)+4,2).EQ.0.AND.
19463 & (KCQ4(JT).EQ.-1.OR.KCQ4(JT).EQ.2)) THEN
19464 MOTHER=K(NSD(JT)+4,5)/MSTU(5)
19465 MCT(NSD(JT)+4,2)=MCT(MOTHER,2)
19466 ENDIF
19467
19468 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
19469 ENDIF
19470 NSHAFT=N
19471 IF(JT.EQ.1) NAFT1=N
19472
19473C...Check if decay products moved by shower.
19474 NSD1=NSD(JT)+1
19475 NSD2=NSD(JT)+2
19476 NSD3=NSD(JT)+3
19477 NSD4=NSD(JT)+4
19478C...4-body decays will only work if one of the products is "inert"
19479 IF(NSHAFT.GT.NSHBEF) THEN
19480 IF(K(NSD1,1).GT.10) THEN
19481 DO 660 I=NSHBEF+1,NSHAFT
19482 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
19483 660 CONTINUE
19484 ENDIF
19485 IF(K(NSD2,1).GT.10) THEN
19486 DO 670 I=NSHBEF+1,NSHAFT
19487 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
19488 & I.NE.NSD1) NSD2=I
19489 670 CONTINUE
19490 ENDIF
19491 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
19492 DO 680 I=NSHBEF+1,NSHAFT
19493 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
19494 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
19495 680 CONTINUE
19496 ENDIF
19497 IF(KFL4(JT).NE.0.AND.K(NSD4,1).GT.10) THEN
19498 DO 685 I=NSHBEF+1,NSHAFT
19499 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD4,2).AND.
19500 & I.NE.NSD1.AND.I.NE.NSD2.AND.I.NE.NSD3) NSD4=I
19501 685 CONTINUE
19502 ENDIF
19503 ENDIF
19504
19505C...Store decay products for further treatment.
19506 IF(KFL4(JT).EQ.0) THEN
19507 NP=NP+1
19508 IREF(NP,1)=NSD1
19509 IREF(NP,2)=NSD2
19510 IREF(NP,3)=0
19511 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
19512 IREF(NP,4)=IDOC+1
19513 IREF(NP,5)=IDOC+2
19514 IREF(NP,6)=0
19515 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
19516 IREF(NP,7)=K(IREF(IP,JT),2)
19517 IREF(NP,8)=IREF(IP,JT)
19518 ELSE
19519 NSDA=NSD1
19520 NSDB=NSD2
19521 NSDC=NSD3
19522 NP=NP+1
19523 IREF(NP,4)=IDOC+1
19524 IREF(NP,5)=IDOC+2
19525 IREF(NP,6)=IDOC+3
19526 IF(K(NSD1,1).EQ.1) THEN
19527 NSDA=NSD4
19528 IREF(NP,4)=IDOC+4
19529 ELSEIF(K(NSD2,1).EQ.1) THEN
19530 NSDB=NSD4
19531 IREF(NP,5)=IDOC+4
19532 ELSEIF(K(NSD3,1).EQ.1) THEN
19533 NSDC=NSD4
19534 IREF(NP,6)=IDOC+4
19535 ENDIF
19536 IREF(NP,1)=NSDA
19537 IREF(NP,2)=NSDB
19538 IREF(NP,3)=NSDC
19539 IREF(NP,7)=K(IREF(IP,JT),2)
19540 IREF(NP,8)=IREF(IP,JT)
19541 ENDIF
19542 690 CONTINUE
19543
19544
19545C...Fill information for 2 -> 1 -> 2.
19546 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
19547 MINT(7)=MINT(83)+6+2*ISET(ISUB)
19548 MINT(8)=MINT(83)+7+2*ISET(ISUB)
19549 MINT(25)=KFL1(1)
19550 MINT(26)=KFL2(1)
19551 VINT(23)=CTHE(1)
19552 RM3=P(N-1,5)**2/SH
19553 RM4=P(N,5)**2/SH
19554 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19555 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
19556 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
19557 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
19558 VINT(47)=SQRT(VINT(48))
19559 ENDIF
19560
19561C...Possibility of colour rearrangement in W+W- events.
19562 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
19563 IAKF1=IABS(KFL1(1))
19564 IAKF2=IABS(KFL1(2))
19565 IAKF3=IABS(KFL2(1))
19566 IAKF4=IABS(KFL2(2))
19567 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
19568 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
19569 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
19570 IF(MINT(51).NE.0) RETURN
19571 ENDIF
19572
19573C...Loop back if needed.
19574 710 IF(IP.LT.NP) GOTO 170
19575
19576C...Boost back to standard frame.
19577 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
19578 &BEZIN)
19579
19580
19581 RETURN
19582 END
19583
19584C*********************************************************************
19585
19586C...PYMULT
19587C...Initializes treatment of multiple interactions, selects kinematics
19588C...of hardest interaction if low-pT physics included in run, and
19589C...generates all non-hardest interactions.
19590
19591 SUBROUTINE PYMULT(MMUL)
19592
19593C...Double precision and integer declarations.
19594 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19595 IMPLICIT INTEGER(I-N)
19596 INTEGER PYK,PYCHGE,PYCOMP
19597C...Commonblocks.
19598 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19599 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19600 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19601 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19602 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19603 COMMON/PYINT1/MINT(400),VINT(400)
19604 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19605 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19606 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19607 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19608 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
19609 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
19610C...Local arrays and saved variables.
19611 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
19612 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19613 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19614 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19615
19616C...Initialization of multiple interaction treatment.
19617 IF(MMUL.EQ.1) THEN
19618 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19619 ISUB=96
19620 MINT(1)=96
19621 VINT(63)=0D0
19622 VINT(64)=0D0
19623 VINT(143)=1D0
19624 VINT(144)=1D0
19625
19626C...Loop over phase space points: xT2 choice in 20 bins.
19627 100 SIGSUM=0D0
19628 DO 120 IXT2=1,20
19629 NMUL(IXT2)=MSTP(83)
19630 SIGM(IXT2)=0D0
19631 DO 110 ITRY=1,MSTP(83)
19632 RSCA=0.05D0*((21-IXT2)-PYR(0))
19633 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19634 XT2=MAX(0.01D0*VINT(149),XT2)
19635 VINT(25)=XT2
19636
19637C...Choose tau and y*. Calculate cos(theta-hat).
19638 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19639 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19640 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19641 ELSE
19642 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19643 ENDIF
19644 VINT(21)=TAU
19645 CALL PYKLIM(2)
19646 RYST=PYR(0)
19647 MYST=1
19648 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19649 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19650 CALL PYKMAP(2,MYST,PYR(0))
19651 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19652
19653C...Calculate differential cross-section.
19654 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19655 CALL PYSIGH(NCHN,SIGS)
19656 SIGM(IXT2)=SIGM(IXT2)+SIGS
19657 110 CONTINUE
19658 SIGSUM=SIGSUM+SIGM(IXT2)
19659 120 CONTINUE
19660 SIGSUM=SIGSUM/(20D0*MSTP(83))
19661
19662C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19663 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19664 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19665 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19666 PARP(82)=0.9D0*PARP(82)
19667 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19668 & VINT(2)
19669 GOTO 100
19670 ENDIF
19671 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19672 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19673
19674C...Start iteration to find k factor.
19675 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19676 P83A=(1D0-PARP(83))**2
19677 P83B=2D0*PARP(83)*(1D0-PARP(83))
19678 P83C=PARP(83)**2
19679 CQ2I=1D0/PARP(84)**2
19680 CQ2R=2D0/(1D0+PARP(84)**2)
19681 SO=0.5D0
19682 XI=0D0
19683 YI=0D0
19684 XF=0D0
19685 YF=0D0
19686 XK=0.5D0
19687 IIT=0
19688 130 IF(IIT.EQ.0) THEN
19689 XK=2D0*XK
19690 ELSEIF(IIT.EQ.1) THEN
19691 XK=0.5D0*XK
19692 ELSE
19693 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19694 ENDIF
19695
19696C...Evaluate overlap integrals. Find where to divide the b range.
19697 IF(MSTP(82).EQ.2) THEN
19698 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19699 SOP=SP/PARU(1)
19700 ELSE
19701 IF(MSTP(82).EQ.3) THEN
19702 DELTAB=0.02D0
19703 ELSEIF(MSTP(82).EQ.4) THEN
19704 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19705 ELSE
19706 POWIP=MAX(0.4D0,PARP(83))
19707 RPWIP=2D0/POWIP-1D0
19708 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19709 SO=0D0
19710 ENDIF
19711 SP=0D0
19712 SOP=0D0
19713 BSP=0D0
19714 SOHIGH=0D0
19715 IBDIV=0
19716 B=-0.5D0*DELTAB
19717 140 B=B+DELTAB
19718 IF(MSTP(82).EQ.3) THEN
19719 OV=EXP(-B**2)/PARU(2)
19720 ELSEIF(MSTP(82).EQ.4) THEN
19721 OV=(P83A*EXP(-MIN(50D0,B**2))+
19722 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19723 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19724 ELSE
19725 OV=EXP(-B**POWIP)/PARU(2)
19726 SO=SO+PARU(2)*B*DELTAB*OV
19727 ENDIF
19728 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19729 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19730 SP=SP+PARU(2)*B*DELTAB*PACC
19731 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19732 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19733 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19734 IBDIV=1
19735 BDIV=B+0.5D0*DELTAB
19736 ENDIF
19737 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19738 ENDIF
19739 YK=PARU(1)*XK*SO/SP
19740
19741C...Continue iteration until convergence.
19742 IF(YK.LT.YKE) THEN
19743 XI=XK
19744 YI=YK
19745 IF(IIT.EQ.1) IIT=2
19746 ELSE
19747 XF=XK
19748 YF=YK
19749 IF(IIT.EQ.0) IIT=1
19750 ENDIF
19751 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19752
19753C...Store some results for subsequent use.
19754 BAVG=BSP/SP
19755 VINT(145)=SIGSUM
19756 VINT(146)=SOP/SO
19757 VINT(147)=SOP/SP
19758 VNT145=VINT(145)
19759 VNT146=VINT(146)
19760 VNT147=VINT(147)
19761C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19762 PIK=(VNT146/VNT147)*YKE
19763
19764C...Find relative weight for low and high impact parameter.
19765 PLOWB=PARU(1)*BDIV**2
19766 IF(MSTP(82).EQ.3) THEN
19767 PHIGHB=PIK*0.5*EXP(-BDIV**2)
19768 ELSEIF(MSTP(82).EQ.4) THEN
19769 S4A=P83A*EXP(-BDIV**2)
19770 S4B=P83B*EXP(-BDIV**2*CQ2R)
19771 S4C=P83C*EXP(-BDIV**2*CQ2I)
19772 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19773 ELSEIF(PARP(83).GE.1.999D0) THEN
19774 PHIGHB=PIK*SOHIGH
19775 B2RPDV=BDIV**POWIP
19776 ELSE
19777 PHIGHB=PIK*SOHIGH
19778 B2RPDV=BDIV**POWIP
19779 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
19780 ENDIF
19781 PALLB=PLOWB+PHIGHB
19782
19783C...Initialize iteration in xT2 for hardest interaction.
19784 ELSEIF(MMUL.EQ.2) THEN
19785 VINT(145)=VNT145
19786 VINT(146)=VNT146
19787 VINT(147)=VNT147
19788 IF(MSTP(82).LE.0) THEN
19789 ELSEIF(MSTP(82).EQ.1) THEN
19790 XT2=1D0
19791 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19792 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19793 & VINT(317)/(VINT(318)*VINT(320))
19794 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19795 ELSEIF(MSTP(82).EQ.2) THEN
19796 XT2=1D0
19797 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19798 & VINT(149)*(1D0+VINT(149))
19799 ELSE
19800 XC2=4D0*CKIN(3)**2/VINT(2)
19801 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
19802 ENDIF
19803
19804C...Select impact parameter for hardest interaction.
19805 IF(MSTP(82).LE.2) RETURN
19806 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
19807C...Treatment in low b region.
19808 MINT(39)=1
19809 B=BDIV*SQRT(PYR(0))
19810 IF(MSTP(82).EQ.3) THEN
19811 OV=EXP(-B**2)/PARU(2)
19812 ELSEIF(MSTP(82).EQ.4) THEN
19813 OV=(P83A*EXP(-MIN(50D0,B**2))+
19814 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19815 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19816 ELSE
19817 OV=EXP(-B**POWIP)/PARU(2)
19818 ENDIF
19819 VINT(148)=OV/VNT147
19820 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
19821 XT2=1D0
19822 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19823 & VINT(149)*(1D0+VINT(149))
19824 ELSE
19825C...Treatment in high b region.
19826 MINT(39)=2
19827 IF(MSTP(82).EQ.3) THEN
19828 B=SQRT(BDIV**2-LOG(PYR(0)))
19829 OV=EXP(-B**2)/PARU(2)
19830 ELSEIF(MSTP(82).EQ.4) THEN
19831 S4RNDM=PYR(0)*(S4A+S4B+S4C)
19832 IF(S4RNDM.LT.S4A) THEN
19833 B=SQRT(BDIV**2-LOG(PYR(0)))
19834 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
19835 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
19836 ELSE
19837 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
19838 ENDIF
19839 OV=(P83A*EXP(-MIN(50D0,B**2))+
19840 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19841 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19842 ELSEIF(PARP(83).GE.1.999D0) THEN
19843 144 B2RPW=B2RPDV-LOG(PYR(0))
19844 ACCIP=(B2RPW/B2RPDV)**RPWIP
19845 IF(ACCIP.LT.PYR(0)) GOTO 144
19846 OV=EXP(-B2RPW)/PARU(2)
19847 B=B2RPW**(1D0/POWIP)
19848 ELSE
19849 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
19850 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
19851 IF(ACCIP.LT.PYR(0)) GOTO 146
19852 OV=EXP(-B2RPW)/PARU(2)
19853 B=B2RPW**(1D0/POWIP)
19854 ENDIF
19855 VINT(148)=OV/VNT147
19856 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
19857 ENDIF
19858 IF(PACC.LT.PYR(0)) GOTO 142
19859 VINT(139)=B/BAVG
19860
19861 ELSEIF(MMUL.EQ.3) THEN
19862C...Low-pT or multiple interactions (first semihard interaction):
19863C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19864C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19865 ISUB=MINT(1)
19866 VINT(145)=VNT145
19867 VINT(146)=VNT146
19868 VINT(147)=VNT147
19869 IF(MSTP(82).LE.0) THEN
19870 XT2=0D0
19871 ELSEIF(MSTP(82).EQ.1) THEN
19872 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19873C...Use with "Sudakov" for low b values when impact parameter dependence.
19874 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
19875 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
19876 & VINT(149)))).GT.PYR(0)) XT2=1D0
19877 IF(XT2.GE.1D0) THEN
19878 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
19879 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
19880 & VINT(149)
19881 ELSE
19882 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
19883 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
19884 & VINT(149)
19885 ENDIF
19886 XT2=MAX(0.01D0*VINT(149),XT2)
19887C...Use without "Sudakov" for high b values when impact parameter dep.
19888 ELSE
19889 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
19890 & PYR(0)*(1D0-XC2))-VINT(149)
19891 XT2=MAX(0.01D0*VINT(149),XT2)
19892 ENDIF
19893 VINT(25)=XT2
19894
19895C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19896 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
19897 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
19898 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
19899 ISUB=95
19900 MINT(1)=ISUB
19901 VINT(21)=0.01D0*VINT(149)
19902 VINT(22)=0D0
19903 VINT(23)=0D0
19904 VINT(25)=0.01D0*VINT(149)
19905
19906 ELSE
19907C...Multiple interactions (first semihard interaction).
19908C...Choose tau and y*. Calculate cos(theta-hat).
19909 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19910 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19911 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19912 ELSE
19913 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19914 ENDIF
19915 VINT(21)=TAU
19916 CALL PYKLIM(2)
19917 RYST=PYR(0)
19918 MYST=1
19919 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19920 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19921 CALL PYKMAP(2,MYST,PYR(0))
19922 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19923 ENDIF
19924 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
19925
19926C...Store results of cross-section calculation.
19927 ELSEIF(MMUL.EQ.4) THEN
19928 ISUB=MINT(1)
19929 VINT(145)=VNT145
19930 VINT(146)=VNT146
19931 VINT(147)=VNT147
19932 XTS=VINT(25)
19933 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
19934 IF(ISET(ISUB).EQ.2)
19935 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
19936 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
19937 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
19938 & (XTS+VINT(149))))
19939 IRBIN=INT(1D0+20D0*RBIN)
19940 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
19941 NMUL(IRBIN)=NMUL(IRBIN)+1
19942 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
19943 ENDIF
19944
19945C...Choose impact parameter if not already done.
19946 ELSEIF(MMUL.EQ.5) THEN
19947 ISUB=MINT(1)
19948 VINT(145)=VNT145
19949 VINT(146)=VNT146
19950 VINT(147)=VNT147
19951 150 IF(MINT(39).GT.0) THEN
19952 ELSEIF(MSTP(82).EQ.3) THEN
19953 EXPB2=PYR(0)
19954 B2=-LOG(PYR(0))
19955 VINT(148)=EXPB2/(PARU(2)*VNT147)
19956 VINT(139)=SQRT(B2)/BAVG
19957 ELSEIF(MSTP(82).EQ.4) THEN
19958 RTYPE=PYR(0)
19959 IF(RTYPE.LT.P83A) THEN
19960 B2=-LOG(PYR(0))
19961 ELSEIF(RTYPE.LT.P83A+P83B) THEN
19962 B2=-LOG(PYR(0))/CQ2R
19963 ELSE
19964 B2=-LOG(PYR(0))/CQ2I
19965 ENDIF
19966 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
19967 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
19968 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
19969 VINT(139)=SQRT(B2)/BAVG
19970 ELSEIF(PARP(83).GE.1.999D0) THEN
19971 POWIP=MAX(2D0,PARP(83))
19972 RPWIP=2D0/POWIP-1D0
19973 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
19974 160 IF(PYR(0).LT.PROB1) THEN
19975 B2RPW=PYR(0)**(0.5D0*POWIP)
19976 ACCIP=EXP(-B2RPW)
19977 ELSE
19978 B2RPW=1D0-LOG(PYR(0))
19979 ACCIP=B2RPW**RPWIP
19980 ENDIF
19981 IF(ACCIP.LT.PYR(0)) GOTO 160
19982 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19983 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19984 ELSE
19985 POWIP=MAX(0.4D0,PARP(83))
19986 RPWIP=2D0/POWIP-1D0
19987 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
19988 170 IF(PYR(0).LT.PROB1) THEN
19989 B2RPW=2D0*RPWIP*PYR(0)
19990 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
19991 ELSE
19992 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
19993 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
19994 ENDIF
19995 IF(ACCIP.LT .PYR(0)) GOTO 170
19996 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19997 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19998 ENDIF
19999
20000C...Multiple interactions (variable impact parameter) : reject with
20001C...probability exp(-overlap*cross-section above pT/normalization).
20002C...Does not apply to low-b region, where "Sudakov" already included.
20003 VINT(150)=1D0
20004 IF(MINT(39).NE.1) THEN
20005 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
20006 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
20007 DO 180 IBIN=IRBIN+1,20
20008 RNCOR=RNCOR+NMUL(IBIN)
20009 SIGCOR=SIGCOR+SIGM(IBIN)
20010 180 CONTINUE
20011 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
20012 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
20013 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
20014 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
20015 ENDIF
20016 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
20017 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
20018 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20019 IF(VINT(150).LT.PYR(0)) GOTO 150
20020 VINT(150)=1D0
20021 ENDIF
20022
20023C...Generate additional multiple semihard interactions.
20024 ELSEIF(MMUL.EQ.6) THEN
20025 ISUBSV=MINT(1)
20026 VINT(145)=VNT145
20027 VINT(146)=VNT146
20028 VINT(147)=VNT147
20029 DO 190 J=11,80
20030 VINTSV(J)=VINT(J)
20031 190 CONTINUE
20032 ISUB=96
20033 MINT(1)=96
20034 VINT(151)=0D0
20035 VINT(152)=0D0
20036
20037C...Reconstruct strings in hard scattering.
20038 NMAX=MINT(84)+4
20039 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
20040 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
20041 NSTR=0
20042 DO 210 I=MINT(84)+1,NMAX
20043 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
20044 IF(KCS.EQ.0) GOTO 210
20045 DO 200 J=1,4
20046 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
20047 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
20048 IF(J.LE.2) THEN
20049 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
20050 ELSE
20051 IST=MOD(K(I,J+1),MSTU(5))
20052 ENDIF
20053 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
20054 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
20055 NSTR=NSTR+1
20056 IF(J.EQ.1.OR.J.EQ.4) THEN
20057 KSTR(NSTR,1)=I
20058 KSTR(NSTR,2)=IST
20059 ELSE
20060 KSTR(NSTR,1)=IST
20061 KSTR(NSTR,2)=I
20062 ENDIF
20063 200 CONTINUE
20064 210 CONTINUE
20065
20066C...Set up starting values for iteration in xT2.
20067 XT2=4D0*VINT(62)/VINT(2)
20068 IF(MSTP(82).LE.1) THEN
20069 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20070 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20071 & VINT(317)/(VINT(318)*VINT(320))
20072 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20073 ELSE
20074 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
20075 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
20076 ENDIF
20077 VINT(63)=0D0
20078 VINT(64)=0D0
20079 VINT(143)=1D0-VINT(141)
20080 VINT(144)=1D0-VINT(142)
20081
20082C...Iterate downwards in xT2.
20083 220 IF(MSTP(82).LE.1) THEN
20084 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20085 IF(XT2.LT.VINT(149)) GOTO 270
20086 ELSE
20087 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
20088 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
20089 & LOG(PYR(0)))-VINT(149)
20090 IF(XT2.LE.0D0) GOTO 270
20091 XT2=MAX(0.01D0*VINT(149),XT2)
20092 ENDIF
20093 VINT(25)=XT2
20094
20095C...Choose tau and y*. Calculate cos(theta-hat).
20096 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20097 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20098 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20099 ELSE
20100 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20101 ENDIF
20102 VINT(21)=TAU
20103 CALL PYKLIM(2)
20104 RYST=PYR(0)
20105 MYST=1
20106 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20107 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20108 CALL PYKMAP(2,MYST,PYR(0))
20109 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20110
20111C...Check that x not used up. Accept or reject kinematical variables.
20112 X1M=SQRT(TAU)*EXP(VINT(22))
20113 X2M=SQRT(TAU)*EXP(-VINT(22))
20114 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
20115 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20116 CALL PYSIGH(NCHN,SIGS)
20117 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
20118 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
20119
20120C...Reset K, P and V vectors. Select some variables.
20121 DO 240 I=N+1,N+2
20122 DO 230 J=1,5
20123 K(I,J)=0
20124 P(I,J)=0D0
20125 V(I,J)=0D0
20126 230 CONTINUE
20127 240 CONTINUE
20128 RFLAV=PYR(0)
20129 PT=0.5D0*VINT(1)*SQRT(XT2)
20130 PHI=PARU(2)*PYR(0)
20131 CTH=VINT(23)
20132
20133C...Add first parton to event record.
20134 K(N+1,1)=3
20135 K(N+1,2)=21
20136 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
20137 & 1+INT((2D0+PARJ(2))*PYR(0))
20138 P(N+1,1)=PT*COS(PHI)
20139 P(N+1,2)=PT*SIN(PHI)
20140 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
20141 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
20142 P(N+1,5)=0D0
20143
20144C...Add second parton to event record.
20145 K(N+2,1)=3
20146 K(N+2,2)=21
20147 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
20148 P(N+2,1)=-P(N+1,1)
20149 P(N+2,2)=-P(N+1,2)
20150 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
20151 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
20152 P(N+2,5)=0D0
20153
20154 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
20155C....Choose relevant string pieces to place gluons on.
20156 DO 260 I=N+1,N+2
20157 DMIN=1D8
20158 DO 250 ISTR=1,NSTR
20159 I1=KSTR(ISTR,1)
20160 I2=KSTR(ISTR,2)
20161 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
20162 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
20163 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
20164 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
20165 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
20166 DMIN=DIST
20167 IST1=I1
20168 IST2=I2
20169 ISTM=ISTR
20170 ENDIF
20171 250 CONTINUE
20172
20173C....Colour flow adjustments, new string pieces.
20174 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
20175 & MOD(K(IST1,4),MSTU(5))
20176 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
20177 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
20178 K(I,5)=MSTU(5)*IST1
20179 K(I,4)=MSTU(5)*IST2
20180 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
20181 & MOD(K(IST2,5),MSTU(5))
20182 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
20183 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
20184 KSTR(ISTM,2)=I
20185 KSTR(NSTR+1,1)=I
20186 KSTR(NSTR+1,2)=IST2
20187 NSTR=NSTR+1
20188 260 CONTINUE
20189
20190C...String drawing and colour flow for gluon loop.
20191 ELSEIF(K(N+1,2).EQ.21) THEN
20192 K(N+1,4)=MSTU(5)*(N+2)
20193 K(N+1,5)=MSTU(5)*(N+2)
20194 K(N+2,4)=MSTU(5)*(N+1)
20195 K(N+2,5)=MSTU(5)*(N+1)
20196 KSTR(NSTR+1,1)=N+1
20197 KSTR(NSTR+1,2)=N+2
20198 KSTR(NSTR+2,1)=N+2
20199 KSTR(NSTR+2,2)=N+1
20200 NSTR=NSTR+2
20201
20202C...String drawing and colour flow for qqbar pair.
20203 ELSE
20204 K(N+1,4)=MSTU(5)*(N+2)
20205 K(N+2,5)=MSTU(5)*(N+1)
20206 KSTR(NSTR+1,1)=N+1
20207 KSTR(NSTR+1,2)=N+2
20208 NSTR=NSTR+1
20209 ENDIF
20210
20211C...Global statistics.
20212 MINT(351)=MINT(351)+1
20213 VINT(351)=VINT(351)+PT
20214 IF (MINT(351).EQ.1) VINT(356)=PT
20215
20216C...Update remaining energy; iterate.
20217 N=N+2
20218 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
20219 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
20220 MINT(51)=1
20221 RETURN
20222 ENDIF
20223 MINT(31)=MINT(31)+1
20224 VINT(151)=VINT(151)+VINT(41)
20225 VINT(152)=VINT(152)+VINT(42)
20226 VINT(143)=VINT(143)-VINT(41)
20227 VINT(144)=VINT(144)-VINT(42)
20228C...Allow FSR for UE (always handle with old showers)
20229 IF(MSTP(152).EQ.1) THEN
20230 M41SAV=MSTJ(41)
20231 IF (MSTJ(41).EQ.10) MSTJ(41)=2
20232 MSTJ(41)=MOD(MSTJ(41),10)
20233 CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
20234 MSTJ(41)=M41SAV
20235 ENDIF
20236 IF(MINT(31).LT.240) GOTO 220
20237 270 CONTINUE
20238 MINT(1)=ISUBSV
20239 DO 280 J=11,80
20240 VINT(J)=VINTSV(J)
20241 280 CONTINUE
20242 ENDIF
20243
20244C...Format statements for printout.
20245 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
20246 &'actions for MSTP(82) =',I2,' ******')
20247 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20248 &D9.2,' mb: rejected')
20249 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20250 &D9.2,' mb: accepted')
20251
20252 RETURN
20253 END
20254
20255C*********************************************************************
20256
20257C...PYREMN
20258C...Adds on target remnants (one or two from each side) and
20259C...includes primordial kT for hadron beams.
20260
20261 SUBROUTINE PYREMN(IPU1,IPU2)
20262
20263C...Double precision and integer declarations.
20264 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20265 IMPLICIT INTEGER(I-N)
20266 INTEGER PYK,PYCHGE,PYCOMP
20267C...Commonblocks.
20268 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20269 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20270 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20271 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20272 COMMON/PYINT1/MINT(400),VINT(400)
20273 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
20274C...Local arrays.
20275 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
20276 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
20277
20278C...Find event type and remaining energy.
20279 ISUB=MINT(1)
20280 NS=N
20281 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
20282 VINT(143)=1D0-VINT(141)
20283 VINT(144)=1D0-VINT(142)
20284 ENDIF
20285
20286C...Define initial partons.
20287 NTRY=0
20288 100 NTRY=NTRY+1
20289 DO 130 JT=1,2
20290 I=MINT(83)+JT+2
20291 IF(JT.EQ.1) IPU=IPU1
20292 IF(JT.EQ.2) IPU=IPU2
20293 K(I,1)=21
20294 K(I,2)=K(IPU,2)
20295 K(I,3)=I-2
20296 PMS(JT)=0D0
20297 VINT(156+JT)=0D0
20298 VINT(158+JT)=0D0
20299 IF(MINT(47).EQ.1) THEN
20300 DO 110 J=1,5
20301 P(I,J)=P(I-2,J)
20302 110 CONTINUE
20303 ELSEIF(ISUB.EQ.95) THEN
20304 K(I,2)=21
20305 ELSE
20306 P(I,5)=P(IPU,5)
20307
20308C...No primordial kT, or chosen according to truncated Gaussian or
20309C...exponential, or (for photon) predetermined or power law.
20310 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
20311 IF(MSTP(91).LE.0) THEN
20312 PT=0D0
20313 ELSEIF(MSTP(91).EQ.1) THEN
20314 PT=PARP(91)*SQRT(-LOG(PYR(0)))
20315 ELSE
20316 RPT1=PYR(0)
20317 RPT2=PYR(0)
20318 PT=-PARP(92)*LOG(RPT1*RPT2)
20319 ENDIF
20320 IF(PT.GT.PARP(93)) GOTO 120
20321 ELSEIF(MINT(106+JT).EQ.3) THEN
20322 PTA=SQRT(VINT(282+JT))
20323 PTB=0D0
20324 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
20325 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
20326 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
20327 RPT1=PYR(0)
20328 RPT2=PYR(0)
20329 PTB=-PARP(99)*LOG(RPT1*RPT2)
20330 ENDIF
20331 IF(PTB.GT.PARP(100)) GOTO 120
20332 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
20333 PT=PT*0.8D0**MINT(57)
20334 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
20335 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
20336 IF(MSTP(93).LE.0) THEN
20337 PT=0D0
20338 ELSEIF(MSTP(93).EQ.1) THEN
20339 PT=PARP(99)*SQRT(-LOG(PYR(0)))
20340 ELSEIF(MSTP(93).EQ.2) THEN
20341 RPT1=PYR(0)
20342 RPT2=PYR(0)
20343 PT=-PARP(99)*LOG(RPT1*RPT2)
20344 ELSEIF(MSTP(93).EQ.3) THEN
20345 HA=PARP(99)**2
20346 HB=PARP(100)**2
20347 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
20348 ELSE
20349 HA=PARP(99)**2
20350 HB=PARP(100)**2
20351 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
20352 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
20353 ENDIF
20354 IF(PT.GT.PARP(100)) GOTO 120
20355 ELSE
20356 PT=0D0
20357 ENDIF
20358 VINT(156+JT)=PT
20359 PHI=PARU(2)*PYR(0)
20360 P(I,1)=PT*COS(PHI)
20361 P(I,2)=PT*SIN(PHI)
20362 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20363 ENDIF
20364 130 CONTINUE
20365 IF(MINT(47).EQ.1) RETURN
20366
20367C...Kinematics construction for initial partons.
20368 I1=MINT(83)+3
20369 I2=MINT(83)+4
20370 IF(ISUB.EQ.95) THEN
20371 SHS=0D0
20372 SHR=0D0
20373 ELSE
20374 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
20375 & (P(I1,2)+P(I2,2))**2
20376 SHR=SQRT(MAX(0D0,SHS))
20377 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
20378 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
20379 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
20380 P(I2,4)=SHR-P(I1,4)
20381 P(I2,3)=-P(I1,3)
20382
20383C...Transform partons to overall CM-frame.
20384 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
20385 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
20386 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
20387 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
20388 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
20389 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
20390 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
20391 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
20392 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
20393 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
20394 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
20395 ENDIF
20396
20397C...Optionally fix up x and Q2 definitions for leptoproduction.
20398 IDISXQ=0
20399 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
20400 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
20401 IF(IDISXQ.EQ.1) THEN
20402
20403C...Find where incoming and outgoing leptons/partons are sitting.
20404 LESD=1
20405 IF(MINT(42).EQ.1) LESD=2
20406 LPIN=MINT(83)+3-LESD
20407 LEIN=MINT(84)+LESD
20408 LQIN=MINT(84)+3-LESD
20409 LEOUT=MINT(84)+2+LESD
20410 LQOUT=MINT(84)+5-LESD
20411 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
20412 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
20413 LSCMS=0
20414 DO 140 I=MINT(84)+5,N
20415 IF(K(I,2).EQ.94) THEN
20416 LSCMS=I
20417 LEOUT=I+LESD
20418 LQOUT=I+3-LESD
20419 ENDIF
20420 140 CONTINUE
20421 LQBG=IPU1
20422 IF(LESD.EQ.1) LQBG=IPU2
20423
20424C...Calculate actual and wanted momentum transfer.
20425 XNOM=VINT(43-LESD)
20426 Q2NOM=-VINT(45)
20427 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
20428 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
20429 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
20430 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
20431 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
20432 P(N+1,1)=FAC*P(LEOUT,1)
20433 P(N+1,2)=FAC*P(LEOUT,2)
20434 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
20435 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
20436 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
20437 & P(N+1,3)**2)
20438 DO 150 J=1,4
20439 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
20440 QNEW(J)=P(LEIN,J)-P(N+1,J)
20441 150 CONTINUE
20442
20443C...Boost outgoing electron and daughters.
20444 IF(LSCMS.EQ.0) THEN
20445 DO 160 J=1,4
20446 P(LEOUT,J)=P(N+1,J)
20447 160 CONTINUE
20448 ELSE
20449 DO 170 J=1,3
20450 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
20451 170 CONTINUE
20452 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
20453 DO 180 J=1,3
20454 DBE(J)=PINV*P(N+2,J)
20455 180 CONTINUE
20456 DO 200 I=LSCMS+1,N
20457 IORIG=I
20458 190 IORIG=K(IORIG,3)
20459 IF(IORIG.GT.LEOUT) GOTO 190
20460 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
20461 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
20462 200 CONTINUE
20463 ENDIF
20464
20465C...Copy shower initiator and all outgoing partons.
20466 NCOP=N+1
20467 K(NCOP,3)=LQBG
20468 DO 210 J=1,5
20469 P(NCOP,J)=P(LQBG,J)
20470 210 CONTINUE
20471 DO 240 I=MINT(84)+1,N
20472 ICOP=0
20473 IF(K(I,1).GT.10) GOTO 240
20474 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
20475 ICOP=I
20476 ELSE
20477 IORIG=I
20478 220 IORIG=K(IORIG,3)
20479 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
20480 ICOP=IORIG
20481 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
20482 GOTO 220
20483 ENDIF
20484 ENDIF
20485 IF(ICOP.NE.0) THEN
20486 NCOP=NCOP+1
20487 K(NCOP,3)=I
20488 DO 230 J=1,5
20489 P(NCOP,J)=P(I,J)
20490 230 CONTINUE
20491 ENDIF
20492 240 CONTINUE
20493
20494C...Calculate relative rescaling factors.
20495 SLC=3-2*LESD
20496 PLCSUM=0D0
20497 DO 250 I=N+2,NCOP
20498 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
20499 250 CONTINUE
20500 DO 260 I=N+2,NCOP
20501 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
20502 260 CONTINUE
20503
20504C...Transfer extra three-momentum of current.
20505 DO 280 I=N+2,NCOP
20506 DO 270 J=1,3
20507 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
20508 270 CONTINUE
20509 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20510 280 CONTINUE
20511
20512C...Iterate change of initiator momentum to get energy right.
20513 ITER=0
20514 290 ITER=ITER+1
20515 PEEX=-P(N+1,4)-QNEW(4)
20516 PEMV=-P(N+1,3)/P(N+1,4)
20517 DO 300 I=N+2,NCOP
20518 PEEX=PEEX+P(I,4)
20519 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
20520 300 CONTINUE
20521 IF(ABS(PEMV).LT.1D-10) THEN
20522 MINT(51)=1
20523 MINT(57)=MINT(57)+1
20524 RETURN
20525 ENDIF
20526 PZCH=-PEEX/PEMV
20527 P(N+1,3)=P(N+1,3)+PZCH
20528 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)
20529 DO 310 I=N+2,NCOP
20530 P(I,3)=P(I,3)+V(I,1)*PZCH
20531 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20532 310 CONTINUE
20533 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
20534
20535C...Modify momenta in event record.
20536 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
20537 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
20538 IF(ABS(HBE).GE.1D0) THEN
20539 MINT(51)=1
20540 MINT(57)=MINT(57)+1
20541 RETURN
20542 ENDIF
20543 I=MINT(83)+5-LESD
20544 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
20545 DO 330 I=N+1,NCOP
20546 ICOP=K(I,3)
20547 DO 320 J=1,4
20548 P(ICOP,J)=P(I,J)
20549 320 CONTINUE
20550 330 CONTINUE
20551 ENDIF
20552
20553C...Check minimum invariant mass of remnant system(s).
20554 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
20555 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
20556 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20557 PMIN(0)=SQRT(PMS(0))
20558 DO 340 JT=1,2
20559 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
20560 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
20561 PMIN(JT)=0D0
20562 IF(MINT(44+JT).EQ.1) GOTO 340
20563 MINT(105)=MINT(102+JT)
20564 MINT(109)=MINT(106+JT)
20565 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
20566 IF(MINT(51).NE.0) THEN
20567 MINT(57)=MINT(57)+1
20568 RETURN
20569 ENDIF
20570 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
20571 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
20572 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
20573 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
20574 & P(MINT(83)+JT+2,2)**2)
20575 340 CONTINUE
20576 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
20577 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
20578 &PSYS(2,4))) THEN
20579 MINT(51)=1
20580 MINT(57)=MINT(57)+1
20581 RETURN
20582 ENDIF
20583
20584C...Loop over two remnants; skip if none there.
20585 I=NS
20586 DO 410 JT=1,2
20587 ISN(JT)=0
20588 IF(MINT(44+JT).EQ.1) GOTO 410
20589 IF(JT.EQ.1) IPU=IPU1
20590 IF(JT.EQ.2) IPU=IPU2
20591
20592C...Store first remnant parton.
20593 I=I+1
20594 IS(JT)=I
20595 ISN(JT)=1
20596 DO 350 J=1,5
20597 K(I,J)=0
20598 P(I,J)=0D0
20599 V(I,J)=0D0
20600 350 CONTINUE
20601 K(I,1)=1
20602 K(I,2)=KFLSP(JT)
20603 K(I,3)=MINT(83)+JT
20604 P(I,5)=PYMASS(K(I,2))
20605
20606C...First parton colour connections and kinematics.
20607 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
20608 IF(KCOL.EQ.2) THEN
20609 K(I,1)=3
20610 K(I,4)=MSTU(5)*IPU+IPU
20611 K(I,5)=MSTU(5)*IPU+IPU
20612 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20613 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20614 ELSEIF(KCOL.NE.0) THEN
20615 K(I,1)=3
20616 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
20617 K(I,KFLS+3)=IPU
20618 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20619 ENDIF
20620 IF(KFLCH(JT).EQ.0) THEN
20621 P(I,1)=-P(MINT(83)+JT+2,1)
20622 P(I,2)=-P(MINT(83)+JT+2,2)
20623 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20624 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20625 P(I,3)=PSYS(JT,3)
20626 P(I,4)=PSYS(JT,4)
20627
20628C...When extra remnant parton or hadron: store extra remnant.
20629 ELSE
20630 I=I+1
20631 ISN(JT)=2
20632 DO 360 J=1,5
20633 K(I,J)=0
20634 P(I,J)=0D0
20635 V(I,J)=0D0
20636 360 CONTINUE
20637 K(I,1)=1
20638 K(I,2)=KFLCH(JT)
20639 K(I,3)=MINT(83)+JT
20640 P(I,5)=PYMASS(K(I,2))
20641
20642C...Find parton colour connections of extra remnant.
20643 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
20644 IF(KCOL.EQ.2) THEN
20645 K(I,1)=3
20646 K(I,4)=MSTU(5)*IPU+IPU
20647 K(I,5)=MSTU(5)*IPU+IPU
20648 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20649 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20650 ELSEIF(KCOL.NE.0) THEN
20651 K(I,1)=3
20652 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
20653 K(I,KFLS+3)=IPU
20654 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20655 ENDIF
20656
20657C...Relative transverse momentum when two remnants.
20658 LOOP=0
20659 370 LOOP=LOOP+1
20660 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
20661 IF(IABS(MINT(10+JT)).LT.20) THEN
20662 P(I-1,1)=0D0
20663 P(I-1,2)=0D0
20664 ELSE
20665 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
20666 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
20667 ENDIF
20668 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
20669 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
20670 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
20671 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20672
20673C...Meson or baryon; photon as meson. For splitup below.
20674 IMB=1
20675 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
20676
20677C***Relative distribution for electron into two electrons. Temporary!
20678 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
20679 & THEN
20680 CHI(JT)=PYR(0)
20681
20682C...Relative distribution of electron energy into electron plus parton.
20683 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
20684 XHRD=VINT(140+JT)
20685 XE=VINT(154+JT)
20686 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
20687
20688C...Relative distribution of energy for particle into two jets.
20689 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
20690 CHIK=PARP(92+2*IMB)
20691 IF(MSTP(92).LE.1) THEN
20692 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20693 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20694 ELSEIF(MSTP(92).EQ.2) THEN
20695 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
20696 ELSEIF(MSTP(92).EQ.3) THEN
20697 CUT=2D0*0.3D0/VINT(1)
20698 380 CHI(JT)=PYR(0)**2
20699 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
20700 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
20701 ELSEIF(MSTP(92).EQ.4) THEN
20702 CUT=2D0*0.3D0/VINT(1)
20703 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
20704 390 CHIR=CUT*CUTR**PYR(0)
20705 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
20706 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
20707 ELSE
20708 CUT=2D0*0.3D0/VINT(1)
20709 CUTA=CUT**(1D0-PARP(98))
20710 CUTB=(1D0+CUT)**(1D0-PARP(98))
20711 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
20712 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
20713 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
20714 ENDIF
20715
20716C...Relative distribution of energy for particle into jet plus particle.
20717 ELSE
20718 IF(MSTP(94).LE.1) THEN
20719 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20720 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20721 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20722 ELSEIF(MSTP(94).EQ.2) THEN
20723 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
20724 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20725 ELSEIF(MSTP(94).EQ.3) THEN
20726 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
20727 CHI(JT)=ZZ
20728 ELSE
20729 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
20730 CHI(JT)=ZZ
20731 ENDIF
20732 ENDIF
20733
20734C...Construct total transverse mass; reject if too large.
20735 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
20736 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
20737 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
20738 IF(LOOP.LT.100) THEN
20739 GOTO 370
20740 ELSE
20741 MINT(51)=1
20742 MINT(57)=MINT(57)+1
20743 RETURN
20744 ENDIF
20745 ENDIF
20746 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20747 VINT(158+JT)=CHI(JT)
20748
20749C...Subdivide longitudinal momentum according to value selected above.
20750 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
20751 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
20752 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
20753 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
20754 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
20755 ENDIF
20756 410 CONTINUE
20757 N=I
20758
20759C...Check if longitudinal boosts needed - if so pick two systems.
20760 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
20761 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
20762 IF(PDEV.LE.1D-6*VINT(1)) RETURN
20763 IF(ISN(1).EQ.0) THEN
20764 IR=0
20765 IL=2
20766 ELSEIF(ISN(2).EQ.0) THEN
20767 IR=1
20768 IL=0
20769 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
20770 IR=1
20771 IL=2
20772 ELSEIF(VINT(143).GT.0.2D0) THEN
20773 IR=1
20774 IL=0
20775 ELSEIF(VINT(144).GT.0.2D0) THEN
20776 IR=0
20777 IL=2
20778 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
20779 IR=1
20780 IL=0
20781 ELSE
20782 IR=0
20783 IL=2
20784 ENDIF
20785 IG=3-IR-IL
20786
20787C...E+-pL wanted for system to be modified.
20788 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
20789 PPB=VINT(1)
20790 PNB=VINT(1)
20791 ELSE
20792 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
20793 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
20794 ENDIF
20795
20796C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
20797 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
20798 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
20799 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
20800 DO 420 J=1,4
20801 PSYS(0,J)=0D0
20802 420 CONTINUE
20803 DO 450 I=MINT(84)+1,NS
20804 IF(K(I,1).GT.10) GOTO 450
20805 INCL=0
20806 IORIG=I
20807 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20808 IORIG=K(IORIG,3)
20809 IF(IORIG.GT.LPIN) GOTO 430
20810 IF(INCL.EQ.0) GOTO 450
20811 DO 440 J=1,4
20812 PSYS(0,J)=PSYS(0,J)+P(I,J)
20813 440 CONTINUE
20814 450 CONTINUE
20815 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20816 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
20817 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
20818 ENDIF
20819
20820C...Construct longitudinal boosts.
20821 DPMTB=PPB*PNB
20822 DPMTR=PMS(IR)
20823 DPMTL=PMS(IL)
20824 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
20825 IF(DSQLAM.LE.1D-6*DPMTB) THEN
20826 MINT(51)=1
20827 MINT(57)=MINT(57)+1
20828 RETURN
20829 ENDIF
20830 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
20831 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
20832 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
20833 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
20834 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
20835 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
20836 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
20837
20838C...Perform longitudinal boosts.
20839 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
20840 P(IS(1),3)=0D0
20841 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
20842 ELSEIF(IR.EQ.1) THEN
20843 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
20844 ELSEIF(IDISXQ.EQ.1) THEN
20845 DO 470 I=I1,NS
20846 INCL=0
20847 IORIG=I
20848 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20849 IORIG=K(IORIG,3)
20850 IF(IORIG.GT.LPIN) GOTO 460
20851 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
20852 470 CONTINUE
20853 ELSE
20854 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
20855 ENDIF
20856 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
20857 P(IS(2),3)=0D0
20858 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
20859 ELSEIF(IL.EQ.2) THEN
20860 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
20861 ELSEIF(IDISXQ.EQ.1) THEN
20862 DO 490 I=I1,NS
20863 INCL=0
20864 IORIG=I
20865 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20866 IORIG=K(IORIG,3)
20867 IF(IORIG.GT.LPIN) GOTO 480
20868 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
20869 490 CONTINUE
20870 ELSE
20871 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
20872 ENDIF
20873
20874C...Final check that energy-momentum conservation worked.
20875 PESUM=0D0
20876 PZSUM=0D0
20877 DO 500 I=MINT(84)+1,N
20878 IF(K(I,1).GT.10) GOTO 500
20879 PESUM=PESUM+P(I,4)
20880 PZSUM=PZSUM+P(I,3)
20881 500 CONTINUE
20882 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
20883 IF(PDEV.GT.1D-4*VINT(1)) THEN
20884 MINT(51)=1
20885 MINT(57)=MINT(57)+1
20886 RETURN
20887 ENDIF
20888
20889C...Calculate rotation and boost from overall CM frame to
20890C...hadronic CM frame in leptoproduction.
20891 MINT(91)=0
20892 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20893 MINT(91)=1
20894 LESD=1
20895 IF(MINT(42).EQ.1) LESD=2
20896 LPIN=MINT(83)+3-LESD
20897
20898C...Sum upp momenta of everything not lepton or photon to define boost.
20899 DO 510 J=1,4
20900 PSUM(J)=0D0
20901 510 CONTINUE
20902 DO 530 I=1,N
20903 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
20904 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
20905 IF(K(I,2).EQ.22) GOTO 530
20906 DO 520 J=1,4
20907 PSUM(J)=PSUM(J)+P(I,J)
20908 520 CONTINUE
20909 530 CONTINUE
20910 VINT(223)=-PSUM(1)/PSUM(4)
20911 VINT(224)=-PSUM(2)/PSUM(4)
20912 VINT(225)=-PSUM(3)/PSUM(4)
20913
20914C...Boost incoming hadron to hadronic CM frame to determine rotations.
20915 K(N+1,1)=1
20916 DO 540 J=1,5
20917 P(N+1,J)=P(LPIN,J)
20918 V(N+1,J)=V(LPIN,J)
20919 540 CONTINUE
20920 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
20921 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
20922 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
20923 IF(LESD.EQ.2) THEN
20924 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
20925 ELSE
20926 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
20927 ENDIF
20928 ENDIF
20929
20930 RETURN
20931 END
20932
20933C*********************************************************************
20934
20935C...PYMIGN
20936C...Initializes treatment of new multiple interactions scenario,
20937C...selects kinematics of hardest interaction if low-pT physics
20938C...included in run, and generates all non-hardest interactions.
20939
20940 SUBROUTINE PYMIGN(MMUL)
20941
20942C...Double precision and integer declarations.
20943 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20944 IMPLICIT INTEGER(I-N)
20945 INTEGER PYK,PYCHGE,PYCOMP
20946 EXTERNAL PYALPS
20947 DOUBLE PRECISION PYALPS
20948C...Commonblocks.
20949 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20950 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20951 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20952 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20953 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20954 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20955 COMMON/PYINT1/MINT(400),VINT(400)
20956 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20957 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20958 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20959 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20960 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20961 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20962 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20963 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20964 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
20965C...Local arrays and saved variables.
20966 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
20967 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
20968 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
20969 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
20970 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
20971
20972C...Initialization of multiple interaction treatment.
20973 IF(MMUL.EQ.1) THEN
20974 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
20975 ISUB=96
20976 MINT(1)=96
20977 VINT(63)=0D0
20978 VINT(64)=0D0
20979 VINT(143)=1D0
20980 VINT(144)=1D0
20981
20982C...Loop over phase space points: xT2 choice in 20 bins.
20983 100 SIGSUM=0D0
20984 DO 120 IXT2=1,20
20985 NMUL(IXT2)=MSTP(83)
20986 SIGM(IXT2)=0D0
20987 DO 110 ITRY=1,MSTP(83)
20988 RSCA=0.05D0*((21-IXT2)-PYR(0))
20989 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
20990 XT2=MAX(0.01D0*VINT(149),XT2)
20991 VINT(25)=XT2
20992
20993C...Choose tau and y*. Calculate cos(theta-hat).
20994 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20995 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20996 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20997 ELSE
20998 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20999 ENDIF
21000 VINT(21)=TAU
21001 CALL PYKLIM(2)
21002 RYST=PYR(0)
21003 MYST=1
21004 IF(RYST.GT.COEF(ISUB,8)) MYST=2
21005 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21006 CALL PYKMAP(2,MYST,PYR(0))
21007 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21008
21009C...Calculate differential cross-section.
21010 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
21011 CALL PYSIGH(NCHN,SIGS)
21012 SIGM(IXT2)=SIGM(IXT2)+SIGS
21013 110 CONTINUE
21014 SIGSUM=SIGSUM+SIGM(IXT2)
21015 120 CONTINUE
21016 SIGSUM=SIGSUM/(20D0*MSTP(83))
21017
21018C...Reject result if sigma(parton-parton) is smaller than hadronic one.
21019 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
21020 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
21021 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
21022 PARP(82)=0.9D0*PARP(82)
21023 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
21024 & VINT(2)
21025 GOTO 100
21026 ENDIF
21027 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
21028 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
21029
21030C...Start iteration to find k factor.
21031 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
21032 P83A=(1D0-PARP(83))**2
21033 P83B=2D0*PARP(83)*(1D0-PARP(83))
21034 P83C=PARP(83)**2
21035 CQ2I=1D0/PARP(84)**2
21036 CQ2R=2D0/(1D0+PARP(84)**2)
21037 SO=0.5D0
21038 XI=0D0
21039 YI=0D0
21040 XF=0D0
21041 YF=0D0
21042 XK=0.5D0
21043 IIT=0
21044 130 IF(IIT.EQ.0) THEN
21045 XK=2D0*XK
21046 ELSEIF(IIT.EQ.1) THEN
21047 XK=0.5D0*XK
21048 ELSE
21049 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
21050 ENDIF
21051
21052C...Evaluate overlap integrals. Find where to divide the b range.
21053 IF(MSTP(82).EQ.2) THEN
21054 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
21055 SOP=SP/PARU(1)
21056 ELSE
21057 IF(MSTP(82).EQ.3) THEN
21058 DELTAB=0.02D0
21059 ELSEIF(MSTP(82).EQ.4) THEN
21060 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
21061 ELSE
21062 POWIP=MAX(0.4D0,PARP(83))
21063 RPWIP=2D0/POWIP-1D0
21064 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
21065 SO=0D0
21066 ENDIF
21067 SP=0D0
21068 SOP=0D0
21069 BSP=0D0
21070 SOHIGH=0D0
21071 IBDIV=0
21072 B=-0.5D0*DELTAB
21073 140 B=B+DELTAB
21074 IF(MSTP(82).EQ.3) THEN
21075 OV=EXP(-B**2)/PARU(2)
21076 ELSEIF(MSTP(82).EQ.4) THEN
21077 OV=(P83A*EXP(-MIN(50D0,B**2))+
21078 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
21079 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
21080 ELSE
21081 OV=EXP(-B**POWIP)/PARU(2)
21082 SO=SO+PARU(2)*B*DELTAB*OV
21083 ENDIF
21084 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
21085 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
21086 SP=SP+PARU(2)*B*DELTAB*PACC
21087 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
21088 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
21089 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
21090 IBDIV=1
21091 BDIV=B+0.5D0*DELTAB
21092 ENDIF
21093 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
21094 ENDIF
21095 YK=PARU(1)*XK*SO/SP
21096
21097C...Continue iteration until convergence.
21098 IF(YK.LT.YKE) THEN
21099 XI=XK
21100 YI=YK
21101 IF(IIT.EQ.1) IIT=2
21102 ELSE
21103 XF=XK
21104 YF=YK
21105 IF(IIT.EQ.0) IIT=1
21106 ENDIF
21107 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
21108
21109C...Store some results for subsequent use.
21110 BAVG=BSP/SP
21111 VINT(145)=SIGSUM
21112 VINT(146)=SOP/SO
21113 VINT(147)=SOP/SP
21114 VNT145=VINT(145)
21115 VNT146=VINT(146)
21116 VNT147=VINT(147)
21117C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
21118 PIK=(VNT146/VNT147)*YKE
21119
21120C...Find relative weight for low and high impact parameter..
21121 PLOWB=PARU(1)*BDIV**2
21122 IF(MSTP(82).EQ.3) THEN
21123 PHIGHB=PIK*0.5*EXP(-BDIV**2)
21124 ELSEIF(MSTP(82).EQ.4) THEN
21125 S4A=P83A*EXP(-BDIV**2)
21126 S4B=P83B*EXP(-BDIV**2*CQ2R)
21127 S4C=P83C*EXP(-BDIV**2*CQ2I)
21128 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
21129 ELSEIF(PARP(83).GE.1.999D0) THEN
21130 PHIGHB=PIK*SOHIGH
21131 B2RPDV=BDIV**POWIP
21132 ELSE
21133 PHIGHB=PIK*SOHIGH
21134 B2RPDV=BDIV**POWIP
21135 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
21136 ENDIF
21137 PALLB=PLOWB+PHIGHB
21138
21139C...Initialize iteration in xT2 for hardest interaction.
21140 ELSEIF(MMUL.EQ.2) THEN
21141 VINT(145)=VNT145
21142 VINT(146)=VNT146
21143 VINT(147)=VNT147
21144 IF(MSTP(82).LE.0) THEN
21145 ELSEIF(MSTP(82).EQ.1) THEN
21146 XT2=1D0
21147 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
21148 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
21149 & VINT(317)/(VINT(318)*VINT(320))
21150 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
21151 ELSEIF(MSTP(82).EQ.2) THEN
21152 XT2=1D0
21153 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
21154 & VINT(149)*(1D0+VINT(149))
21155 ELSE
21156 XC2=4D0*CKIN(3)**2/VINT(2)
21157 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
21158 ENDIF
21159
21160C...Select impact parameter for hardest interaction.
21161 IF(MSTP(82).LE.2) RETURN
21162 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
21163C...Treatment in low b region.
21164 MINT(39)=1
21165 B=BDIV*SQRT(PYR(0))
21166 IF(MSTP(82).EQ.3) THEN
21167 OV=EXP(-B**2)/PARU(2)
21168 ELSEIF(MSTP(82).EQ.4) THEN
21169 OV=(P83A*EXP(-MIN(50D0,B**2))+
21170 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
21171 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
21172 ELSE
21173 OV=EXP(-B**POWIP)/PARU(2)
21174 ENDIF
21175 VINT(148)=OV/VNT147
21176 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
21177 XT2=1D0
21178 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
21179 & VINT(149)*(1D0+VINT(149))
21180 ELSE
21181C...Treatment in high b region.
21182 MINT(39)=2
21183 IF(MSTP(82).EQ.3) THEN
21184 B=SQRT(BDIV**2-LOG(PYR(0)))
21185 OV=EXP(-B**2)/PARU(2)
21186 ELSEIF(MSTP(82).EQ.4) THEN
21187 S4RNDM=PYR(0)*(S4A+S4B+S4C)
21188 IF(S4RNDM.LT.S4A) THEN
21189 B=SQRT(BDIV**2-LOG(PYR(0)))
21190 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
21191 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
21192 ELSE
21193 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
21194 ENDIF
21195 OV=(P83A*EXP(-MIN(50D0,B**2))+
21196 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
21197 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
21198 ELSEIF(PARP(83).GE.1.999D0) THEN
21199 144 B2RPW=B2RPDV-LOG(PYR(0))
21200 ACCIP=(B2RPW/B2RPDV)**RPWIP
21201 IF(ACCIP.LT.PYR(0)) GOTO 144
21202 OV=EXP(-B2RPW)/PARU(2)
21203 B=B2RPW**(1D0/POWIP)
21204 ELSE
21205 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
21206 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
21207 IF(ACCIP.LT.PYR(0)) GOTO 146
21208 OV=EXP(-B2RPW)/PARU(2)
21209 B=B2RPW**(1D0/POWIP)
21210 ENDIF
21211 VINT(148)=OV/VNT147
21212 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
21213 ENDIF
21214 IF(PACC.LT.PYR(0)) GOTO 142
21215 VINT(139)=B/BAVG
21216
21217 ELSEIF(MMUL.EQ.3) THEN
21218C...Low-pT or multiple interactions (first semihard interaction):
21219C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
21220C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
21221 ISUB=MINT(1)
21222 VINT(145)=VNT145
21223 VINT(146)=VNT146
21224 VINT(147)=VNT147
21225 IF(MSTP(82).LE.0) THEN
21226 XT2=0D0
21227 ELSEIF(MSTP(82).EQ.1) THEN
21228 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
21229C...Use with "Sudakov" for low b values when impact parameter dependence.
21230 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
21231 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
21232 & VINT(149)))).GT.PYR(0)) XT2=1D0
21233 IF(XT2.GE.1D0) THEN
21234 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
21235 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
21236 & VINT(149)
21237 ELSE
21238 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
21239 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
21240 & VINT(149)
21241 ENDIF
21242 XT2=MAX(0.01D0*VINT(149),XT2)
21243C...Use without "Sudakov" for high b values when impact parameter dep.
21244 ELSE
21245 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
21246 & PYR(0)*(1D0-XC2))-VINT(149)
21247 XT2=MAX(0.01D0*VINT(149),XT2)
21248 ENDIF
21249 VINT(25)=XT2
21250
21251C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
21252 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
21253 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
21254 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
21255 ISUB=95
21256 MINT(1)=ISUB
21257 VINT(21)=1D-12*VINT(149)
21258 VINT(22)=0D0
21259 VINT(23)=0D0
21260 VINT(25)=1D-12*VINT(149)
21261
21262 ELSE
21263C...Multiple interactions (first semihard interaction).
21264C...Choose tau and y*. Calculate cos(theta-hat).
21265 IF(PYR(0).LE.COEF(ISUB,1)) THEN
21266 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
21267 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
21268 ELSE
21269 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
21270 ENDIF
21271 VINT(21)=TAU
21272 CALL PYKLIM(2)
21273 RYST=PYR(0)
21274 MYST=1
21275 IF(RYST.GT.COEF(ISUB,8)) MYST=2
21276 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21277 CALL PYKMAP(2,MYST,PYR(0))
21278 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21279 ENDIF
21280 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
21281
21282C...Store results of cross-section calculation.
21283 ELSEIF(MMUL.EQ.4) THEN
21284 ISUB=MINT(1)
21285 VINT(145)=VNT145
21286 VINT(146)=VNT146
21287 VINT(147)=VNT147
21288 XTS=VINT(25)
21289 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
21290 IF(ISET(ISUB).EQ.2)
21291 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
21292 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
21293 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
21294 & (XTS+VINT(149))))
21295 IRBIN=INT(1D0+20D0*RBIN)
21296 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
21297 NMUL(IRBIN)=NMUL(IRBIN)+1
21298 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
21299 ENDIF
21300
21301C...Choose impact parameter if not already done.
21302 ELSEIF(MMUL.EQ.5) THEN
21303 ISUB=MINT(1)
21304 VINT(145)=VNT145
21305 VINT(146)=VNT146
21306 VINT(147)=VNT147
21307 150 IF(MINT(39).GT.0) THEN
21308 ELSEIF(MSTP(82).EQ.3) THEN
21309 EXPB2=PYR(0)
21310 B2=-LOG(PYR(0))
21311 VINT(148)=EXPB2/(PARU(2)*VNT147)
21312 VINT(139)=SQRT(B2)/BAVG
21313 ELSEIF(MSTP(82).EQ.4) THEN
21314 RTYPE=PYR(0)
21315 IF(RTYPE.LT.P83A) THEN
21316 B2=-LOG(PYR(0))
21317 ELSEIF(RTYPE.LT.P83A+P83B) THEN
21318 B2=-LOG(PYR(0))/CQ2R
21319 ELSE
21320 B2=-LOG(PYR(0))/CQ2I
21321 ENDIF
21322 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
21323 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
21324 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
21325 VINT(139)=SQRT(B2)/BAVG
21326 ELSEIF(PARP(83).GE.1.999D0) THEN
21327 POWIP=MAX(2D0,PARP(83))
21328 RPWIP=2D0/POWIP-1D0
21329 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
21330 160 IF(PYR(0).LT.PROB1) THEN
21331 B2RPW=PYR(0)**(0.5D0*POWIP)
21332 ACCIP=EXP(-B2RPW)
21333 ELSE
21334 B2RPW=1D0-LOG(PYR(0))
21335 ACCIP=B2RPW**RPWIP
21336 ENDIF
21337 IF(ACCIP.LT.PYR(0)) GOTO 160
21338 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
21339 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
21340 ELSE
21341 POWIP=MAX(0.4D0,PARP(83))
21342 RPWIP=2D0/POWIP-1D0
21343 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
21344 170 IF(PYR(0).LT.PROB1) THEN
21345 B2RPW=2D0*RPWIP*PYR(0)
21346 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
21347 ELSE
21348 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
21349 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
21350 ENDIF
21351 IF(ACCIP.LT .PYR(0)) GOTO 170
21352 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
21353 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
21354 ENDIF
21355
21356C...Multiple interactions (variable impact parameter) : reject with
21357C...probability exp(-overlap*cross-section above pT/normalization).
21358C...Does not apply to low-b region, where "Sudakov" already included.
21359 VINT(150)=1D0
21360 IF(MINT(39).NE.1) THEN
21361 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
21362 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
21363 DO 180 IBIN=IRBIN+1,20
21364 RNCOR=RNCOR+NMUL(IBIN)
21365 SIGCOR=SIGCOR+SIGM(IBIN)
21366 180 CONTINUE
21367 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
21368 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
21369 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
21370 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
21371 ENDIF
21372 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
21373 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
21374 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
21375 IF(VINT(150).LT.PYR(0)) GOTO 150
21376 VINT(150)=1D0
21377 ENDIF
21378
21379C...Generate additional multiple semihard interactions.
21380 ELSEIF(MMUL.EQ.6) THEN
21381
21382C...Save data for hardest initeraction, to be restored.
21383 ISUBSV=MINT(1)
21384 VINT(145)=VNT145
21385 VINT(146)=VNT146
21386 VINT(147)=VNT147
21387 M13SV=MINT(13)
21388 M14SV=MINT(14)
21389 M15SV=MINT(15)
21390 M16SV=MINT(16)
21391 M21SV=MINT(21)
21392 M22SV=MINT(22)
21393 DO 190 J=11,80
21394 VINTSV(J)=VINT(J)
21395 190 CONTINUE
21396 V141SV=VINT(141)
21397 V142SV=VINT(142)
21398
21399C...Store data on hardest interaction.
21400 XMI(1,1)=VINT(141)
21401 XMI(2,1)=VINT(142)
21402 PT2MI(1)=VINT(54)
21403 IMISEP(0)=MINT(84)
21404 IMISEP(1)=N
21405
21406C...Change process to generate; sum of x values so far.
21407 ISUB=96
21408 MINT(1)=96
21409 VINT(143)=1D0-VINT(141)
21410 VINT(144)=1D0-VINT(142)
21411 VINT(151)=0D0
21412 VINT(152)=0D0
21413
21414C...Initialize factors for PDF reshaping.
21415 DO 230 JS=1,2
21416 KFBEAM=MINT(10+JS)
21417 KFABM=IABS(KFBEAM)
21418 KFSBM=ISIGN(1,KFBEAM)
21419
21420C...Zero flavour content of incoming beam particle.
21421 KFIVAL(JS,1)=0
21422 KFIVAL(JS,2)=0
21423 KFIVAL(JS,3)=0
21424C...Flavour content of baryon.
21425 IF(KFABM.GT.1000) THEN
21426 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
21427 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
21428 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
21429C...Flavour content of pi+-, K+-.
21430 ELSEIF(KFABM.EQ.211) THEN
21431 KFIVAL(JS,1)=KFSBM*2
21432 KFIVAL(JS,2)=-KFSBM
21433 ELSEIF(KFABM.EQ.321) THEN
21434 KFIVAL(JS,1)=-KFSBM*3
21435 KFIVAL(JS,2)=KFSBM*2
21436C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
21437 ENDIF
21438
21439C...Zero initial valence and companion content.
21440 DO 200 IFL=-6,6
21441 NVC(JS,IFL)=0
21442 200 CONTINUE
21443
21444C...Initiate listing of all incoming partons from two sides.
21445 NMI(JS)=0
21446 DO 210 I=MINT(84)+1,N
21447 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
21448 IMI(JS,1,1)=I
21449 IMI(JS,1,2)=0
21450 ENDIF
21451 210 CONTINUE
21452
21453C...Decide whether quarks in hard scattering were valence or sea.
21454 IFL=K(IMI(JS,1,1),2)
21455 IF (IABS(IFL).GT.6) GOTO 230
21456
21457C...Get PDFs at X and Q2 of the parton shower initiator for the
21458C...hard scattering.
21459 X=VINT(140+JS)
21460 IF(MSTP(61).GE.1) THEN
21461 Q2=PARP(62)**2
21462 ELSE
21463 Q2=VINT(54)
21464 ENDIF
21465C...Note: XPSVC = x*pdf.
21466 MINT(30)=JS
21467C.... ALICE
21468C.... Store side in MINT(124)
21469 MINT(124) = JS
21470C....
21471 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
21472 SEA=XPSVC(IFL,-1)
21473 VAL=XPSVC(IFL,0)
21474
21475C...Decide (Extra factor x cancels in the division).
21476 RVCS=PYR(0)*(SEA+VAL)
21477 IVNOW=1
21478 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
21479C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21480 IVNOW=0
21481 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
21482 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
21483 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
21484 IF(KFIVAL(JS,1).EQ.0) THEN
21485 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
21486 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
21487 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
21488 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
21489 ENDIF
21490 IF(IVNOW.EQ.0) GOTO 220
21491C...Mark valence.
21492 IMI(JS,1,2)=0
21493C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21494 IF(KFIVAL(JS,1).EQ.0) THEN
21495 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21496 KFIVAL(JS,1)=IFL
21497 KFIVAL(JS,2)=-IFL
21498 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21499 KFIVAL(JS,1)=IFL
21500 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21501 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21502 ENDIF
21503 ENDIF
21504
21505C...If sea, add opposite sign companion parton. Store X and I.
21506 ELSE
21507 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21508 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21509C...Set pointer to companion
21510 IMI(JS,1,2)=-NVC(JS,-IFL)
21511 ENDIF
21512 230 CONTINUE
21513
21514C...Update counter number of multiple interactions.
21515 NMI(1)=1
21516 NMI(2)=1
21517
21518C...Set up starting values for iteration in xT2.
21519 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
21520 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
21521 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
21522 & ISUBSV.NE.96)) THEN
21523 XT2=(1D0-VINT(141))*(1D0-VINT(142))
21524 ELSE
21525 XT2=VINT(25)
21526 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
21527 IF(ISET(ISUBSV).EQ.2)
21528 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
21529 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
21530 ENDIF
21531 IF(MSTP(82).LE.1) THEN
21532 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
21533 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
21534 & VINT(317)/(VINT(318)*VINT(320))
21535 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
21536 ELSE
21537 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
21538 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
21539 ENDIF
21540 VINT(63)=0D0
21541 VINT(64)=0D0
21542
21543C...Iterate downwards in xT2.
21544 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
21545 XT2=0D0
21546 GOTO 440
21547 ELSEIF(MSTP(82).LE.1) THEN
21548 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
21549 IF(XT2.LT.VINT(149)) GOTO 440
21550 ELSE
21551 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
21552 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
21553 & LOG(PYR(0)))-VINT(149)
21554 IF(XT2.LE.0D0) GOTO 440
21555 XT2=MAX(0.01D0*VINT(149),XT2)
21556 ENDIF
21557 VINT(25)=XT2
21558
21559C...Choose tau and y*. Calculate cos(theta-hat).
21560 IF(PYR(0).LE.COEF(ISUB,1)) THEN
21561 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
21562 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
21563 ELSE
21564 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
21565 ENDIF
21566 VINT(21)=TAU
21567C...New: require shat > 1.
21568 IF(TAU*VINT(2).LT.1D0) GOTO 240
21569 CALL PYKLIM(2)
21570 RYST=PYR(0)
21571 MYST=1
21572 IF(RYST.GT.COEF(ISUB,8)) MYST=2
21573 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21574 CALL PYKMAP(2,MYST,PYR(0))
21575 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21576
21577C...Check that x not used up. Accept or reject kinematical variables.
21578 X1M=SQRT(TAU)*EXP(VINT(22))
21579 X2M=SQRT(TAU)*EXP(-VINT(22))
21580 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
21581 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
21582 CALL PYSIGH(NCHN,SIGS)
21583 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
21584 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
21585 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
21586
21587C...Reset K, P and V vectors.
21588 DO 260 I=N+1,N+4
21589 DO 250 J=1,5
21590 K(I,J)=0
21591 P(I,J)=0D0
21592 V(I,J)=0D0
21593 250 CONTINUE
21594 260 CONTINUE
21595 PT=0.5D0*VINT(1)*SQRT(XT2)
21596
21597C...Choose flavour of reacting partons (and subprocess).
21598 RSIGS=SIGS*PYR(0)
21599 DO 270 ICHN=1,NCHN
21600 KFL1=ISIG(ICHN,1)
21601 KFL2=ISIG(ICHN,2)
21602 ICONMI=ISIG(ICHN,3)
21603 RSIGS=RSIGS-SIGH(ICHN)
21604 IF(RSIGS.LE.0D0) GOTO 280
21605 270 CONTINUE
21606
21607C...Reassign to appropriate process codes.
21608 280 ISUBMI=ICONMI/10
21609 ICONMI=MOD(ICONMI,10)
21610
21611C...Choose new quark flavour for annihilation graphs
21612 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
21613 SH=TAU*VINT(2)
21614 CALL PYWIDT(21,SH,WDTP,WDTE)
21615 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
21616 DO 300 I=1,MDCY(21,3)
21617 KFLF=KFDP(I+MDCY(21,2)-1,1)
21618 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
21619 IF(RKFL.LE.0D0) GOTO 310
21620 300 CONTINUE
21621 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
21622 IF(KFLF.GE.4) GOTO 290
21623 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
21624 KFLF=4
21625 ICONMI=ICONMI-2
21626 ELSEIF(ISUBMI.EQ.53) THEN
21627 KFLF=5
21628 ICONMI=ICONMI-4
21629 ENDIF
21630 ENDIF
21631
21632C...Final state flavours and colour flow: default values
21633 JS=1
21634 KFL3=KFL1
21635 KFL4=KFL2
21636 KCC=20
21637 KCS=ISIGN(1,KFL1)
21638
21639 IF(ISUBMI.EQ.11) THEN
21640C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
21641 KCC=ICONMI
21642 IF(KFL1*KFL2.LT.0) KCC=KCC+2
21643
21644 ELSEIF(ISUBMI.EQ.12) THEN
21645C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
21646 KFL3=ISIGN(KFLF,KFL1)
21647 KFL4=-KFL3
21648 KCC=4
21649
21650 ELSEIF(ISUBMI.EQ.13) THEN
21651C...f + fbar -> g + g; th arbitrary
21652 KFL3=21
21653 KFL4=21
21654 KCC=ICONMI+4
21655
21656 ELSEIF(ISUBMI.EQ.28) THEN
21657C...f + g -> f + g; th = (p(f)-p(f))**2
21658 IF(KFL1.EQ.21) JS=2
21659 KCC=ICONMI+6
21660 IF(KFL1.EQ.21) KCC=KCC+2
21661 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
21662 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
21663
21664 ELSEIF(ISUBMI.EQ.53) THEN
21665C...g + g -> f + fbar; th arbitrary
21666 KCS=(-1)**INT(1.5D0+PYR(0))
21667 KFL3=ISIGN(KFLF,KCS)
21668 KFL4=-KFL3
21669 KCC=ICONMI+10
21670
21671 ELSEIF(ISUBMI.EQ.68) THEN
21672C...g + g -> g + g; th arbitrary
21673 KCC=ICONMI+12
21674 KCS=(-1)**INT(1.5D0+PYR(0))
21675 ENDIF
21676
21677C...Store flavours of scattering.
21678 MINT(13)=KFL1
21679 MINT(14)=KFL2
21680 MINT(15)=KFL1
21681 MINT(16)=KFL2
21682 MINT(21)=KFL3
21683 MINT(22)=KFL4
21684
21685C...Set flavours and mothers of scattering partons.
21686 K(N+1,1)=14
21687 K(N+2,1)=14
21688 K(N+3,1)=3
21689 K(N+4,1)=3
21690 K(N+1,2)=KFL1
21691 K(N+2,2)=KFL2
21692 K(N+3,2)=KFL3
21693 K(N+4,2)=KFL4
21694 K(N+1,3)=MINT(83)+1
21695 K(N+2,3)=MINT(83)+2
21696 K(N+3,3)=N+1
21697 K(N+4,3)=N+2
21698
21699C...Store colour connection indices.
21700 DO 320 J=1,2
21701 JC=J
21702 IF(KCS.EQ.-1) JC=3-J
21703 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
21704 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
21705 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
21706 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
21707 320 CONTINUE
21708
21709C...Store incoming and outgoing partons in their CM-frame.
21710 SHR=SQRT(TAU)*VINT(1)
21711 P(N+1,3)=0.5D0*SHR
21712 P(N+1,4)=0.5D0*SHR
21713 P(N+2,3)=-0.5D0*SHR
21714 P(N+2,4)=0.5D0*SHR
21715 P(N+3,5)=PYMASS(K(N+3,2))
21716 P(N+4,5)=PYMASS(K(N+4,2))
21717 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
21718 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
21719 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
21720 P(N+4,4)=SHR-P(N+3,4)
21721 P(N+4,3)=-P(N+3,3)
21722
21723C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
21724 PHI=PARU(2)*PYR(0)
21725 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
21726
21727C...Set up default values before showers.
21728 MINT(31)=MINT(31)+1
21729 IPU1=N+1
21730 IPU2=N+2
21731 IPU3=N+3
21732 IPU4=N+4
21733 VINT(141)=VINT(41)
21734 VINT(142)=VINT(42)
21735 N=N+4
21736
21737C...Showering of initial state partons (optional).
21738C...Note: no showering of final state partons here; it comes later.
21739 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21740 MINT(51)=0
21741 ALAMSV=PARJ(81)
21742 PARJ(81)=PARP(72)
21743 NSAV=N
21744 DO 340 I=1,4
21745 DO 330 J=1,5
21746 KSAV(I,J)=K(N-4+I,J)
21747 PSAV(I,J)=P(N-4+I,J)
21748 330 CONTINUE
21749 340 CONTINUE
21750 CALL PYSSPA(IPU1,IPU2)
21751 PARJ(81)=ALAMSV
21752C...If shower failed then restore to situation before shower.
21753 IF(MINT(51).GE.1) THEN
21754 N=NSAV
21755 DO 360 I=1,4
21756 DO 350 J=1,5
21757 K(N-4+I,J)=KSAV(I,J)
21758 P(N-4+I,J)=PSAV(I,J)
21759 350 CONTINUE
21760 360 CONTINUE
21761 IPU1=N-3
21762 IPU2=N-2
21763 VINT(141)=VINT(41)
21764 VINT(142)=VINT(42)
21765 ENDIF
21766 ENDIF
21767
21768C...Keep track of loose colour ends and information on scattering.
21769 370 IMI(1,MINT(31),1)=IPU1
21770 IMI(2,MINT(31),1)=IPU2
21771 IMI(1,MINT(31),2)=0
21772 IMI(2,MINT(31),2)=0
21773 XMI(1,MINT(31))=VINT(141)
21774 XMI(2,MINT(31))=VINT(142)
21775 PT2MI(MINT(31))=VINT(54)
21776 IMISEP(MINT(31))=N
21777
21778C...Decide whether quarks in last scattering were valence, companion or
21779C...sea.
21780 DO 430 JS=1,2
21781 KFBEAM=MINT(10+JS)
21782 KFSBM=ISIGN(1,MINT(10+JS))
21783 IFL=K(IMI(JS,MINT(31),1),2)
21784 IMI(JS,MINT(31),2)=0
21785 IF (IABS(IFL).GT.6) GOTO 430
21786
21787C...Get PDFs at X and Q2 of the parton shower initiator for the
21788C...last scattering. At this point VINT(143:144) do not yet
21789C...include the scattered x values VINT(141:142).
21790 X=VINT(140+JS)/VINT(142+JS)
21791 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21792 Q2=PARP(62)**2
21793 ELSE
21794 Q2=VINT(54)
21795 ENDIF
21796C...Note: XPSVC = x*pdf.
21797 MINT(30)=JS
21798C.... ALICE
21799C.... Store side in MINT(124)
21800 MINT(124) = JS
21801C....
21802 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
21803 SEA=XPSVC(IFL,-1)
21804 VAL=XPSVC(IFL,0)
21805 CMP=0D0
21806 DO 380 IVC=1,NVC(JS,IFL)
21807 CMP=CMP+XPSVC(IFL,IVC)
21808 380 CONTINUE
21809
21810C...Decide (Extra factor x cancels in the dvision).
21811 RVCS=PYR(0)*(SEA+VAL+CMP)
21812 IVNOW=1
21813 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
21814C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21815 IVNOW=0
21816 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
21817 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
21818 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
21819 IF(KFIVAL(JS,1).EQ.0) THEN
21820 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
21821 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
21822 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
21823 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
21824 ELSE
21825 DO 400 I1=1,NMI(JS)
21826 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
21827 & IVNOW=IVNOW-1
21828 400 CONTINUE
21829 ENDIF
21830 IF(IVNOW.EQ.0) GOTO 390
21831C...Mark valence.
21832 IMI(JS,MINT(31),2)=0
21833C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21834 IF(KFIVAL(JS,1).EQ.0) THEN
21835 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21836 KFIVAL(JS,1)=IFL
21837 KFIVAL(JS,2)=-IFL
21838 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21839 KFIVAL(JS,1)=IFL
21840 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21841 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21842 ENDIF
21843 ENDIF
21844
21845 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
21846C...If sea, add opposite sign companion parton. Store X and I.
21847 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21848 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21849C...Set pointer to companion
21850 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
21851 ELSE
21852C...If companion, decide which one.
21853 CMPSUM=VAL+SEA
21854 ISEL=0
21855 410 ISEL=ISEL+1
21856 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
21857 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
21858C...Find original sea (anti-)quark:
21859 IASSOC=0
21860 DO 420 I1=1,NMI(JS)
21861 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
21862 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
21863 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
21864 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
21865 ENDIF
21866 420 CONTINUE
21867C...Change X to what associated companion had, so that the correct
21868C...amount of momentum can be subtracted from the companion sum below.
21869 X=XASSOC(JS,IFL,ISEL)
21870C...Mark companion read.
21871 XASSOC(JS,IFL,ISEL)=0D0
21872 ENDIF
21873 430 CONTINUE
21874
21875C...Global statistics.
21876 MINT(351)=MINT(351)+1
21877 VINT(351)=VINT(351)+PT
21878 IF (MINT(351).EQ.1) VINT(356)=PT
21879
21880C...Update remaining energy and other counters.
21881 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
21882 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
21883 MINT(51)=1
21884 RETURN
21885 ENDIF
21886 NMI(1)=NMI(1)+1
21887 NMI(2)=NMI(2)+1
21888 VINT(151)=VINT(151)+VINT(41)
21889 VINT(152)=VINT(152)+VINT(42)
21890 VINT(143)=VINT(143)-VINT(141)
21891 VINT(144)=VINT(144)-VINT(142)
21892
21893C...Iterate, with more interactions allowed.
21894 IF(MINT(31).LT.240) GOTO 240
21895 440 CONTINUE
21896
21897C...Restore saved quantities for hardest interaction.
21898 MINT(1)=ISUBSV
21899 MINT(13)=M13SV
21900 MINT(14)=M14SV
21901 MINT(15)=M15SV
21902 MINT(16)=M16SV
21903 MINT(21)=M21SV
21904 MINT(22)=M22SV
21905 DO 450 J=11,80
21906 VINT(J)=VINTSV(J)
21907 450 CONTINUE
21908 VINT(141)=V141SV
21909 VINT(142)=V142SV
21910
21911 ENDIF
21912
21913C...Format statements for printout.
21914 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
21915 &'actions for MSTP(82) =',I2,' ******')
21916 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21917 &D9.2,' mb: rejected')
21918 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21919 &D9.2,' mb: accepted')
21920
21921 RETURN
21922 END
21923
21924C*********************************************************************
21925
21926C...PYMIHK
21927C...Finds left-behind remnant flavour content and hooks up
21928C...the colour flow between the hard scattering and remnants
21929
21930 SUBROUTINE PYMIHK
21931
21932C...Double precision and integer declarations.
21933 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21934 IMPLICIT INTEGER(I-N)
21935 INTEGER PYK,PYCHGE,PYCOMP
21936C...The event record
21937 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21938C...Parameters
21939 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21940 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21941 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21942 COMMON/PYINT1/MINT(400),VINT(400)
21943C...The common block of dangling ends
21944 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
21945 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
21946 & XMI(2,240),PT2MI(240),IMISEP(0:240)
21947 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
21948C...Local variables
21949 PARAMETER (NERSIZ=4000)
21950 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
21951 & ,MACCPT
21952 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
21953 SAVE /PYCBLS/,/PYCTAG/
21954 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
21955 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
21956 DATA NERRPR/0/
21957 SAVE NERRPR
21958 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)
21959
21960C...Set up error checkers
21961 IBOOST=0
21962
21963C...Initialize colour arrays: MCO (Original) and MCT (New)
21964 DO 110 I=MINT(84)+1,NERSIZ
21965 DO 100 JC=1,2
21966 MCT(I,JC)=0
21967 MCO(I,JC)=0
21968 100 CONTINUE
21969C...Also zero colour tracing information, if existed.
21970 IF (I.LE.N) THEN
21971 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21972 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21973 ENDIF
21974 110 CONTINUE
21975
21976C...Initialize colour tag collapse arrays:
21977C...JCCO (Original) and JCCN (New).
21978 DO 130 MG=MINT(84)+1,NERSIZ
21979 DO 120 JC=1,2
21980 JCCO(MG,JC)=0
21981 JCCN(MG,JC)=0
21982 120 CONTINUE
21983 130 CONTINUE
21984
21985C...Zero gluon insertion array
21986 DO 150 IM=1,1000
21987 DO 140 J=1,3
21988 INSR(IM,J)=0
21989 140 CONTINUE
21990 150 CONTINUE
21991
21992C...Compute hard scattering system rapidities
21993 IF (MSTP(89).EQ.1) THEN
21994 DO 160 IM=1,240
21995 IF (IM.LE.MINT(31)) THEN
21996 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
21997 ELSE
21998C...Set (unsigned) rapidity = 100 for beam remnant systems.
21999 YMI(IM)=100D0
22000 ENDIF
22001 160 CONTINUE
22002 ENDIF
22003
22004C...Treat each side separately
22005 DO 290 JS=1,2
22006
22007C...Initialize side.
22008 NG(JS)=0
22009 JV=0
22010 KFS=ISIGN(1,MINT(10+JS))
22011
22012C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
22013 IF(KFIVAL(JS,1).EQ.0) THEN
22014 IF(MINT(10+JS).EQ.111) THEN
22015 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
22016 KFIVAL(JS,2)=-KFIVAL(JS,1)
22017 ELSEIF(MINT(10+JS).EQ.22) THEN
22018 PYRKF=PYR(0)
22019 KFIVAL(JS,1)=1
22020 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
22021 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
22022 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
22023 KFIVAL(JS,2)=-KFIVAL(JS,1)
22024 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
22025 IF(PYR(0).GT.0.5D0) THEN
22026 KFIVAL(JS,1)=1
22027 KFIVAL(JS,2)=-3
22028 ELSE
22029 KFIVAL(JS,1)=3
22030 KFIVAL(JS,2)=-1
22031 ENDIF
22032 ENDIF
22033 ENDIF
22034
22035C...Initialize beam remnant sea and valence content flavour by flavour.
22036 NVSUM(JS)=0
22037 NBRTOT(JS)=0
22038 DO 210 JFA=1,6
22039C...Count up original number of JFA valence quarks and antiquarks.
22040 NVALQ=0
22041 NVALQB=0
22042 NSEA=0
22043 DO 170 J=1,3
22044 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
22045 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
22046 170 CONTINUE
22047 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
22048C...Subtract kicked out valence and determine sea from flavour cons.
22049 DO 180 IM=1,NMI(JS)
22050 IFL = K(IMI(JS,IM,1),2)
22051 IFA = IABS(IFL)
22052 IFS = ISIGN(1,IFL)
22053 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
22054C...Subtract K.O. valence quark from remainder.
22055 NVALQ=NVALQ-1
22056 JV=NVSUM(JS)-NVALQ-NVALQB
22057 IV(JS,JV)=IMI(JS,IM,1)
22058 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
22059C...Subtract K.O. valence antiquark from remainder.
22060 NVALQB=NVALQB-1
22061 JV=NVSUM(JS)-NVALQ-NVALQB
22062 IV(JS,JV)=IMI(JS,IM,1)
22063 ELSEIF (IFA.EQ.JFA) THEN
22064C...Outside sea without companion: add opposite sea flavour inside.
22065 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
22066 ENDIF
22067 180 CONTINUE
22068C...Check if space left in PYJETS for additional BR flavours
22069 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
22070 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
22071 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
22072 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
22073 MINT(51)=1
22074 RETURN
22075 ENDIF
22076C...Add required val+sea content to beam remnant.
22077 IF (NFLSUM.GT.0) THEN
22078 DO 200 IA=1,NFLSUM
22079C...Insert beam remnant quark as p.t. symbolic parton in ER.
22080 N=N+1
22081 DO 190 IX=1,5
22082 K(N,IX)=0
22083 P(N,IX)=0D0
22084 V(N,IX)=0D0
22085 190 CONTINUE
22086 K(N,1)=3
22087 K(N,2)=ISIGN(JFA,NSEA)
22088 IF (IA.LE.NVALQ) K(N,2)=JFA
22089 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
22090 K(N,3)=MINT(83)+JS
22091C...Also update NMI, IMI, and IV arrays.
22092 NMI(JS)=NMI(JS)+1
22093 IMI(JS,NMI(JS),1)=N
22094 IMI(JS,NMI(JS),2)=-1
22095 IF (IA.LE.NVALQ+NVALQB) THEN
22096 IMI(JS,NMI(JS),2)=0
22097 JV=JV+1
22098 IV(JS,JV)=IMI(JS,NMI(JS),1)
22099 ENDIF
22100 200 CONTINUE
22101 ENDIF
22102 210 CONTINUE
22103
22104 IM=0
22105 220 IM=IM+1
22106 IF (IM.LE.NMI(JS)) THEN
22107 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
22108 NG(JS)=NG(JS)+1
22109C...Add fictitious parent gluons for companion pairs.
22110 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
22111C...Randomly assign companions to sea quarks which have none.
22112 IF (IMI(JS,IM,2).LT.0) THEN
22113 IMC=PYR(0)*NMI(JS)
22114 230 IMC=MOD(IMC,NMI(JS))+1
22115 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
22116 IF (IMI(JS,IMC,2).GE.0) GOTO 230
22117 IMI(JS, IM,2) = IMI(JS,IMC,1)
22118 IMI(JS,IMC,2) = IMI(JS, IM,1)
22119 ENDIF
22120C...Add fictitious parent gluon
22121 N=N+1
22122 DO 240 IX=1,5
22123 K(N,IX)=0
22124 P(N,IX)=0D0
22125 V(N,IX)=0D0
22126 240 CONTINUE
22127 K(N,1)=14
22128 K(N,2)=21
22129 K(N,3)=MINT(83)+JS
22130C...Set gluon (anti-)colour daughter pointers
22131 K(N,4)=IMI(JS, IM,1)
22132 K(N,5)=IMI(JS, IM,2)
22133C...Set quark (anti-)colour parent pointers
22134 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
22135 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
22136C...Add gluon to IMI
22137 NMI(JS)=NMI(JS)+1
22138 IMI(JS,NMI(JS),1)=N
22139 IMI(JS,NMI(JS),2)=0
22140 ENDIF
22141 GOTO 220
22142 ENDIF
22143
22144C...If incoming (anti-)baryon, insert inside (anti-)junction.
22145C...Set up initial v-v-j-v configuration. Otherwise set up
22146C...mesonic v-vbar configuration
22147 IF (IABS(MINT(10+JS)).GT.1000) THEN
22148C...Determine junction type (1: B=1 2: B=-1)
22149 ITJUNC(JS) = (3-KFS)/2
22150C...Insert junction.
22151 N=N+1
22152 DO 250 IX=1,5
22153 K(N,IX)=0
22154 P(N,IX)=0D0
22155 V(N,IX)=0D0
22156 250 CONTINUE
22157C...Set special junction codes:
22158 K(N,1)=42
22159 K(N,2)=88
22160C...Set parent to side.
22161 K(N,3)=MINT(83)+JS
22162 K(N,4)=ITJUNC(JS)*MSTU(5)
22163 K(N,5)=0
22164C...Connect valence quarks to junction.
22165 MOUT(JS)=0
22166 MANTI=ITJUNC(JS)-1
22167C...Set (anti)colour mother = junction.
22168 DO 260 JV=1,3
22169 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
22170 & +MSTU(5)*N
22171C...Keep track of partons adjacent to junction:
22172 JST(JS,JV)=IV(JS,JV)
22173 260 CONTINUE
22174 ELSE
22175C...Mesons: set up initial q-qbar topology
22176 ITJUNC(JS)=0
22177 IF (K(IV(JS,1),2).GT.0) THEN
22178 IQ=IV(JS,1)
22179 IQBAR=IV(JS,2)
22180 ELSE
22181 IQ=IV(JS,2)
22182 IQBAR=IV(JS,1)
22183 ENDIF
22184 IV(JS,3)=0
22185 JST(JS,1)=IQ
22186 JST(JS,2)=IQBAR
22187 JST(JS,3)=0
22188 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
22189 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
22190C...Special for mesons. Insert gluon if BR empty.
22191 IF (NBRTOT(JS).EQ.0) THEN
22192 N=N+1
22193 DO 270 IX=1,5
22194 K(N,IX)=0
22195 P(N,IX)=0D0
22196 V(N,IX)=0D0
22197 270 CONTINUE
22198 K(N,1)=3
22199 K(N,2)=21
22200 K(N,3)=MINT(83)+JS
22201 K(N,4)=0
22202 K(N,5)=0
22203 NBRTOT(JS)=1
22204 NG(JS)=NG(JS)+1
22205C...Add gluon to IMI
22206 NMI(JS)=NMI(JS)+1
22207 IMI(JS,NMI(JS),1)=N
22208 IMI(JS,NMI(JS),2)=0
22209 ENDIF
22210 MOUT(JS)=0
22211 ENDIF
22212
22213C...Count up number of valence quarks outside BR.
22214 DO 280 JV=1,3
22215 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
22216 & MOUT(JS)=MOUT(JS)+1
22217 280 CONTINUE
22218
22219 290 CONTINUE
22220
22221C...Now both sides have been prepared in an initial vvjv (baryonic) or
22222C...v(g)vbar (mesonic) configuration.
22223
22224C...Create colour line tags starting from initiators.
22225 NCT=0
22226 DO 320 IM=1,MINT(31)
22227C...Consider each side in turn.
22228 DO 310 JS=1,2
22229 I1=IMI(JS,IM,1)
22230 I2=IMI(3-JS,IM,1)
22231 DO 300 JCS=4,5
22232 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
22233 & GOTO 300
22234 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
22235
22236 KCS=JCS
22237 CALL PYCTTR(I1,KCS,I2)
22238 IF(MINT(51).NE.0) RETURN
22239
22240 300 CONTINUE
22241 310 CONTINUE
22242 320 CONTINUE
22243
22244 DO 340 JS=1,2
22245C...Create colour tags for beam remnant partons.
22246 DO 330 IM=MINT(31)+1,NMI(JS)
22247 IP=IMI(JS,IM,1)
22248 IF (K(IP,2).NE.21) THEN
22249 JC=(3-ISIGN(1,K(IP,2)))/2
22250 IF (MCT(IP,JC).EQ.0) THEN
22251 NCT=NCT+1
22252 MCT(IP,JC)=NCT
22253 ENDIF
22254 ELSE
22255C...Gluons
22256 ICD=K(IP,4)
22257 IAD=K(IP,5)
22258 IF (ICD.NE.0) THEN
22259C...Fictituous gluons just inherit from their quark daughters.
22260 ICC=MCT(ICD,1)
22261 IAC=MCT(IAD,2)
22262 ELSE
22263C...Real beam remnant gluons get their own colours
22264 ICC=NCT+1
22265 IAC=NCT+2
22266 NCT=NCT+2
22267 ENDIF
22268 MCT(IP,1)=ICC
22269 MCT(IP,2)=IAC
22270 ENDIF
22271 330 CONTINUE
22272 340 CONTINUE
22273
22274C...Create colour tags for colour lines which are detached from the
22275C...initial state.
22276
22277 DO 360 MQGST=1,2
22278 DO 350 I=MINT(84)+1,N
22279
22280C...Look for coloured string endpoint, or (later) leftover gluon.
22281 IF (K(I,1).NE.3) GOTO 350
22282 KC=PYCOMP(K(I,2))
22283 IF(KC.EQ.0) GOTO 350
22284 KQ=KCHG(KC,2)
22285 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
22286
22287C...Pick up loose string end with no previous tag.
22288 KCS=4
22289 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
22290 IF(MCT(I,KCS-3).NE.0) GOTO 350
22291
22292 CALL PYCTTR(I,KCS,I)
22293 IF(MINT(51).NE.0) RETURN
22294
22295 350 CONTINUE
22296 360 CONTINUE
22297
22298C...Store original colour tags
22299 DO 370 I=MINT(84)+1,N
22300 MCO(I,1)=MCT(I,1)
22301 MCO(I,2)=MCT(I,2)
22302 370 CONTINUE
22303
22304C...Iteratively add gluons to already existing string pieces, enforcing
22305C...various possible orderings, and rejecting insertions that would give
22306C...rise to singlet gluons.
22307C...<kappa tau> normalization.
22308 RM0=1.5D0
22309 MRETRY=0
22310 PARP80=PARP(80)
22311
22312C...Set up simplified kinematics.
22313C...Boost hard interaction systems.
22314 IBOOST=IBOOST+1
22315 DO 380 IM=1,MINT(31)
22316 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22317 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
22318 380 CONTINUE
22319C...Assign preliminary beam remnant momenta.
22320 DO 390 I=MINT(53)+1,N
22321 JS=K(I,3)
22322 P(I,1)=0D0
22323 P(I,2)=0D0
22324 IF (K(I,2).NE.88) THEN
22325 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
22326 P(I,3)=P(I,4)
22327 IF (JS.EQ.2) P(I,3)=-P(I,3)
22328 ELSE
22329C...Junctions are wildcards for the present.
22330 P(I,4)=0D0
22331 P(I,3)=0D0
22332 ENDIF
22333 390 CONTINUE
22334
22335C...Reset colour processing information.
22336 400 DO 410 I=MINT(84)+1,N
22337 K(I,4)=MOD(K(I,4),MSTU(5)**2)
22338 K(I,5)=MOD(K(I,5),MSTU(5)**2)
22339 410 CONTINUE
22340
22341 NCC=0
22342 DO 430 JS=1,2
22343C...If meson, without gluon in BR, collapse q-qbar colour tags:
22344 IF (ITJUNC(JS).EQ.0) THEN
22345 JC1=MCT(JST(JS,1),1)
22346 JC2=MCT(JST(JS,2),2)
22347 NCC=NCC+1
22348 JCCO(NCC,1)=MAX(JC1,JC2)
22349 JCCO(NCC,2)=MIN(JC1,JC2)
22350C...Collapse colour tags in event record
22351 DO 420 I=MINT(84)+1,N
22352 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
22353 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
22354 420 CONTINUE
22355 ENDIF
22356 430 CONTINUE
22357
22358 440 JS=1
22359 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
22360 IF (NG(JS).GT.0) THEN
22361 NOPT=0
22362 RLOPT=1D9
22363C...Start at random gluon (optimizes speed for random attachments)
22364 NMGL=0
22365 IMGL=PYR(0)*NMI(JS)+1
22366 450 IMGL=MOD(IMGL,NMI(JS))+1
22367 NMGL=NMGL+1
22368C...Only loop through NMI once (with upper limit to save time)
22369 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
22370 IGL = IMI(JS,IMGL,1)
22371C...If not gluon or if already connected, try next.
22372 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
22373 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
22374C...Now loop through all possible insertions of this gluon.
22375 NMP1=0
22376 IMP1=PYR(0)*NMI(JS)+1
22377 460 IMP1=MOD(IMP1,NMI(JS))+1
22378 NMP1=NMP1+1
22379 IF (IMP1.EQ.IMGL) GOTO 460
22380C...Only loop through NMI once (with upper limit to save time).
22381 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
22382 IP1 = IMI(JS,IMP1,1)
22383C...Try both colour mother and colour anti-mother.
22384C...Randomly select which one to try first.
22385 NANTI=0
22386 MANTI=PYR(0)*2
22387 470 MANTI=MOD(MANTI+1,2)
22388 NANTI=NANTI+1
22389 IF (NANTI.LE.2) THEN
22390 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
22391C...Reject if no appropriate mother (or if mother is fictitious
22392C...parent gluon.)
22393 IF (IP2.LE.0) GOTO 470
22394 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
22395C...Also reject if this link has already been tried.
22396 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
22397 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
22398C...Set flag to indicate that this link has now been tried for this
22399C...gluon. IP2 may be junction, which has several mothers.
22400 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
22401 IF (K(IP2,2).NE.88) THEN
22402 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
22403 ENDIF
22404
22405C...JCG1: Original colour tag of gluon on IP1 side
22406C...JCG2: Original colour tag of gluon on IP2 side
22407C...JCP1: Original colour tag of IP1 on gluon side
22408C...JCP2: Original colour tag of IP2 on gluon side.
22409 JCG1=MCO(IGL,2-MANTI)
22410 JCG2=MCO(IGL,1+MANTI)
22411 JCP1=MCO(IP1,1+MANTI)
22412 JCP2=MCO(IP2,2-MANTI)
22413
22414 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
22415C...Reject gluon attachments that give rise to singlet gluons.
22416 IF (MACCPT.EQ.0) GOTO 470
22417
22418C...Update colours
22419 JCG1=MCT(IGL,2-MANTI)
22420 JCG2=MCT(IGL,1+MANTI)
22421 JCP1=MCT(IP1,1+MANTI)
22422 JCP2=MCT(IP2,2-MANTI)
22423
22424C...Select whether to accept this insertion
22425 IF (MSTP(89).EQ.0) THEN
22426C...Random insertions: no measure.
22427 RL=1D0
22428C...For random ordering, we want to suppress beam remnant breakups
22429C...already at this point.
22430 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
22431 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
22432 NMP1=0
22433 NMGL=0
22434 GOTO 470
22435 ENDIF
22436 ELSEIF (MSTP(89).EQ.1) THEN
22437C...Rapidity ordering:
22438C...YGL = Rapidity of gluon.
22439 YGL=YMI(IMGL)
22440C...If fictitious gluon
22441 IF (YGL.EQ.100D0) THEN
22442 YGL=(3-2*JS)*100D0
22443 IDA1=MOD(K(IGL,4),MSTU(5))
22444 IDA2=MOD(K(IGL,5),MSTU(5))
22445 DO 480 IMT=1,NMI(JS)
22446C...Select (arbitrarily) the most central daughter.
22447 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
22448 & THEN
22449 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
22450 ENDIF
22451 480 CONTINUE
22452 ENDIF
22453C...YP1 = Rapidity IP1
22454 YP1=YMI(IMP1)
22455C...If fictitious gluon
22456 IF (YP1.EQ.100D0) THEN
22457 YP1=(3-2*JS)*YP1
22458 IDA1=MOD(K(IP1,4),MSTU(5))
22459 IDA2=MOD(K(IP1,5),MSTU(5))
22460 DO 490 IMT=1,NMI(JS)
22461C...Select (arbitrarily) the most central daughter.
22462 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
22463 & THEN
22464 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
22465 ENDIF
22466 490 CONTINUE
22467 ENDIF
22468C...YP2 = Rapidity of mother system
22469 IF (K(IP2,2).NE.88) THEN
22470 DO 500 IMT=1,NMI(JS)
22471 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
22472 500 CONTINUE
22473C...If fictitious gluon
22474 IF (YP2.EQ.100D0) THEN
22475 YP2=(3-2*JS)*YP2
22476 IDA1=MOD(K(IP2,4),MSTU(5))
22477 IDA2=MOD(K(IP2,5),MSTU(5))
22478 DO 510 IMT=1,NMI(JS)
22479C...Select (arbitrarily) the most central daughter.
22480 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
22481 & ) THEN
22482 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
22483 ENDIF
22484 510 CONTINUE
22485 ENDIF
22486C...Assign (arbitrarily) 100D0 to junction also
22487 ELSE
22488 YP2=(3-2*JS)*100D0
22489 ENDIF
22490 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
22491 ELSEIF (MSTP(89).EQ.2) THEN
22492C...Lambda ordering:
22493C...Compute lambda measure for this insertion.
22494 RL=1D0
22495 DO 520 IST=1,6
22496 ISTR(IST)=0
22497 520 CONTINUE
22498C...If IP2 is junction, not caught below.
22499 IF (JCP2.EQ.0) THEN
22500 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
22501C...Anti-junction is colour endpoint et vv., always on JCG2.
22502 ISTR(5-ITJU)=IP2
22503 ENDIF
22504 DO 530 I=MINT(84)+1,N
22505 IF (K(I,1).LT.10) THEN
22506C...The new string pieces
22507 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
22508 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
22509 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
22510 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
22511 ENDIF
22512 530 CONTINUE
22513C...Also identify junctions as string endpoints.
22514 DO 540 I=MINT(84)+1,N
22515 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
22516 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
22517C...Find partons adjacent to junctions.
22518 IF (ICMO.GT.0.AND.ICMO.LE.N) THEN
22519 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
22520 & .EQ.0) ISTR(2) = ICMO
22521 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
22522 & .EQ.0) ISTR(4) = ICMO
22523 ENDIF
22524 IF (IAMO.GT.0.AND.IAMO.LE.N) THEN
22525 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
22526 & .EQ.0) ISTR(1) = IAMO
22527 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
22528 & .EQ.0) ISTR(3) = IAMO
22529 ENDIF
22530 540 CONTINUE
22531C...The old string piece
22532 ISTR(5)=ISTR(1+2*MANTI)
22533 ISTR(6)=ISTR(4-2*MANTI)
22534 IF (ISTR(1).EQ.0.OR.ISTR(2).EQ.0.OR.ISTR(3).EQ.0.OR.
22535 & ISTR(4).EQ.0.OR.ISTR(5).EQ.0.OR.ISTR(6).EQ.0) THEN
22536C...If one or more of the colour tags for this connection is/are still
22537C...dangling, skip this attempt for the time being.
22538 RL=1D6
22539 ELSE
22540 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
22541 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
22542 RL=LOG(RL)
22543 ENDIF
22544 ENDIF
22545C...Allow some breadth to speed things up.
22546 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
22547 NOPT=NOPT+1
22548 ELSEIF (RL.GT.RLOPT) THEN
22549 GOTO 470
22550 ELSE
22551 NOPT=1
22552 RLOPT=RL
22553 ENDIF
22554C...INSR(NOPT,1)=Gluon colour mother
22555C...INSR(NOPT,2)=Gluon
22556C...INSR(NOPT,3)=Gluon anticolour mother
22557 IF (NOPT.GT.1000) GOTO 470
22558 INSR(NOPT,1+2*MANTI)=IP2
22559 INSR(NOPT,2)=IGL
22560 INSR(NOPT,3-2*MANTI)=IP1
22561 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
22562 ENDIF
22563 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
22564 ENDIF
22565C...Reset link test information.
22566 DO 550 I=MINT(84)+1,N
22567 K(I,4)=MOD(K(I,4),MSTU(5)**2)
22568 K(I,5)=MOD(K(I,5),MSTU(5)**2)
22569 550 CONTINUE
22570 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
22571 ENDIF
22572C...Now we have a list of best gluon insertions, none of which cause
22573C...singlets to arise. If list is empty, try again a few times. Note:
22574C...this should never happen if we have a meson with a gluon inserted
22575C...in the beam remnant, since that breaks up the colour line.
22576 IF (NOPT.EQ.0) THEN
22577C...Abandon BR-g-BR suppression for retries. This is not serious, it
22578C...just means we happened to start with trying a bad sequence.
22579 PARP80=1D0
22580 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
22581 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
22582 MRETRY=MRETRY+1
22583 DO 590 JS=1,2
22584 IF (ITJUNC(JS).NE.0) THEN
22585 JST(JS,1)=IV(JS,1)
22586 JST(JS,2)=IV(JS,2)
22587 JST(JS,3)=IV(JS,3)
22588C...Reset valence quark parent pointers
22589 DO 560 I=MINT(53)+1,N
22590 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
22591 560 CONTINUE
22592 MANTI=ITJUNC(JS)-1
22593C...Set (anti)colour mother = junction.
22594 DO 570 JV=1,3
22595 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
22596 & +MSTU(5)*IJU
22597 570 CONTINUE
22598 ELSE
22599C...Same for mesons. JST unchanged, so needn't be restored.
22600 IQ=JST(JS,1)
22601 IQBAR=JST(JS,2)
22602 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
22603 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
22604 ENDIF
22605C...Also reset gluon parent pointers.
22606 NG(JS)=0
22607 DO 580 IM=1,NMI(JS)
22608 I=IMI(JS,IM,1)
22609 IF (K(I,2).EQ.21) THEN
22610 K(I,4)=MOD(K(I,4),MSTU(5))
22611 K(I,5)=MOD(K(I,5),MSTU(5))
22612 NG(JS)=NG(JS)+1
22613 ENDIF
22614 580 CONTINUE
22615 590 CONTINUE
22616C...Reset colour tags
22617 DO 600 I=MINT(84)+1,N
22618 MCT(I,1)=MCO(I,1)
22619 MCT(I,2)=MCO(I,2)
22620 600 CONTINUE
22621 GOTO 400
22622 ELSE
22623 IF(NERRPR.LT.5) THEN
22624 NERRPR=NERRPR+1
22625 CALL PYLIST(4)
22626 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
22627 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
22628 ENDIF
22629C...Kill event and start another.
22630 MINT(51)=1
22631 RETURN
22632 ENDIF
22633 ELSE
22634C...Select between insertions, suppressing insertions wholly in the BR.
22635 IIN=PYR(0)*NOPT+1
22636 610 IIN=MOD(IIN,NOPT)+1
22637 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
22638 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
22639 ENDIF
22640
22641C...Now we know which gluon to insert where. Colour tags in JCCO and
22642C...colour connection information should be updated, NG(JS) should be
22643C...counted down, and a new loop performed if there are still gluons
22644C...left on any side.
22645 ICM=INSR(IIN,1)
22646 IACM=INSR(IIN,3)
22647 IGL=INSR(IIN,2)
22648C...JCG : Original gluon colour tag
22649C...JCAG: Original gluon anticolour tag.
22650C...JCM : Original anticolour tag of gluon colour mother
22651C...JACM: Original colour tag of gluon anticolour mother
22652 JCG=MCO(IGL,1)
22653 JCM=MCO(ICM,2)
22654 JACG=MCO(IGL,2)
22655 JACM=MCO(IACM,1)
22656
22657 CALL PYMIHG(JACM,JACG,JCM,JCG)
22658 IF (MACCPT.EQ.0) THEN
22659 IF(NERRPR.LT.5) THEN
22660 NERRPR=NERRPR+1
22661 CALL PYLIST(4)
22662 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
22663 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
22664 ENDIF
22665C...Kill event and start another.
22666 MINT(51)=1
22667 RETURN
22668 ELSE
22669C...If everything went fine, store new JCCN in JCCO.
22670 NCC=NCC+1
22671 DO 620 ICC=1,NCC
22672 JCCO(ICC,1)=JCCN(ICC,1)
22673 JCCO(ICC,2)=JCCN(ICC,2)
22674 620 CONTINUE
22675 ENDIF
22676
22677C...One gluon attached is counted as equivalent to one end outside.
22678 MOUT(JS)=1
22679C...Set IGL colour mother = ICM.
22680 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
22681C...Set ICM anticolour mother = IGL colour.
22682 IF (K(ICM,2).NE.88) THEN
22683 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
22684 ELSE
22685C...If ICM is junction, just update JST array for now.
22686 DO 630 MSJ=1,3
22687 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
22688 630 CONTINUE
22689 ENDIF
22690C...Set IGL anticolour mother = IACM.
22691 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
22692C...Set IACM anticolour mother = IGL anticolour.
22693 IF (K(IACM,2).NE.88) THEN
22694 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
22695 ELSE
22696C...If IACM is junction, just update JST array for now.
22697 DO 640 MSJ=1,3
22698 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
22699 640 CONTINUE
22700 ENDIF
22701C...Count down # unconnected gluons.
22702 NG(JS)=NG(JS)-1
22703 ENDIF
22704 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
22705
22706 DO 840 JS=1,2
22707C...Collapse fictitious gluons.
22708 DO 670 IGL=MINT(53)+1,N
22709 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
22710 & K(IGL,1).EQ.14) THEN
22711 ICM=K(IGL,4)/MSTU(5)
22712 IAM=K(IGL,5)/MSTU(5)
22713 ICD=MOD(K(IGL,4),MSTU(5))
22714 IAD=MOD(K(IGL,5),MSTU(5))
22715C...Set gluon daughters pointing to gluon mothers
22716 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
22717 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
22718C...Set gluon mothers pointing to gluon daughters.
22719 IF (K(ICM,2).NE.88) THEN
22720 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
22721 ELSE
22722C...Special case: mother=junction. Just update JST array for now.
22723 DO 650 MSJ=1,3
22724 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
22725 650 CONTINUE
22726 ENDIF
22727 IF (K(IAM,2).NE.88) THEN
22728 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
22729 ELSE
22730 DO 660 MSJ=1,3
22731 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
22732 660 CONTINUE
22733 ENDIF
22734 ENDIF
22735 670 CONTINUE
22736
22737C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
22738 IM=NMI(JS)+1
22739 680 IM=IM-1
22740 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
22741 IF (IM.GT.MINT(31)) THEN
22742 NMI(JS)=NMI(JS)-1
22743 DO 690 IMR=IM,NMI(JS)
22744 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
22745 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
22746 690 CONTINUE
22747 GOTO 680
22748 ENDIF
22749
22750C...Finally, connect junction.
22751 IF (ITJUNC(JS).NE.0) THEN
22752 DO 700 I=MINT(53)+1,N
22753 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
22754 700 CONTINUE
22755C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
22756 NBRJQ =0
22757 NBRVQ =0
22758 DO 720 MSJ=1,3
22759 IDQ(MSJ)=0
22760C...Find jq with no glue inbetween inside beam remnant.
22761 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
22762 & THEN
22763 NBRJQ=NBRJQ+1
22764C...Set IDQ = -I if q non-valence and = +I if q valence.
22765 IDQ(NBRJQ)=-JST(JS,MSJ)
22766 DO 710 JV=1,3
22767 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
22768 IDQ(NBRJQ)=JST(JS,MSJ)
22769 NBRVQ=NBRVQ+1
22770 ENDIF
22771 710 CONTINUE
22772 ENDIF
22773 I12=MOD(MSJ+1,2)
22774 I45=5
22775 IF (MSJ.EQ.3) I45=4
22776 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
22777 720 CONTINUE
22778
22779C...Check if diquark can be formed.
22780 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
22781 & .GE.1)) THEN
22782C...If there is less than 2 valence quarks connected to junction
22783C...and MSTP(88)>1, use random non-valence quarks to fill up.
22784 IF (NBRVQ.LE.1) THEN
22785 NDIQ=NBRVQ
22786 730 JFLIP=NBRJQ*PYR(0)+1
22787 IF (IDQ(JFLIP).LT.0) THEN
22788 IDQ(JFLIP)=-IDQ(JFLIP)
22789 NDIQ=NDIQ+1
22790 ENDIF
22791 IF (NDIQ.LE.1) GOTO 730
22792 ENDIF
22793C...Place selected quarks first in IDQ, ordered in flavour.
22794 DO 740 JDQ=1,3
22795 IF (IDQ(JDQ).LE.0) THEN
22796 ITEMP1 = IDQ(JDQ)
22797 IDQ(JDQ)= IDQ(3)
22798 IDQ(3) = -ITEMP1
22799 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
22800 ITEMP1 = IDQ(1)
22801 IDQ(1) = IDQ(2)
22802 IDQ(2) = ITEMP1
22803 ENDIF
22804 ENDIF
22805 740 CONTINUE
22806C...Choose diquark spin.
22807 IF (NBRVQ.EQ.2) THEN
22808C...If the selected quarks are both valence, we may use SU(6) rules
22809C...to figure out which spin the diquark has, by a subdivision of the
22810C...original beam hadron into the selected diquark system plus a kicked
22811C...out quark, IKO.
22812 JKO=6
22813 DO 760 JDQ=1,2
22814 DO 750 JV=1,3
22815 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
22816 750 CONTINUE
22817 760 CONTINUE
22818 IKO=IV(JS,JKO)
22819 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
22820 ELSE
22821C...If one or more of the selected quarks are not valence, we cannot use
22822C...SU(6) subdivisions of the original beam hadron. Instead, with the
22823C...flavours of the diquark already selected, we assume for now
22824C...50:50 spin-1:spin-0 (where spin-0 possible).
22825 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
22826 IS=3
22827 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
22828 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
22829 KFDQ=KFDQ+ISIGN(IS,KFDQ)
22830 ENDIF
22831
22832C...Collapse diquark-j-quark system to baryon, if allowed and possible.
22833C...Note: third quark can per definition not also be valence,
22834C...therefore we can only do this if we are allowed to use sea quarks.
22835 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
22836 NTRY=0
22837 780 NTRY=NTRY+1
22838 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
22839 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
22840 GOTO 780
22841 ELSEIF(NTRY.GT.100) THEN
22842C...If no baryon can be found, give up and form diquark.
22843 IDQ(3)=0
22844 GOTO 770
22845 ELSE
22846C...Replace junction by baryon.
22847 K(IJU,1)=1
22848 K(IJU,2)=KFBAR
22849 K(IJU,3)=MINT(83)+JS
22850 K(IJU,4)=0
22851 K(IJU,5)=0
22852 P(IJU,5)=PYMASS(KFBAR)
22853 DO 790 MSJ=1,3
22854C...Prepare removal of participating quarks from ER.
22855 K(JST(JS,MSJ),1)=-1
22856 790 CONTINUE
22857 ENDIF
22858 ELSE
22859C...If collapse to baryon not possible or not allowed, replace junction
22860C...by diquark. This way, collapsed gluons that were pointing at the
22861C...junction will now point (correctly) at diquark.
22862 MANTI=ITJUNC(JS)-1
22863 K(IJU,1)=3
22864 K(IJU,2)=KFDQ
22865 K(IJU,3)=MINT(83)+JS
22866 K(IJU,4)=0
22867 K(IJU,5)=0
22868 DO 800 MSJ=1,3
22869 IP=JST(JS,MSJ)
22870 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
22871 K(IJU,4+MANTI)=0
22872 K(IJU,5-MANTI)=IP*MSTU(5)
22873 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
22874 & MSTU(5)*IJU
22875 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
22876 ELSE
22877C...Prepare removal of participating quarks from ER.
22878 K(IP,1)=-1
22879 ENDIF
22880 800 CONTINUE
22881 ENDIF
22882
22883C...Update so ER pointers to collapsed quarks
22884C...now go to collapsed object.
22885 DO 820 I=MINT(84)+1,N
22886 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
22887 & .K(I,1).GT.0) THEN
22888 DO 810 ISID=4,5
22889 IMO=K(I,ISID)/MSTU(5)
22890 IDA=MOD(K(I,ISID),MSTU(5))
22891 IF (IMO.GT.0) THEN
22892 IF (K(IMO,1).EQ.-1) IMO=IJU
22893 ENDIF
22894 IF (IDA.GT.0) THEN
22895 IF (K(IDA,1).EQ.-1) IDA=IJU
22896 ENDIF
22897 K(I,ISID)=IDA+MSTU(5)*IMO
22898 810 CONTINUE
22899 ENDIF
22900 820 CONTINUE
22901 ENDIF
22902 ENDIF
22903
22904C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
22905C...(this only happens for baryons, where we want to force the gluon
22906C...to sit next to the junction. Mesons handled above.)
22907 IF (NBRTOT(JS).EQ.0) THEN
22908 N=N+1
22909 DO 830 IX=1,5
22910 K(N,IX)=0
22911 P(N,IX)=0D0
22912 V(N,IX)=0D0
22913 830 CONTINUE
22914 IGL=N
22915 K(IGL,1)=3
22916 K(IGL,2)=21
22917 K(IGL,3)=MINT(83)+JS
22918 IF (ITJUNC(JS).NE.0) THEN
22919C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
22920 JLEG=PYR(0)*NVSUM(JS)+1
22921 I1=JST(JS,JLEG)
22922 JST(JS,JLEG)=IGL
22923 JCT=MCT(I1,ITJUNC(JS))
22924 MCT(IGL,3-ITJUNC(JS))=JCT
22925 NCT=NCT+1
22926 MCT(IGL,ITJUNC(JS))=NCT
22927 MANTI=ITJUNC(JS)-1
22928 ELSE
22929C...Meson. Should not happen.
22930 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
22931 IF(NERRPR.LT.5) THEN
22932 WRITE(MSTU(11),*) 'This should not have been possible!'
22933 CALL PYLIST(4)
22934 NERRPR=NERRPR+1
22935 ENDIF
22936 MINT(51)=1
22937 RETURN
22938 ENDIF
22939 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
22940 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
22941 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
22942 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
22943 IF (K(I2,2).NE.88) THEN
22944 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
22945 ELSE
22946 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
22947 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
22948 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
22949 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
22950 ELSE
22951 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
22952 ENDIF
22953 ENDIF
22954 ENDIF
22955 840 CONTINUE
22956
22957C...Remove collapsed quarks and junctions from ER and update IMI.
22958 CALL PYEDIT(11)
22959
22960C...Also update beam remnant part of IMI.
22961 NMI(1)=MINT(31)
22962 NMI(2)=MINT(31)
22963 DO 850 I=MINT(53)+1,N
22964 IF (K(I,1).LE.0) GOTO 850
22965C...Restore BR quark/diquark/baryon pointers in IMI.
22966 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
22967 JS=K(I,3)-MINT(83)
22968 NMI(JS)=NMI(JS)+1
22969 IMI(JS,NMI(JS),1)=I
22970 IMI(JS,NMI(JS),2)=0
22971 ENDIF
22972 850 CONTINUE
22973
22974C...Restore companion information from collapsed gluons.
22975 DO 870 I=MINT(53)+1,N
22976 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
22977 JS=K(I,3)-MINT(83)
22978 JCD=MOD(K(I,4),MSTU(5))
22979 JAD=MOD(K(I,5),MSTU(5))
22980 DO 860 IM=1,NMI(JS)
22981 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
22982 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
22983 860 CONTINUE
22984 IMI(JS,IMC,2)=IMI(JS,IMA,1)
22985 IMI(JS,IMA,2)=IMI(JS,IMC,1)
22986 ENDIF
22987 870 CONTINUE
22988
22989C...Renumber colour lines (since some have disappeared)
22990 JCT=0
22991 JCD=0
22992 880 JCT=JCT+1
22993 MFOUND=0
22994 I=MINT(84)
22995 890 I=I+1
22996 IF (I.EQ.N+1) THEN
22997 IF (MFOUND.EQ.0) JCD=JCD+1
22998 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
22999 MCT(I,1)=JCT-JCD
23000 MFOUND=1
23001 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
23002 MCT(I,2)=JCT-JCD
23003 MFOUND=1
23004 ENDIF
23005 IF (I.LE.N) GOTO 890
23006 IF (JCT.LT.NCT) GOTO 880
23007 NCT=JCT-JCD
23008
23009C...Reset hard interaction subsystems to their CM frames.
23010 IF (IBOOST.EQ.1) THEN
23011 DO 900 IM=1,MINT(31)
23012 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
23013 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
23014 900 CONTINUE
23015C...Zero beam remnant longitudinal momenta and energies
23016 DO 910 I=MINT(53)+1,N
23017 P(I,3)=0D0
23018 P(I,4)=0D0
23019 910 CONTINUE
23020 ELSE
23021 CALL PYERRM(9
23022 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
23023C...Kill event and start another.
23024 MINT(51)=1
23025 RETURN
23026 ENDIF
23027
23028 9999 RETURN
23029 END
23030C*********************************************************************
23031
23032C...PYCTTR
23033C...Adapted from PYPREP.
23034C...Assigns LHA1 colour tags to coloured partons based on
23035C...K(I,4) and K(I,5) colour connection record.
23036C...KCS negative signifies that a previous tracing should be continued.
23037C...(in case the tag to be continued is empty, the routine exits)
23038C...Starts at I and ends at I or IEND.
23039C...Special considerations for systems with junctions.
23040C...Special: if IEND=-1, means trace this parton to its color partner,
23041C... then exit. If no partner found, exit with 0.
23042
23043 SUBROUTINE PYCTTR(I,KCS,IEND)
23044C...Double precision and integer declarations.
23045 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23046 INTEGER PYK,PYCHGE,PYCOMP
23047C...Commonblocks.
23048 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23049 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23050 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23051 COMMON/PYINT1/MINT(400),VINT(400)
23052C...The common block of colour tags.
23053 COMMON/PYCTAG/NCT,MCT(4000,2)
23054 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
23055 DATA NERRPR/0/
23056 SAVE NERRPR
23057
23058C...Skip if parton not existing or does not have KCS
23059 IF (K(I,1).LE.0) GOTO 120
23060 KC=PYCOMP(K(I,2))
23061 IF (KC.EQ.0) GOTO 120
23062 KQ=KCHG(KC,2)
23063 IF (KQ.EQ.0) GOTO 120
23064 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
23065 & GOTO 120
23066
23067 IF (KCS.GT.0) THEN
23068 NCT=NCT+1
23069C...Set colour tag of first parton.
23070 MCT(I,KCS-3)=NCT
23071 NCS=NCT
23072 ELSE
23073 KCS=-KCS
23074 NCS=MCT(I,KCS-3)
23075 IF (NCS.EQ.0) GOTO 120
23076 ENDIF
23077
23078 IA=I
23079 NSTP=0
23080 100 NSTP=NSTP+1
23081 IF(NSTP.GT.4*N) THEN
23082 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
23083 GOTO 120
23084 ENDIF
23085
23086C...Finished if reached final-state triplet.
23087 IF(K(IA,1).EQ.3) THEN
23088 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
23089 ENDIF
23090
23091C...Also finished if reached junction.
23092 IF(K(IA,1).EQ.42) THEN
23093 GOTO 120
23094 ENDIF
23095
23096C...GOTO next parton in colour space.
23097 110 IB=IA
23098C...If IB's KCS daughter not traced and exists, goto KCS daughter.
23099 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
23100 & .NE.0) THEN
23101 IA=MOD(K(IB,KCS),MSTU(5))
23102 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
23103 MREV=0
23104 ELSE
23105C...If KCS mother traced or KCS mother nonexistent, switch colour.
23106 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
23107 & MSTU(5)).EQ.0) THEN
23108 KCS=9-KCS
23109 NCT=NCT+1
23110 NCS=NCT
23111C...Assign new colour tag on other side of old parton.
23112 MCT(IB,KCS-3)=NCT
23113 ENDIF
23114C...Goto (new) KCS mother, set mother traced tag
23115 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
23116 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
23117 MREV=1
23118 ENDIF
23119 IF(IA.LE.0.OR.IA.GT.N) THEN
23120 IF (IEND.EQ.-1) THEN
23121 IEND=0
23122 GOTO 120
23123 ENDIF
23124 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
23125 IF(NERRPR.LT.5) THEN
23126 write(*,*) 'began at ',I
23127 write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
23128 & ' NCS=',NCS,' MREV=',MREV
23129 CALL PYLIST(4)
23130 NERRPR=NERRPR+1
23131 ENDIF
23132 MINT(51)=1
23133 RETURN
23134 ENDIF
23135 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
23136 & MSTU(5)).EQ.IB) THEN
23137 IF(MREV.EQ.1) KCS=9-KCS
23138 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
23139C...Set KSC mother traced tag for IA
23140 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
23141 ELSE
23142 IF(MREV.EQ.0) KCS=9-KCS
23143 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
23144C...Set KCS daughter traced tag for IA
23145 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
23146 ENDIF
23147C...Assign new colour tag
23148 MCT(IA,KCS-3)=NCS
23149C...Finish if IEND=-1 and found final-state color partner
23150 IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN
23151 IEND=IA
23152 GOTO 120
23153 ENDIF
23154 IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100
23155
23156 120 RETURN
23157 END
23158
23159*********************************************************************
23160
23161C...PYMIHG
23162C...Collapse JCP1 and connecting tags to JCG1.
23163C...Collapse JCP2 and connecting tags to JCG2.
23164
23165 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
23166C...Double precision and integer declarations.
23167 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23168 IMPLICIT INTEGER(I-N)
23169 INTEGER PYK,PYCHGE,PYCOMP
23170C...The event record
23171 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23172C...Parameters
23173 COMMON/PYINT1/MINT(400),VINT(400)
23174 SAVE /PYJETS/,/PYINT1/
23175C...Local variables
23176 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
23177 COMMON /PYCTAG/NCT,MCT(4000,2)
23178 SAVE /PYCBLS/,/PYCTAG/
23179
23180C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
23181C...in temporary tag collapse array JCCN. Only break up one connection.
23182 MACCPT=1
23183 MCLPS=0
23184 DO 100 ICC=1,NCC
23185 JCCN(ICC,1)=JCCO(ICC,1)
23186 JCCN(ICC,2)=JCCO(ICC,2)
23187C...If there was a mother, it was previously connected to JCP1.
23188C...Should be changed to JCP2.
23189 IF (MCLPS.EQ.0) THEN
23190 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
23191 & ,JCP2)) THEN
23192 JCCN(ICC,1)=MAX(JCG2,JCP2)
23193 JCCN(ICC,2)=MIN(JCG2,JCP2)
23194 MCLPS=1
23195 ENDIF
23196 ENDIF
23197 100 CONTINUE
23198C...Also collapse colours on JCP1 side of JCG1
23199 IF (JCP1.NE.0) THEN
23200 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
23201 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
23202 ELSE
23203 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
23204 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
23205 ENDIF
23206
23207C...Initialize event record colour tag array MCT array to MCO.
23208 DO 110 I=MINT(84)+1,N
23209 MCT(I,1)=MCO(I,1)
23210 MCT(I,2)=MCO(I,2)
23211 110 CONTINUE
23212
23213C...Collapse tags:
23214C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
23215C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
23216C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
23217C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
23218 DO 160 IS=1,4
23219C...Skip if junction.
23220 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
23221C...Define starting point in tag space.
23222C...JCA = previous tag
23223C...JCO = present tag
23224C...JCN = new tag
23225 IF (MOD(IS,2).EQ.1) THEN
23226 JCO=JCP1
23227 JCN=JCG1
23228 JCALL=JCG1
23229 ELSEIF (MOD(IS,2).EQ.0) THEN
23230 JCO=JCP2
23231 JCN=JCG2
23232 JCALL=JCG2
23233 ENDIF
23234 ITRACE=0
23235 120 ITRACE=ITRACE+1
23236 IF (ITRACE.GT.1000) THEN
23237C...NB: Proper error message should be defined here.
23238 CALL PYERRM(14
23239 & ,'(PYMIHG:) Inf loop when collapsing colours.')
23240 MINT(57)=MINT(57)+1
23241 MINT(51)=1
23242 RETURN
23243 ENDIF
23244C...Collapse all JCN tags to JCALL
23245 DO 130 I=MINT(84)+1,N
23246 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
23247 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
23248 130 CONTINUE
23249C...IS = 1,2: first step forward. IS = 3,4: first step backward.
23250 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
23251 JCA=JCN
23252 JCN=JCO
23253 ELSE
23254 JCA=JCO
23255 JCO=JCN
23256 ENDIF
23257C...If possible, step from JCO to new tag JCN not equal to JCA.
23258 DO 140 ICC=1,NCC+1
23259 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
23260 & JCCN(ICC,2)
23261 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
23262 & JCCN(ICC,1)
23263 140 CONTINUE
23264C...Iterate if new colour was arrived at, but don't go in circles.
23265 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
23266C...Change all JCN tags in MCO to JCALL in MCT.
23267 DO 150 I=MINT(84)+1,N
23268 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
23269 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
23270C...If gluon and colour tag = anticolour tag (and not = 0) try again.
23271 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
23272 & .NE.0) MACCPT=0
23273 150 CONTINUE
23274 160 CONTINUE
23275
23276 DO 200 JCL=NCT,1,-1
23277 JCA=0
23278 JCN=JCL
23279 170 JCO=JCN
23280 DO 180 ICC=1,NCC+1
23281 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
23282 & =JCCN(ICC,2)
23283 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
23284 & =JCCN(ICC,1)
23285 180 CONTINUE
23286C...Overpaint all JCN with JCL
23287 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
23288 DO 190 I=MINT(84)+1,N
23289 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
23290 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
23291C...If gluon and colour tag = anticolour tag (and not = 0) try again.
23292 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
23293 & .NE.0) MACCPT=0
23294 190 CONTINUE
23295 JCA=JCO
23296 GOTO 170
23297 ENDIF
23298 200 CONTINUE
23299
23300 RETURN
23301 END
23302
23303C*********************************************************************
23304
23305C...PYMIRM
23306C...Picks primordial kT and shares longitudinal momentum among
23307C...beam remnants.
23308
23309 SUBROUTINE PYMIRM
23310
23311C...Double precision and integer declarations.
23312 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23313 IMPLICIT INTEGER(I-N)
23314 INTEGER PYK,PYCHGE,PYCOMP
23315C...The event record
23316 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23317C...Parameters
23318 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23319 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23320 COMMON/PYINT1/MINT(400),VINT(400)
23321C...The common block of colour tags.
23322 COMMON/PYCTAG/NCT,MCT(4000,2)
23323C...The common block of dangling ends
23324 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
23325 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
23326 & XMI(2,240),PT2MI(240),IMISEP(0:240)
23327 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
23328C...Local variables
23329 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
23330C...W(I,J)| J=0 | 1 | 2 |
23331C... I=0 | Wrem**2 | W+ | W- |
23332C... 1 | W1**2 | W1+ | W1- |
23333C... 2 | W2**2 | W2+ | W2- |
23334C...4-product
23335 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)
23336C...Tentative parametrization of <kT> as a function of Q.
23337 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
23338C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
23339C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
23340 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
23341C...Lambda kinematic function.
23342 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
23343
23344C...Beginning and end of beam remnant partons
23345 NOUT=MINT(53)
23346 ISUB=MINT(1)
23347
23348C...Loopback point if kinematic choices gives impossible configuration.
23349 NTRY=0
23350 100 NTRY=NTRY+1
23351
23352C...Assign kT values on each side separately.
23353 DO 180 JS=1,2
23354
23355C...First zero all kT on this side. Skip if no kT to generate.
23356 DO 110 IM=1,NMI(JS)
23357 P(IMI(JS,IM,1),1)=0D0
23358 P(IMI(JS,IM,1),2)=0D0
23359 110 CONTINUE
23360 IF(MSTP(91).LE.0) GOTO 180
23361
23362C...Now assign kT to each (non-collapsed) parton in IMI.
23363 DO 170 IM=1,NMI(JS)
23364 I=IMI(JS,IM,1)
23365C...Select kT according to truncated gaussian or 1/kt6 tails.
23366C...For first interaction, either use rms width = PARP(91) or fitted.
23367 IF (IM.EQ.1) THEN
23368 SIGMA=PARP(91)
23369 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
23370 Q=SQRT(PT2MI(IM))
23371 SIGMA=SIGPT(Q)
23372 ENDIF
23373 ELSE
23374C...For subsequent interactions and BR partons use fragmentation width.
23375 SIGMA=PARJ(21)
23376 ENDIF
23377 PHI=PARU(2)*PYR(0)
23378 PT=0D0
23379 IF(NTRY.LE.100) THEN
23380 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
23381 PT=GETPT(Q,SIGMA)
23382 PTX=PT*COS(PHI)
23383 PTY=PT*SIN(PHI)
23384 ELSEIF (MSTP(91).EQ.2) THEN
23385 CALL PYERRM(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
23386 & 'available, using MSTP(91)=1.')
23387 CALL PYGIVE('MSTP(91)=1')
23388 GOTO 111
23389 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
23390C...Use distribution with kt**6 tails, rms width = PARP(91).
23391 EPS=SQRT(3D0/2D0)*SIGMA
23392C...Generate PTX and PTY separately, each propto 1/KT**6
23393 DO 119 IXY=1,2
23394C...Decide which interval to try
23395 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
23396 IF (PYR(0).LT.P12) THEN
23397C...Use flat approx with accept/reject up to EPS.
23398 PT=PYR(0)*EPS
23399 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
23400 IF (PYR(0).GT.WT) GOTO 112
23401 ELSE
23402C...Above EPS, use 1/kt**6 approx with accept/reject.
23403 PT=EPS/(PYR(0)**(1D0/5D0))
23404 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
23405 IF (PYR(0).GT.WT) GOTO 112
23406 ENDIF
23407 MSIGN=1
23408 IF (PYR(0).GT.0.5D0) MSIGN=-1
23409 IF (IXY.EQ.1) PTX=MSIGN*PT
23410 IF (IXY.EQ.2) PTY=MSIGN*PT
23411 119 CONTINUE
23412 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
23413 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
23414 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
23415 ENDIF
23416C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
23417 PT=SQRT(PTX**2+PTY**2)
23418 WT=1D0
23419 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
23420 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
23421 PTX=PTX*WT
23422 PTY=PTY*WT
23423 PT=SQRT(PTX**2+PTY**2)
23424 ENDIF
23425
23426 P(I,1)=P(I,1)+PTX
23427 P(I,2)=P(I,2)+PTY
23428
23429C...Compensation kicks, with varying degree of local anticorrelations.
23430 MCORR=MSTP(90)
23431 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
23432 PTCX=-PTX/(NMI(JS)-1)
23433 PTCY=-PTY/(NMI(JS)-1)
23434 IF(ISUB.EQ.95) THEN
23435 PTCX=-PTX/(NMI(JS)-2)
23436 PTCY=-PTY/(NMI(JS)-2)
23437 ENDIF
23438 DO 120 IMC=1,NMI(JS)
23439 IF (IMC.EQ.IM) GOTO 120
23440 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
23441 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
23442 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
23443 120 CONTINUE
23444 ELSEIF (MCORR.GE.1) THEN
23445 DO 140 MSID=4,5
23446 NNXT(MSID-3)=0
23447C...Count up # of neighbours on either side
23448 IMO=I
23449 130 IMO=K(IMO,MSID)/MSTU(5)
23450 IF (IMO.EQ.0) GOTO 140
23451 NNXT(MSID-3)=NNXT(MSID-3)+1
23452C...Stop at quarks and junctions
23453 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
23454 140 CONTINUE
23455C...How should compensation be shared when unequal numbers on the
23456C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
23457 NSUM=NNXT(1)+NNXT(2)
23458 T1=0
23459 DO 160 MSID=4,5
23460C...Total momentum to be compensated on this side
23461 IF (NNXT(MSID-3).EQ.0) GOTO 160
23462 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
23463 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
23464C...RS: compensation supression factor as we go out from parton I.
23465C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
23466C...since (for now) MSTP(90) provides enough variability.
23467 RS=0.5D0
23468 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
23469 IMO=I
23470 150 IDA=IMO
23471 IMO=K(IMO,MSID)/MSTU(5)
23472 IF (IMO.EQ.0) GOTO 160
23473 FAC=FAC*RS
23474 IF (K(IMO,2).NE.88) THEN
23475 P(IMO,1)=P(IMO,1)+FAC*PTCX
23476 P(IMO,2)=P(IMO,2)+FAC*PTCY
23477 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
23478C...If we reach junction, divide out the kT that would have been
23479C...assigned to the junction on each of its other legs.
23480 ELSE
23481 L1=MOD(K(IMO,4),MSTU(5))
23482 L2=K(IMO,5)/MSTU(5)
23483 L3=MOD(K(IMO,5),MSTU(5))
23484 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
23485 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
23486 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
23487 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
23488 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
23489 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
23490 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
23491 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
23492 ENDIF
23493
23494 160 CONTINUE
23495 ENDIF
23496 170 CONTINUE
23497C...End assignment of kT values to initiators and remnants.
23498 180 CONTINUE
23499
23500C...Check kinematics constraints for non-BR partons.
23501 DO 190 IM=1,MINT(31)
23502 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
23503 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
23504 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
23505 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
23506 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
23507 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
23508 IF(NTRY.GE.100) THEN
23509C...Kill this event and start another.
23510 CALL PYERRM(1,
23511 & '(PYMIRM:) No consistent (x,kT) sets found')
23512 MINT(51)=1
23513 RETURN
23514 ENDIF
23515 GOTO 100
23516 ENDIF
23517 190 CONTINUE
23518
23519C...Calculate W+ and W- available for combined remnant system.
23520 W(0,1)=VINT(1)
23521 W(0,2)=VINT(1)
23522 DO 200 IM=1,MINT(31)
23523 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
23524 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
23525 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
23526 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
23527 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
23528 200 CONTINUE
23529C...Also store Wrem**2 = W+ * W-
23530 W(0,0)=W(0,1)*W(0,2)
23531
23532 IF ((W(0,0).LT.0D0.OR.W(0,1)+W(0,2).LT.0D0).AND.NTRY.LE.100) THEN
23533 IF(NTRY.GE.100) THEN
23534C...Kill this event and start another.
23535 CALL PYERRM(1,
23536 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
23537 MINT(51)=1
23538 RETURN
23539 ENDIF
23540 GOTO 100
23541 ENDIF
23542
23543C...Assign unscaled x values to partons/hadrons in each of the
23544C...beam remnants and calculate unscaled W+ and W- from them.
23545 NTRYX=0
23546 210 NTRYX=NTRYX+1
23547 DO 280 JS=1,2
23548 W(JS,1)=0D0
23549 W(JS,2)=0D0
23550 DO 270 IM=MINT(31)+1,NMI(JS)
23551 I=IMI(JS,IM,1)
23552 KF=K(I,2)
23553 KFA=IABS(KF)
23554 ICOMP=IMI(JS,IM,2)
23555
23556C...Skip collapsed gluons and junctions. Reset.
23557 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
23558 IF (KFA.EQ.88) GOTO 270
23559 X=0D0
23560 IVALQ(1)=0
23561 IVALQ(2)=0
23562 ICOMQ(1)=0
23563 ICOMQ(2)=0
23564
23565C...If gluon then only beam remnant, so takes all.
23566 IF(KFA.EQ.21) THEN
23567 X=1D0
23568C...If valence quark then use parametrized valence distribution.
23569 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
23570 IVALQ(1)=KF
23571C...If companion quark then derive from companion x.
23572 ELSEIF(KFA.LE.6) THEN
23573 ICOMQ(1)=ICOMP
23574C...If valence diquark then use two parametrized valence distributions.
23575 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23576 & ICOMP.EQ.0) THEN
23577 IVALQ(1)=ISIGN(KFA/1000,KF)
23578 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
23579C...If valence+sea diquark then combine valence + companion choices.
23580 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23581 & ICOMP.LT.MSTU(5)) THEN
23582 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
23583 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
23584 ELSE
23585 IVALQ(1)=ISIGN(KFA/1000,KF)
23586 ENDIF
23587 ICOMQ(1)=ICOMP
23588C...Extra code: workaround for diquark made out of two sea
23589C...quarks, but where not (yet) ICOMP > MSTU(5).
23590 DO 220 IM1=1,MINT(31)
23591 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
23592 ICOMQ(2)=IMI(JS,IM1,1)
23593 IVALQ(1)=0
23594 ENDIF
23595 220 CONTINUE
23596C...If sea diquark then sum of two derived from companion x.
23597 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
23598 ICOMQ(1)=MOD(ICOMP,MSTU(5))
23599 ICOMQ(2)=ICOMP/MSTU(5)
23600C...If meson or baryon then use fragmentation function.
23601C...Somewhat arbitrary split into old and new flavour, but OK normally.
23602 ELSE
23603 KFL3=MOD(KFA/10,10)
23604 IF(MOD(KFA/1000,10).EQ.0) THEN
23605 KFL1=MOD(KFA/100,10)
23606 ELSE
23607 KFL1=MOD(KFA,10000)-10*KFL3-1
23608 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
23609 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
23610 ENDIF
23611 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
23612 CALL PYZDIS(KFL1,KFL3,PR,X)
23613 ENDIF
23614
23615 DO 260 IQ=1,2
23616C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
23617C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
23618C...In other baryons combine u and d from proton appropriately.
23619 IF(IVALQ(IQ).NE.0) THEN
23620 NVAL=0
23621 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
23622 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
23623 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
23624C...Meson.
23625 IF(KFIVAL(JS,3).EQ.0) THEN
23626 MDU=0
23627C...Baryon with three identical quarks: mix u and d forms.
23628 ELSEIF(NVAL.EQ.3) THEN
23629 MDU=INT(PYR(0)+5D0/3D0)
23630C...Baryon, one of two identical quarks: u form.
23631 ELSEIF(NVAL.EQ.2) THEN
23632 MDU=2
23633C...Baryon with two identical quarks, but not the one picked: d form.
23634 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
23635 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
23636 MDU=1
23637C...Baryon with three nonidentical quarks: mix u and d forms.
23638 ELSE
23639 MDU=INT(PYR(0)+5D0/3D0)
23640 ENDIF
23641 XPOW=0.8D0
23642 IF(MDU.EQ.1) XPOW=3.5D0
23643 IF(MDU.EQ.2) XPOW=2D0
23644 230 XX=PYR(0)**2
23645 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
23646 X=X+XX
23647 ENDIF
23648
23649C...Calculation of x of companion quark.
23650 IF(ICOMQ(IQ).NE.0) THEN
23651 XCOMP=1D-4
23652 DO 240 IM1=1,MINT(31)
23653 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
23654 240 CONTINUE
23655 NPOW=MAX(0,MIN(4,MSTP(87)))
23656 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
23657 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
23658 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
23659 IF(CORR.LT.PYR(0)) GOTO 250
23660 X=X+XX
23661 ENDIF
23662 260 CONTINUE
23663
23664C...Optionally enchance x of composite systems (e.g. diquarks)
23665 IF (KFA.GT.100) X=PARP(79)*X
23666
23667C...Store x. Also calculate light cone energies of each system.
23668 XMI(JS,IM)=X
23669 W(JS,JS)=W(JS,JS)+X
23670 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
23671 270 CONTINUE
23672 W(JS,JS)=W(JS,JS)*W(0,JS)
23673 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
23674 W(JS,0)=W(JS,1)*W(JS,2)
23675 280 CONTINUE
23676
23677C...Check W1 W2 < Wrem (can be done before rescaling, since W
23678C...insensitive to global rescalings of the BR x values).
23679 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
23680 & THEN
23681 GOTO 210
23682 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
23683 GOTO 100
23684 ELSEIF (NTRYX.GT.100) THEN
23685 CALL PYERRM(1,'(PYMIRM:) No consistent (x,kT) sets found')
23686 MINT(57)=MINT(57)+1
23687 MINT(51)=1
23688 RETURN
23689 ENDIF
23690
23691C...Compute x rescaling factors
23692 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
23693 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
23694 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
23695
23696 IF (R1.LT.0.OR.R2.LT.0) THEN
23697 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
23698 MINT(57)=MINT(57)+1
23699 MINT(51)=1
23700 ENDIF
23701
23702C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
23703 W(1,1)=W(1,1)*R1
23704 W(1,2)=W(1,2)/R1
23705 W(2,1)=W(2,1)/R2
23706 W(2,2)=W(2,2)*R2
23707
23708C...Rescale BR x values.
23709 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
23710 XMI(1,IM)=XMI(1,IM)*R1
23711 XMI(2,IM)=XMI(2,IM)*R2
23712 290 CONTINUE
23713
23714C...Now we have a consistent set of x and kT values.
23715C...First set up the initiators and their daughters correctly.
23716 DO 300 IM=1,MINT(31)
23717 I1=IMI(1,IM,1)
23718 I2=IMI(2,IM,1)
23719 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
23720 & (P(I1,2)+P(I2,2))**2
23721 PT12=P(I1,1)**2+P(I1,2)**2
23722 PT22=P(I2,1)**2+P(I2,2)**2
23723C...p_z
23724 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
23725 P(I2,3)=-P(I1,3)
23726C...Energies (masses should be zero at this stage)
23727 P(I1,4)=SQRT(PT12+P(I1,3)**2)
23728 P(I2,4)=SQRT(PT22+P(I2,3)**2)
23729
23730C...Transverse 12 system initiator velocity:
23731 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
23732 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
23733C...Boost to overall initiator system rest frame
23734 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
23735 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
23736
23737C...Compute phi,theta coordinates of I1 and rotate z axis.
23738 PHI=PYANGL(P(I1,1),P(I1,2))
23739 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
23740 IMIN=IMISEP(IM-1)+1
23741C...(include documentation lines if MI = 1)
23742 IF (IM.EQ.1) IMIN=MINT(83)+5
23743 IMAX=IMISEP(IM)
23744C...Rotate entire system in phi
23745 CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
23746C...Only rotate 12 system in theta
23747 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
23748 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
23749
23750C...Now boost entire system back to LAB
23751 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
23752 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
23753 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
23754
23755 300 CONTINUE
23756
23757
23758C...For the beam remnant partons/hadrons, we only need to set pz and E.
23759 DO 320 JS=1,2
23760 DO 310 IM=MINT(31)+1,NMI(JS)
23761 I=IMI(JS,IM,1)
23762C...Skip collapsed gluons and junctions.
23763 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
23764 IF (KFA.EQ.88) GOTO 310
23765 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
23766 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
23767 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
23768 IF (JS.EQ.2) P(I,3)=-P(I,3)
23769 310 CONTINUE
23770 320 CONTINUE
23771
23772
23773C...Documentation lines
23774 DO 340 JS=1,2
23775 IN=MINT(83)+JS+2
23776 IO=IMI(JS,1,1)
23777 K(IN,1)=21
23778 K(IN,2)=K(IO,2)
23779 K(IN,3)=MINT(83)+JS
23780 K(IN,4)=0
23781 K(IN,5)=0
23782 DO 330 J=1,5
23783 P(IN,J)=P(IO,J)
23784 V(IN,J)=V(IO,J)
23785 330 CONTINUE
23786 MCT(IN,1)=MCT(IO,1)
23787 MCT(IN,2)=MCT(IO,2)
23788 340 CONTINUE
23789
23790C...Final state colour reconnections.
23791 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
23792
23793C...Number of colour tags for which a recoupling will be tried.
23794 NTOT=NCT
23795C...Number of recouplings to try
23796 MINT(34)=0
23797 NRECP=0
23798 NITER=0
23799 350 NRECP=MINT(34)
23800 NITER=NITER+1
23801 IITER=0
23802 360 IITER=IITER+1
23803 IF (IITER.LE.PARP(78)*NTOT) THEN
23804C...Select two colour tags at random
23805C...NB: jj strings do not have colour tags assigned to them,
23806C...thus they are as yet not affected by anything done here.
23807 JCT=PYR(0)*NCT+1
23808 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
23809 IJ1=0
23810 IJ2=0
23811 IK1=0
23812 IK2=0
23813C...Find final state partons with this (anti)colour
23814 DO 370 I=MINT(84)+1,N
23815 IF (K(I,1).EQ.3) THEN
23816 IF (MCT(I,1).EQ.JCT) IJ1=I
23817 IF (MCT(I,2).EQ.JCT) IJ2=I
23818 IF (MCT(I,1).EQ.KCT) IK1=I
23819 IF (MCT(I,2).EQ.KCT) IK2=I
23820 ENDIF
23821 370 CONTINUE
23822C...Only consider recouplings not involving junctions for now.
23823 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
23824
23825 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
23826 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
23827 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
23828 MCT(IJ2,2)=KCT
23829 MCT(IK2,2)=JCT
23830C...Count up number of reconnections
23831 MINT(34)=MINT(34)+1
23832 ENDIF
23833 IF (MINT(34).LE.1000) THEN
23834 GOTO 360
23835 ELSE
23836 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
23837 GOTO 380
23838 ENDIF
23839 ENDIF
23840 IF (NRECP.LT.MINT(34)) GOTO 350
23841
23842C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
23843 380 MINT(33)=1
23844
23845 RETURN
23846 END
23847
23848C*********************************************************************
23849
23850C...PYFSCR
23851C...Performs colour annealing.
23852C...MSTP(95) : CR Type
23853C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
23854C... = 2 : Type I(no gg loops); hadron-hadron only
23855C... = 3 : Type I(no gg loops); all beams
23856C... = 4 : Type II(gg loops) ; hadron-hadron only
23857C... = 5 : Type II(gg loops) ; all beams
23858C... = 6 : Type S ; hadron-hadron only
23859C... = 7 : Type S ; all beams
23860C... = 8 : Type P ; hadron-hadron only
23861C... = 9 : Type P ; all beams
23862C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
23863C...Type S is driven by starting only from free triplets, not octets.
23864C...Type P is also driven by free triplets, but the reconnect probability
23865C...is computed from the string density per unit rapidity, where the axis
23866C...with respect to which the rapidity is computed is the Thrust axis of the
23867C...event.
23868C...A string piece remains unchanged with probability
23869C... PKEEP = (1-PARP(78))**N
23870C...This scaling corresponds to each string piece having to go through
23871C...N other ones, each with probability PARP(78) for reconnection.
23872C...For types I, II, and S, N is chosen simply as the number of multiple
23873C...interactions, for a rough scaling with the general level of activity.
23874C...For type P, N is chosen to be the number of string pieces in a given
23875C...interval of rapidity (minus one, since the string doesn't reconnect
23876C...with itself), and the reconnect probability is interpreted as the
23877C...probability per unit rapidity.
23878C...It also also possible to apply a dampening factor to the CR strength,
23879C...using PARP(77), which will cause reconnections among high-pT string
23880C...pieces to be suppressed.
23881
23882 SUBROUTINE PYFSCR(IP)
23883C...Double precision and integer declarations.
23884 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23885 INTEGER PYK,PYCHGE,PYCOMP
23886C...Commonblocks.
23887 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23888 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23889 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23890 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23891 COMMON/PYINT1/MINT(400),VINT(400)
23892C...The common block of colour tags.
23893 COMMON/PYCTAG/NCT,MCT(4000,2)
23894 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
23895 &/PYPARS/
23896C...MCN: Temporary storage of new colour tags
23897 INTEGER MCN(4000,2)
23898C...Arrays for storing color strings
23899 PARAMETER (NBINY=100)
23900 INTEGER ICR(4000),MSCR(4000)
23901 INTEGER IOPT(4000), NSTRY(NBINY)
23902 DOUBLE PRECISION RLOPTC(4000)
23903
23904C...Function to give four-product.
23905 FOUR(I,J)=P(I,4)*P(J,4)
23906 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
23907
23908C...Check valid range of MSTP(95), local copy
23909 IF (MSTP(95).LE.1.OR.MSTP(95).GE.10) RETURN
23910 MSTP95=MOD(MSTP(95),10)
23911C...Set whether CR allowed inside resonance systems or not
23912C...(not implemented yet)
23913C MRESCR=1
23914C IF (MSTP(95).GE.10) MRESCR=0
23915
23916C...Check whether colour tags already defined
23917 IF (MINT(33).EQ.0) THEN
23918C...Erase any existing colour tags for this event
23919 DO 100 I=1,N
23920 MCT(I,1)=0
23921 MCT(I,2)=0
23922 100 CONTINUE
23923C...Create colour tags for this event
23924 DO 120 I=1,N
23925 IF (K(I,1).EQ.3) THEN
23926 DO 110 KCS=4,5
23927 KCSIN=KCS
23928 IF (MCT(I,KCSIN-3).EQ.0) THEN
23929 CALL PYCTTR(I,KCSIN,I)
23930 ENDIF
23931 110 CONTINUE
23932 ENDIF
23933 120 CONTINUE
23934C...Instruct PYPREP to use colour tags
23935 MINT(33)=1
23936 ENDIF
23937
23938C...For MSTP(95) even, only apply to hadron-hadron
23939 KA1=IABS(MINT(11))
23940 KA2=IABS(MINT(12))
23941 IF (MOD(MSTP(95),2).EQ.0.AND.(KA1.LT.100.OR.KA2.LT.100)) GOTO 9999
23942
23943C...Initialize new tag array (but do not delete old yet)
23944 LCT=NCT
23945 DO 130 I=MAX(1,IP),N
23946 MCN(I,1)=0
23947 MCN(I,2)=0
23948 130 CONTINUE
23949
23950C...For Paquis type, determine thrust axis (default along Z axis)
23951 TX=0D0
23952 TY=0D0
23953 TZ=1D0
23954 IF (MSTP95.GE.8) THEN
23955 CALL PYTHRU(THRDUM,OBLDUM)
23956 TX = P(N+1,1)
23957 TY = P(N+1,2)
23958 TZ = P(N+1,3)
23959 ENDIF
23960
23961C...For each final-state dipole, check whether string should be
23962C...preserved.
23963 NCR=0
23964 IA=0
23965 IC=0
23966 RAPMAX=0.0
23967
23968 ICTMIN=NCT
23969 DO 150 ICT=1,NCT
23970 IA=0
23971 IC=0
23972 DO 140 I=MAX(1,IP),N
23973 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
23974 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
23975 140 CONTINUE
23976 IF (IC.NE.0.AND.IA.NE.0) THEN
23977C...Save smallest NCT value so far
23978 ICTMIN = MIN(ICTMIN,ICT)
23979C...For Paquis algorithm, just store all string pieces for now
23980 IF (MSTP95.GE.8) THEN
23981C... Add coloured parton
23982 NCR=NCR+1
23983 ICR(NCR)=IC
23984 MSCR(NCR)=1
23985 IOPT(NCR)=0
23986C... Store rapidity (along Thrust axis) in RLOPT for the time being
23987C... Add pion mass headroom to energy for this calculation
23988 EET = P(IC,4)*SQRT(1D0+(0.135D0/P(IC,4))**2)
23989 PZT = P(IC,1)*TX+P(IC,2)*TY+P(IC,3)*TZ
23990 RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT))
23991C... Add anti-coloured parton
23992 NCR = NCR+1
23993 ICR(NCR) = IA
23994 MSCR(NCR) = 2
23995 IOPT(NCR) = 0
23996C... Store rapidity (along Thrust axis) in RLOPT for the time being
23997 EET = P(IA,4)*SQRT(1D0+(0.135D0/P(IA,4))**2)
23998 PZT = P(IA,1)*TX+P(IA,2)*TY+P(IA,3)*TZ
23999 RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT))
24000C... Keep track of largest endpoint "rapidity"
24001 RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR)))
24002 RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR-1)))
24003 ELSE
24004 CRMODF=1D0
24005C... Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
24006C... (so far ignores the possibility that the whole "muck" may be moving.)
24007 IF (PARP(77).GT.0D0) THEN
24008 PT2STR=(P(IA,1)+P(IC,1))**2+(P(IA,2)+P(IC,2))**2
24009C... For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
24010 IF (KA1.LT.100.AND.KA2.LT.100) THEN
24011 P2STR = PT2STR + (P(IA,3)+P(IC,3))**2
24012 ELSE
24013 P2STR = 3D0/2D0 * PT2STR
24014 ENDIF
24015 RM2STR=(P(IA,4)+P(IC,4))**2-(P(IA,3)+P(IC,3))**2-PT2STR
24016 RM2STR=MAX(RM2STR,PMAS(PYCOMP(111),1)**2)
24017C... Estimate number of particles ~ log(M2), cut off at 1.
24018 RLOGM2=MAX(1D0,LOG(RM2STR))
24019 P2AVG=P2STR/RLOGM2
24020C... Supress reconnection probability by 1/(1+P77*P2AVG)
24021 CRMODF=1D0/(1D0+PARP(77)**2*P2AVG)
24022 ENDIF
24023 PKEEP=(1D0-PARP(78)*CRMODF)**MINT(31)
24024 IF (PYR(0).LE.PKEEP) THEN
24025 LCT=LCT+1
24026 MCN(IC,1)=LCT
24027 MCN(IA,2)=LCT
24028 ELSE
24029C... Add coloured parton
24030 NCR=NCR+1
24031 ICR(NCR)=IC
24032 MSCR(NCR)=1
24033 IOPT(NCR)=0
24034 RLOPTC(NCR)=1D19
24035C... Add anti-coloured parton
24036 NCR=NCR+1
24037 ICR(NCR)=IA
24038 MSCR(NCR)=2
24039 IOPT(NCR)=0
24040 RLOPTC(NCR)=1D19
24041 ENDIF
24042 ENDIF
24043 ENDIF
24044 150 CONTINUE
24045
24046C...PAQUIS TYPE
24047 IF (MSTP95.GE.8) THEN
24048C... For Paquis type, make "histogram" of string densities along thrust axis
24049 RAPMIN = -RAPMAX
24050 DRAP = 2*RAPMAX/(1D0*NBINY)
24051C... Explicitly zero histogram bin content
24052 DO 147 IBINY=1,NBINY
24053 NSTRY(IBINY)=0
24054 147 CONTINUE
24055 DO 152 ISTR=1,NCR-1,2
24056 IC = ICR(ISTR)
24057 IA = ICR(ISTR+1)
24058 Y1 = MIN(RLOPTC(ISTR),RLOPTC(ISTR+1))
24059 Y2 = MAX(RLOPTC(ISTR),RLOPTC(ISTR+1))
24060 DO 153 IBINY=1,NBINY
24061 YBINLO = RAPMIN + (IBINY-1)*DRAP
24062C... If bin inside string piece, add 1 in this bin
24063C... (Strictly speaking: if it starts before midpoint and ends after midpoint)
24064 IF (Y1.LE.YBINLO+0.5*DRAP.AND.Y2.GE.YBINLO+0.5*DRAP)
24065 & NSTRY(IBINY) = NSTRY(IBINY) + 1
24066 153 CONTINUE
24067 152 CONTINUE
24068C... Loop over pieces to find individual reconnect probability
24069 DO 167 IS=1,NCR-1,2
24070 DNSUM = 0D0
24071 DNAVG = 0D0
24072C...Beginning at Y = RAPMIN = -RAPMAX, ending at Y = RAPMAX
24073 RBINLO = (MIN(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5
24074 RBINHI = (MAX(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5
24075C...Make sure integer bin numbers lie inside proper range
24076 IBINLO = MAX(1,MIN(NBINY,NINT(RBINLO)))
24077 IBINHI = MAX(1,MIN(NBINY,NINT(RBINHI)))
24078C...Size of rapidity bins (is < DRAP if piece smaller than one bin)
24079C...(also smaller than DRAP if a one-unit wide piece is stretched
24080C... over 2 bins, thus making the computation more accurate)
24081 DRAPAV = (RBINHI-RBINLO)/(IBINHI-IBINLO+1)*DRAP
24082C... Decide whether to suppress reconnections in high-pT string pieces
24083 CRMODF = 1D0
24084 IF (PARP(77).GT.0D0) THEN
24085C... Total string piece energy, momentum squared, and components
24086 EES = P(ICR(IS),4) + P(ICR(IS+1),4)
24087 PPS2 = (P(ICR(IS),1)+ P(ICR(IS+1),1))**2
24088 & + (P(ICR(IS),2)+ P(ICR(IS+1),2))**2
24089 & + (P(ICR(IS),3)+ P(ICR(IS+1),3))**2
24090 PZTS = P(ICR(IS),1)*TX+P(ICR(IS),2)*TY+P(ICR(IS),3)*TZ
24091 & + P(ICR(IS+1),1)*TX+P(ICR(IS+1),2)*TY+P(ICR(IS+1),3)*TZ
3ce9b8e0 24092 PTTS = SQRT(MAX(0.D0,PPS2 - PZTS**2))
92e27c01 24093C... Mass of string piece in units of mpi (at least 1)
24094 RMPI2 = 0.135D0
24095 RM2STR = MAX(RMPI2,EES**2 - PPS2)
24096C... Estimate number of pions ~ log(M2) (at least 1)
24097 RNPI = LOG(RM2STR/RMPI2)+1D0
24098 PT2AVG = (PTTS / RNPI)**2
24099C... Supress reconnection probability by 1/(1+P77*P2AVG)
24100 CRMODF=1D0/(1D0+PARP(77)**2*PT2AVG)
24101 ENDIF
24102 PKEEP = 1.0
24103 DO 178 IBINY=IBINLO,IBINHI
24104C DNSUM = DNSUM + 1D0
24105 DNOVL = MAX(0,NSTRY(IBINY)-1)
24106 PKEEP = PKEEP * (1D0-CRMODF*PARP(78))**(DRAPAV*DNOVL)
24107C DNAVG = DNAVG + MAX(1,NSTRY(IBINY))
24108 178 CONTINUE
24109C DNAVG = DNAVG / DNSUM
24110C... If keeping string piece, save
24111 IF (PYR(0).LE.PKEEP) THEN
24112 LCT = LCT+1
24113 MCN(ICR(IS),1)=LCT
24114 MCN(ICR(IS+1),2)=LCT
24115 ENDIF
24116 167 CONTINUE
24117 ENDIF
24118
24119C...Skip if there is only one possibility
24120 IF (NCR.LE.2) THEN
24121 GOTO 9999
24122 ENDIF
24123
24124C...Reorder, so ordered in I (in order to correspond to old algorithm)
24125 NLOOP=0
24126 151 NLOOP=NLOOP+1
24127 MORD=1
24128 DO 155 IC1=1,NCR-1
24129 I1=ICR(IC1)
24130 I2=ICR(IC1+1)
24131 IF (I1.GT.I2) THEN
24132 IT=I1
24133 MST=MSCR(IC1)
24134 ICR(IC1)=I2
24135 MSCR(IC1)=MSCR(IC1+1)
24136 ICR(IC1+1)=IT
24137 MSCR(IC1+1)=MST
24138 MORD=0
24139 ENDIF
24140 155 CONTINUE
24141C...Max do 1000 reordering loops
24142 IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 151
24143
24144C...PS: 03 May 2010
24145C...For Seattle and Paquis types, check if there is a dangling tag
24146C...Needed for special case when entire reconnected state was one or
24147C...more gluon loops in original topology in which case these CR
24148C...algorithms need to be told they shouldn't look for a dangling tag.
24149 M3FREE=0
24150 IF (MSTP95.GE.6.AND.MSTP95.LE.9) THEN
24151 DO 157 IC1=1,NCR
24152 I1=ICR(IC1)
24153C...Color charge
24154 MCI=KCHG(PYCOMP(K(I1,2)),2)*ISIGN(1,K(I1,2))
24155 IF (MCI.EQ.1.AND.MCN(I1,1).EQ.0) M3FREE=1
24156 IF (MCI.EQ.-1.AND.MCN(I1,2).EQ.0) M3FREE=1
24157 IF (MCI.EQ.2) THEN
24158 IF (MCN(I1,1).NE.0.AND.MCN(I1,2).EQ.0) M3FREE=1
24159 IF (MCN(I1,2).NE.0.AND.MCN(I1,1).EQ.0) M3FREE=1
24160 ENDIF
24161 157 CONTINUE
24162 ENDIF
24163
24164C...Loop over CR partons
24165C...(Ignore junctions for now.)
24166 NLOOP=0
24167 160 NLOOP=NLOOP+1
24168 RLMAX=0D0
24169 ICRMAX=0
24170C...Loop over coloured partons
24171 DO 230 IC1=1,NCR
24172C...Retrieve parton Event Record index and Colour Side
24173 I=ICR(IC1)
24174 MSI=MSCR(IC1)
24175C...Skip already connected partons
24176 IF (MCN(I,MSI).NE.0) GOTO 230
24177C...Shorthand for colour charge
24178 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
24179C...For Seattle algorithm, only start from partons with one dangling
24180C...colour tag (unless there aren't any, cf. M3FREE above.)
24181 IF (MSTP(95).GE.6.AND.MSTP(95).LE.9) THEN
24182 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0
24183 & .AND.M3FREE.EQ.1) THEN
24184 GOTO 230
24185 ENDIF
24186 ENDIF
24187C...Retrieve saved optimal partner
24188 IO=IOPT(IC1)
24189 IF (IO.NE.0) THEN
24190C...Reject saved optimal partner if latter is now connected
24191C...(Also reject if using model S1, since saved partner may
24192C...now give rise to gg loop.)
24193 IF (MCN(IO,3-MSI).NE.0.OR.MSTP(95).LE.3) THEN
24194 IOPT(IC1)=0
24195 RLOPTC(IC1)=1D19
24196 ENDIF
24197 ENDIF
24198 RLOPT=RLOPTC(IC1)
24199C...Search for new optimal partner if necessary
24200 IF (IOPT(IC1).EQ.0) THEN
24201 MBROPT=0
24202 MGGOPT=0
24203 RLOPT=1D19
24204C...Loop over partons you can connect to
24205 DO 210 IC2=1,NCR
24206 J=ICR(IC2)
24207 MSJ=MSCR(IC2)
24208C...Skip if already connected
24209 IF (MCN(J,MSJ).NE.0) GOTO 210
24210C...Skip if this not colour-anticolour pair
24211 IF (MSI.EQ.MSJ) GOTO 210
24212C...And do not let gluons connect to themselves
24213 IF (I.EQ.J) GOTO 210
24214C...Suppress direct connections between partons in same Beam Remnant
24215 MBRSTR=0
24216 IF (K(I,3).LE.2.AND.K(I,3).GE.1.AND.K(I,3).EQ.K(J,3))
24217 & MBRSTR=1
24218C...Shorthand for colour charge
24219 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
24220C...Check for gluon loops
24221 MGGSTR=0
24222 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
24223 IF (MCN(I,2).EQ.MCN(J,1).AND.MSTP(95).LE.3.AND.
24224 & MCN(I,2).NE.0) MGGSTR=1
24225 ENDIF
24226C...Save connection with smallest lambda measure
24227 RL=FOUR(I,J)
24228C...If best so far was a BR string and this is not, also save.
24229C...If best so far was a gg string and this is not, also save.
24230C...NB: this is not fool-proof. If the algorithm finds a BR or gg
24231C...string with a small Lambda measure as the last step, this connection
24232C...will be saved regardless of whether other possibilities existed.
24233C...I.e., there should really be a check whether another possibility has
24234C...already been found, but since these models are now actively in use
24235C...and uncertainties are anyway large, the algorithm is left as it is.
24236C...(correction --> Pythia 8 ?)
24237 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
24238 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
24239 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
24240C...Paquis type: fix problem above
24241 MPAQ = 0
24242 IF (MSTP95.GE.8.AND.RLOPT.LE.1D18) THEN
24243 IF (MBRSTR.EQ.1.AND.MBROPT.EQ.0) MPAQ=1
24244 IF (MGGSTR.EQ.1.AND.MGGOPT.EQ.0) MPAQ=1
24245 ENDIF
24246 IF (MPAQ.EQ.0) THEN
24247 RLOPT=RL
24248 RLOPTC(IC1)=RLOPT
24249 IOPT(IC1)=J
24250 MBROPT=MBRSTR
24251 MGGOPT=MGGSTR
24252 ENDIF
24253 ENDIF
24254 210 CONTINUE
24255 ENDIF
24256 IF (IOPT(IC1).NE.0) THEN
24257C...Save pair with largest RLOPT so far
24258 IF (RLOPT.GE.RLMAX) THEN
24259 ICRMAX=IC1
24260 RLMAX=RLOPT
24261 ENDIF
24262 ENDIF
24263 230 CONTINUE
24264C...Save and iterate
24265 ICMAX=0
24266 IF (ICRMAX.GT.0) THEN
24267 LCT=LCT+1
24268 ILMAX=ICR(ICRMAX)
24269 JLMAX=IOPT(ICRMAX)
24270 ICMAX=MSCR(ICRMAX)
24271 JCMAX=3-ICMAX
24272 MCN(ILMAX,ICMAX)=LCT
24273 MCN(JLMAX,JCMAX)=LCT
24274 IF (NLOOP.LE.2*(N-IP)) THEN
24275 GOTO 160
24276 ELSE
24277 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
24278 CALL PYSTOP(11)
24279 ENDIF
24280 ELSE
24281C...Save and exit. First check for leftover gluon(s)
24282 DO 260 I=MAX(1,IP),N
24283C...Check colour charge
24284 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
24285 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
24286 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
24287C...Decide where to put left-over gluon (minimal insertion)
24288 ICMAX=0
24289 RLMAX=1D19
24290C...PS: Bug fix 30 Apr 2010: try all lines, not just reconnected ones
24291 DO 250 KCT=ICTMIN,LCT
24292 IC=0
24293 IA=0
24294 DO 240 IT=MAX(1,IP),N
24295 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
24296 IF (MCN(IT,1).EQ.KCT) IC=IT
24297 IF (MCN(IT,2).EQ.KCT) IA=IT
24298 240 CONTINUE
24299C...Skip if this color tag no longer present in event record
24300 IF (IC.EQ.0.OR.IA.EQ.0) GOTO 250
24301 RL=FOUR(IC,I)*FOUR(IA,I)
24302 IF (RL.LT.RLMAX) THEN
24303 RLMAX=RL
24304 ICMAX=IC
24305 IAMAX=IA
24306 ENDIF
24307 250 CONTINUE
24308 LCT=LCT+1
24309 MCN(I,1)=MCN(ICMAX,1)
24310 MCN(I,2)=LCT
24311 MCN(ICMAX,1)=LCT
24312 ENDIF
24313 260 CONTINUE
24314C...Here we need to loop over entire event.
24315 DO 270 IZ=MAX(1,IP),N
24316C...Do not erase parton shower colour history
24317 IF (K(IZ,1).NE.3) GOTO 270
24318C...Check colour charge
24319 MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2))
24320 IF (MCI.EQ.0) GOTO 270
24321 IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1)
24322 IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2)
24323 270 CONTINUE
24324 ENDIF
24325
24326 9999 RETURN
24327 END
24328
24329C*********************************************************************
24330
24331C...PYDIFF
24332C...Handles diffractive and elastic scattering.
24333
24334 SUBROUTINE PYDIFF
24335
24336C...Double precision and integer declarations.
24337 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24338 IMPLICIT INTEGER(I-N)
24339 INTEGER PYK,PYCHGE,PYCOMP
24340C...Commonblocks.
24341 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24342 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24343 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24344 COMMON/PYINT1/MINT(400),VINT(400)
24345 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
24346
24347C...Reset K, P and V vectors. Store incoming particles.
24348 DO 110 JT=1,MSTP(126)+10
24349 I=MINT(83)+JT
24350 DO 100 J=1,5
24351 K(I,J)=0
24352 P(I,J)=0D0
24353 V(I,J)=0D0
24354 100 CONTINUE
24355 110 CONTINUE
24356 N=MINT(84)
24357 MINT(3)=0
24358 MINT(21)=0
24359 MINT(22)=0
24360 MINT(23)=0
24361 MINT(24)=0
24362 MINT(4)=4
24363 DO 130 JT=1,2
24364 I=MINT(83)+JT
24365 K(I,1)=21
24366 K(I,2)=MINT(10+JT)
24367 DO 120 J=1,5
24368 P(I,J)=VINT(285+5*JT+J)
24369 120 CONTINUE
24370 130 CONTINUE
24371 MINT(6)=2
24372
24373C...Subprocess; kinematics.
24374 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
24375 PZ=SQRT(SQLAM)/(2D0*VINT(1))
24376 DO 200 JT=1,2
24377 I=MINT(83)+JT
24378 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
24379 KFH=MINT(102+JT)
24380
24381C...Elastically scattered particle. (Except elastic GVMD states.)
24382 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
24383 & MINT(106+JT).NE.3)) THEN
24384 N=N+1
24385 K(N,1)=1
24386 K(N,2)=KFH
24387 K(N,3)=I+2
24388 P(N,3)=PZ*(-1)**(JT+1)
24389 P(N,4)=PE
24390 P(N,5)=SQRT(VINT(62+JT))
24391
24392C...Decay rho from elastic scattering of gamma with sin**2(theta)
24393C...distribution of decay products (in rho rest frame).
24394 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
24395 NSAV=N
24396 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
24397 P(N,3)=0D0
24398 P(N,4)=P(N,5)
24399 CALL PYDECY(NSAV)
24400 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
24401 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
24402 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
24403 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
24404 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
24405 140 CTHE=2D0*PYR(0)-1D0
24406 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
24407 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
24408 ENDIF
24409 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
24410 ENDIF
24411
24412C...Diffracted particle: low-mass system to two particles.
24413 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
24414 N=N+2
24415 K(N-1,1)=1
24416 K(N,1)=1
24417 K(N-1,3)=I+2
24418 K(N,3)=I+2
24419 PMMAS=SQRT(VINT(62+JT))
24420 NTRY=0
24421 150 NTRY=NTRY+1
24422 IF(NTRY.LT.20) THEN
24423 MINT(105)=MINT(102+JT)
24424 MINT(109)=MINT(106+JT)
24425 CALL PYSPLI(KFH,21,KFL1,KFL2)
24426 CALL PYKFDI(KFL1,0,KFL3,KF1)
24427 IF(KF1.EQ.0) GOTO 150
24428 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
24429 IF(KF2.EQ.0) GOTO 150
24430 ELSE
24431 KF1=KFH
24432 KF2=111
24433 ENDIF
24434 PM1=PYMASS(KF1)
24435 PM2=PYMASS(KF2)
24436 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
24437 K(N-1,2)=KF1
24438 K(N,2)=KF2
24439 P(N-1,5)=PM1
24440 P(N,5)=PM2
24441 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
24442 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
24443 P(N-1,3)=PZP
24444 P(N,3)=-PZP
24445 P(N-1,4)=SQRT(PM1**2+PZP**2)
24446 P(N,4)=SQRT(PM2**2+PZP**2)
24447 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
24448 & 0D0,0D0,0D0)
24449 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
24450 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
24451
24452C...Diffracted particle: valence quark kicked out.
24453 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
24454 & PARP(101))) THEN
24455 N=N+2
24456 K(N-1,1)=2
24457 K(N,1)=1
24458 K(N-1,3)=I+2
24459 K(N,3)=I+2
24460 MINT(105)=MINT(102+JT)
24461 MINT(109)=MINT(106+JT)
24462 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
24463 P(N-1,5)=PYMASS(K(N-1,2))
24464 P(N,5)=PYMASS(K(N,2))
24465 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
24466 & 4D0*P(N-1,5)**2*P(N,5)**2
24467 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
24468 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
24469 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
24470 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
24471 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
24472
24473C...Diffracted particle: gluon kicked out.
24474 ELSE
24475 N=N+3
24476 K(N-2,1)=2
24477 K(N-1,1)=2
24478 K(N,1)=1
24479 K(N-2,3)=I+2
24480 K(N-1,3)=I+2
24481 K(N,3)=I+2
24482 MINT(105)=MINT(102+JT)
24483 MINT(109)=MINT(106+JT)
24484 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
24485 K(N-1,2)=21
24486 P(N-2,5)=PYMASS(K(N-2,2))
24487 P(N-1,5)=0D0
24488 P(N,5)=PYMASS(K(N,2))
24489C...Energy distribution for particle into two jets.
24490 160 IMB=1
24491 IF(MOD(KFH/1000,10).NE.0) IMB=2
24492 CHIK=PARP(92+2*IMB)
24493 IF(MSTP(92).LE.1) THEN
24494 IF(IMB.EQ.1) CHI=PYR(0)
24495 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
24496 ELSEIF(MSTP(92).EQ.2) THEN
24497 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
24498 ELSEIF(MSTP(92).EQ.3) THEN
24499 CUT=2D0*0.3D0/VINT(1)
24500 170 CHI=PYR(0)**2
24501 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
24502 & PYR(0)) GOTO 170
24503 ELSEIF(MSTP(92).EQ.4) THEN
24504 CUT=2D0*0.3D0/VINT(1)
24505 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
24506 180 CHIR=CUT*CUTR**PYR(0)
24507 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
24508 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
24509 ELSE
24510 CUT=2D0*0.3D0/VINT(1)
24511 CUTA=CUT**(1D0-PARP(98))
24512 CUTB=(1D0+CUT)**(1D0-PARP(98))
24513 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
24514 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
24515 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
24516 ENDIF
24517 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
24518 & VINT(62+JT)) GOTO 160
24519 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
24520 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
24521 & (2D0*VINT(62+JT))
24522 PEI=SQRT(PZI**2+SQM)
24523 PQQP=(1D0-CHI)*(PEI+PZI)
24524 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
24525 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
24526 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
24527 P(N-1,3)=P(N-1,4)*(-1)**JT
24528 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
24529 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
24530 ENDIF
24531
24532C...Documentation lines.
24533 K(I+2,1)=21
24534 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
24535 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
24536 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
24537 K(I+2,3)=I
24538 P(I+2,3)=PZ*(-1)**(JT+1)
24539 P(I+2,4)=PE
24540 P(I+2,5)=SQRT(VINT(62+JT))
24541 200 CONTINUE
24542
24543C...Rotate outgoing partons/particles using cos(theta).
24544 IF(VINT(23).LT.0.9D0) THEN
24545 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
24546 ELSE
24547 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
24548 ENDIF
24549
24550 RETURN
24551 END
24552
24553C*********************************************************************
24554
24555C...PYDISG
24556C...Set up a DIS process as gamma* + f -> f, with beam remnant
24557C...and showering added consecutively. Photon flux by the PYGAGA
24558C...routine (if at all).
24559
24560 SUBROUTINE PYDISG
24561
24562C...Double precision and integer declarations.
24563 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24564 IMPLICIT INTEGER(I-N)
24565 INTEGER PYK,PYCHGE,PYCOMP
24566C...Parameter statement to help give large particle numbers.
24567 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24568 &KEXCIT=4000000,KDIMEN=5000000)
24569C...Commonblocks.
24570 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24571 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24572 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24573 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24574 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24575 COMMON/PYINT1/MINT(400),VINT(400)
24576 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
24577C...Local arrays.
24578 DIMENSION PMS(4)
24579
24580C...Choice of subprocess, number of documentation lines
24581 IDOC=7
24582 MINT(3)=IDOC-6
24583 MINT(4)=IDOC
24584 IPU1=MINT(84)+1
24585 IPU2=MINT(84)+2
24586 IPU3=MINT(84)+3
24587 ISIDE=1
24588 IF(MINT(107).EQ.4) ISIDE=2
24589
24590C...Reset K, P and V vectors. Store incoming particles
24591 DO 110 JT=1,MSTP(126)+20
24592 I=MINT(83)+JT
24593 DO 100 J=1,5
24594 K(I,J)=0
24595 P(I,J)=0D0
24596 V(I,J)=0D0
24597 100 CONTINUE
24598 110 CONTINUE
24599 DO 130 JT=1,2
24600 I=MINT(83)+JT
24601 K(I,1)=21
24602 K(I,2)=MINT(10+JT)
24603 DO 120 J=1,5
24604 P(I,J)=VINT(285+5*JT+J)
24605 120 CONTINUE
24606 130 CONTINUE
24607 MINT(6)=2
24608
24609C...Store incoming partons in hadronic CM-frame
24610 DO 140 JT=1,2
24611 I=MINT(84)+JT
24612 K(I,1)=14
24613 K(I,2)=MINT(14+JT)
24614 K(I,3)=MINT(83)+2+JT
24615 140 CONTINUE
24616 IF(MINT(15).EQ.22) THEN
24617 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
24618 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
24619 P(MINT(84)+1,5)=-SQRT(VINT(307))
24620 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
24621 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
24622 KFRES=MINT(16)
24623 ISIDE=2
24624 ELSE
24625 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
24626 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
24627 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
24628 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
24629 P(MINT(84)+1,5)=-SQRT(VINT(308))
24630 KFRES=MINT(15)
24631 ISIDE=1
24632 ENDIF
24633 SIDESG=(-1D0)**(ISIDE-1)
24634
24635C...Copy incoming partons to documentation lines.
24636 DO 170 JT=1,2
24637 I1=MINT(83)+4+JT
24638 I2=MINT(84)+JT
24639 K(I1,1)=21
24640 K(I1,2)=K(I2,2)
24641 K(I1,3)=I1-2
24642 DO 150 J=1,5
24643 P(I1,J)=P(I2,J)
24644 150 CONTINUE
24645
24646C...Second copy for partons before ISR shower, since no such.
24647 I1=MINT(83)+2+JT
24648 K(I1,1)=21
24649 K(I1,2)=K(I2,2)
24650 K(I1,3)=I1-2
24651 DO 160 J=1,5
24652 P(I1,J)=P(I2,J)
24653 160 CONTINUE
24654 170 CONTINUE
24655
24656C...Define initial partons.
24657 NTRY=0
24658 180 NTRY=NTRY+1
24659 IF(NTRY.GT.100) THEN
24660 MINT(51)=1
24661 RETURN
24662 ENDIF
24663
24664C...Scattered quark in hadronic CM frame.
24665 I=MINT(83)+7
24666 K(IPU3,1)=3
24667 K(IPU3,2)=KFRES
24668 K(IPU3,3)=I
24669 P(IPU3,5)=PYMASS(KFRES)
24670 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
24671 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
24672 P(IPU3,5)=0D0
24673 K(I,1)=21
24674 K(I,2)=KFRES
24675 K(I,3)=MINT(83)+4+ISIDE
24676 P(I,3)=P(IPU3,3)
24677 P(I,4)=P(IPU3,4)
24678 P(I,5)=P(IPU3,5)
24679 N=IPU3
24680 MINT(21)=KFRES
24681 MINT(22)=0
24682
24683C...No primordial kT, or chosen according to truncated Gaussian or
24684C...exponential, or (for photon) predetermined or power law.
24685 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
24686 IF(MSTP(91).LE.0) THEN
24687 PT=0D0
24688 ELSEIF(MSTP(91).EQ.1) THEN
24689 PT=PARP(91)*SQRT(-LOG(PYR(0)))
24690 ELSE
24691 RPT1=PYR(0)
24692 RPT2=PYR(0)
24693 PT=-PARP(92)*LOG(RPT1*RPT2)
24694 ENDIF
24695 IF(PT.GT.PARP(93)) GOTO 190
24696 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
24697 PTA=SQRT(VINT(282+ISIDE))
24698 PTB=0D0
24699 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
24700 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
24701 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
24702 RPT1=PYR(0)
24703 RPT2=PYR(0)
24704 PTB=-PARP(99)*LOG(RPT1*RPT2)
24705 ENDIF
24706 IF(PTB.GT.PARP(100)) GOTO 190
24707 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
24708 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
24709 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
24710 IF(MSTP(93).LE.0) THEN
24711 PT=0D0
24712 ELSEIF(MSTP(93).EQ.1) THEN
24713 PT=PARP(99)*SQRT(-LOG(PYR(0)))
24714 ELSEIF(MSTP(93).EQ.2) THEN
24715 RPT1=PYR(0)
24716 RPT2=PYR(0)
24717 PT=-PARP(99)*LOG(RPT1*RPT2)
24718 ELSEIF(MSTP(93).EQ.3) THEN
24719 HA=PARP(99)**2
24720 HB=PARP(100)**2
24721 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
24722 ELSE
24723 HA=PARP(99)**2
24724 HB=PARP(100)**2
24725 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
24726 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
24727 ENDIF
24728 IF(PT.GT.PARP(100)) GOTO 190
24729 ELSE
24730 PT=0D0
24731 ENDIF
24732 VINT(156+ISIDE)=PT
24733 PHI=PARU(2)*PYR(0)
24734 P(IPU3,1)=PT*COS(PHI)
24735 P(IPU3,2)=PT*SIN(PHI)
24736 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
24737 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
24738 PCP=P(IPU3,4)+ABS(P(IPU3,3))
24739
24740C...Find one or two beam remnants.
24741 MINT(105)=MINT(102+ISIDE)
24742 MINT(109)=MINT(106+ISIDE)
24743 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
24744 IF(MINT(51).NE.0) THEN
24745 MINT(51)=0
24746 GOTO 180
24747 ENDIF
24748
24749C...Store first remnant parton, with colour info and kinematics.
24750 I=N+1
24751 K(I,1)=1
24752 K(I,2)=KFLSP
24753 K(I,3)=MINT(83)+ISIDE
24754 P(I,5)=PYMASS(K(I,2))
24755 KCOL=KCHG(PYCOMP(KFLSP),2)
24756 IF(KCOL.NE.0) THEN
24757 K(I,1)=3
24758 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
24759 K(I,KFLS+3)=MSTU(5)*IPU3
24760 K(IPU3,6-KFLS)=MSTU(5)*I
24761 ICOLR=I
24762 ENDIF
24763 IF(KFLCH.EQ.0) THEN
24764 P(I,1)=-P(IPU3,1)
24765 P(I,2)=-P(IPU3,2)
24766 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24767 P(I,3)=-P(IPU3,3)
24768 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
24769 PRP=P(I,4)+ABS(P(I,3))
24770
24771C...When extra remnant parton or hadron: store extra remnant.
24772 ELSE
24773 I=I+1
24774 K(I,1)=1
24775 K(I,2)=KFLCH
24776 K(I,3)=MINT(83)+ISIDE
24777 P(I,5)=PYMASS(K(I,2))
24778 KCOL=KCHG(PYCOMP(KFLCH),2)
24779 IF(KCOL.NE.0) THEN
24780 K(I,1)=3
24781 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
24782 K(I,KFLS+3)=MSTU(5)*IPU3
24783 K(IPU3,6-KFLS)=MSTU(5)*I
24784 ICOLR=I
24785 ENDIF
24786
24787C...Relative transverse momentum when two remnants.
24788 LOOP=0
24789 200 LOOP=LOOP+1
24790 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
24791 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
24792 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
24793 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
24794 P(I,1)=-P(IPU3,1)-P(I-1,1)
24795 P(I,2)=-P(IPU3,2)-P(I-1,2)
24796 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24797
24798C...Relative distribution of energy for particle into jet plus particle.
24799 IMB=1
24800 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
24801 IF(MSTP(94).LE.1) THEN
24802 IF(IMB.EQ.1) CHI=PYR(0)
24803 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
24804 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24805 ELSEIF(MSTP(94).EQ.2) THEN
24806 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
24807 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24808 ELSEIF(MSTP(94).EQ.3) THEN
24809 CALL PYZDIS(1,0,PMS(4),ZZ)
24810 CHI=ZZ
24811 ELSE
24812 CALL PYZDIS(1000,0,PMS(4),ZZ)
24813 CHI=ZZ
24814 ENDIF
24815
24816C...Construct total transverse mass; reject if too large.
24817 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
24818 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
24819 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
24820 IF(LOOP.LT.10) GOTO 200
24821 GOTO 180
24822 ENDIF
24823 VINT(158+ISIDE)=CHI
24824
24825C...Subdivide longitudinal momentum according to value selected above.
24826 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
24827 PW1=(1D0-CHI)*PRP
24828 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
24829 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
24830 PW2=CHI*PRP
24831 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
24832 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
24833 ENDIF
24834 N=I
24835
24836C...Boost current and remnant systems to correct frame.
24837 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
24838 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
24839 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
24840 &(2D0*VINT(1)*PCP)
24841 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
24842 &(2D0*VINT(1)*PRP)
24843 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
24844 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
24845 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
24846 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
24847
24848C...Let current quark shower; recoil but no showering by colour partner.
24849 QMAX=2D0*SQRT(VINT(309-ISIDE))
24850 MSTJ48=MSTJ(48)
24851 MSTJ(48)=1
24852 PARJ86=PARJ(86)
24853 PARJ(86)=0D0
24854 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
24855 MSTJ(48)=MSTJ48
24856 PARJ(86)=PARJ86
24857
24858 RETURN
24859 END
24860
24861C*********************************************************************
24862
24863C...PYDOCU
24864C...Handles the documentation of the process in MSTI and PARI,
24865C...and also computes cross-sections based on accumulated statistics.
24866
24867 SUBROUTINE PYDOCU
24868
24869C...Double precision and integer declarations.
24870 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24871 IMPLICIT INTEGER(I-N)
24872 INTEGER PYK,PYCHGE,PYCOMP
24873C...Commonblocks.
24874 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24875 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24876 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24877 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24878 COMMON/PYINT1/MINT(400),VINT(400)
24879 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24880 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
24881 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
24882 &/PYINT5/
24883
24884C...Calculate Monte Carlo estimates of cross-sections.
24885 ISUB=MINT(1)
24886 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
24887 NGEN(0,3)=NGEN(0,3)+1
24888 XSEC(0,3)=0D0
24889 DO 100 I=1,500
24890 IF(I.EQ.96.OR.I.EQ.97) THEN
24891 XSEC(I,3)=0D0
24892 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
24893 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
24894 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24895 & DBLE(NGEN(96,2)))
24896 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
24897 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24898 & DBLE(NGEN(96,2)))
24899 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
24900 XSEC(I,3)=0D0
24901 ELSEIF(NGEN(I,2).EQ.0) THEN
24902 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
24903 & DBLE(NGEN(0,2)))
24904 ELSE
24905 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
24906 & DBLE(NGEN(I,2)))
24907 ENDIF
24908 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
24909 100 CONTINUE
24910
24911C...Rescale to known low-pT cross-section for standard QCD processes.
24912 IF(MSUB(95).EQ.1) THEN
24913 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
24914 & XSEC(68,3)+XSEC(95,3)
24915 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
24916 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
24917 FAC=XSECW/XSECH
24918 XSEC(11,3)=FAC*XSEC(11,3)
24919 XSEC(12,3)=FAC*XSEC(12,3)
24920 XSEC(13,3)=FAC*XSEC(13,3)
24921 XSEC(28,3)=FAC*XSEC(28,3)
24922 XSEC(53,3)=FAC*XSEC(53,3)
24923 XSEC(68,3)=FAC*XSEC(68,3)
24924 XSEC(95,3)=FAC*XSEC(95,3)
24925 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
24926 ENDIF
24927 ENDIF
24928
24929C...Save information for gamma-p and gamma-gamma.
24930 IF(MINT(121).GT.1) THEN
24931 IGA=MINT(122)
24932 CALL PYSAVE(2,IGA)
24933 CALL PYSAVE(5,0)
24934 ENDIF
24935
24936C...Reset information on hard interaction.
24937 DO 110 J=1,200
24938 MSTI(J)=0
24939 PARI(J)=0D0
24940 110 CONTINUE
24941
24942C...Copy integer valued information from MINT into MSTI.
24943 DO 120 J=1,32
24944 MSTI(J)=MINT(J)
24945 120 CONTINUE
24946 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
24947
24948C...Store cross-section variables in PARI.
24949 PARI(1)=XSEC(0,3)
24950 PARI(2)=XSEC(0,3)/MINT(5)
24951 PARI(7)=VINT(97)
24952 PARI(9)=VINT(99)
24953 PARI(10)=VINT(100)
24954 VINT(98)=VINT(98)+VINT(100)
24955 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
24956
24957C...Store kinematics variables in PARI.
24958 PARI(11)=VINT(1)
24959 PARI(12)=VINT(2)
24960 IF(ISUB.NE.95) THEN
24961 DO 130 J=13,26
24962 PARI(J)=VINT(30+J)
24963 130 CONTINUE
24964 PARI(29)=VINT(39)
24965 PARI(30)=VINT(40)
24966 PARI(31)=VINT(141)
24967 PARI(32)=VINT(142)
24968 PARI(33)=VINT(41)
24969 PARI(34)=VINT(42)
24970 PARI(35)=PARI(33)-PARI(34)
24971 PARI(36)=VINT(21)
24972 PARI(37)=VINT(22)
24973 PARI(38)=VINT(26)
24974 PARI(39)=VINT(157)
24975 PARI(40)=VINT(158)
24976 PARI(41)=VINT(23)
24977 PARI(42)=2D0*VINT(47)/VINT(1)
24978 ENDIF
24979
24980C...Store information on scattered partons in PARI.
24981 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
24982 DO 140 IS=7,8
24983 I=MINT(IS)
24984 PARI(36+IS)=P(I,3)/VINT(1)
24985 PARI(38+IS)=P(I,4)/VINT(1)
24986 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
24987 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24988 & SQRT(PR),1D20)),P(I,3))
24989 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
24990 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24991 & SQRT(PR),1D20)),P(I,3))
24992 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
24993 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
24994 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
24995 140 CONTINUE
24996 ENDIF
24997
24998C...Store sum up transverse and longitudinal momenta.
24999 PARI(65)=2D0*PARI(17)
25000 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
25001 DO 150 I=MSTP(126)+1,N
25002 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
25003 PT=SQRT(P(I,1)**2+P(I,2)**2)
25004 PARI(69)=PARI(69)+PT
25005 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
25006 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
25007 150 CONTINUE
25008 PARI(67)=PARI(68)
25009 PARI(71)=VINT(151)
25010 PARI(72)=VINT(152)
25011 PARI(73)=VINT(151)
25012 PARI(74)=VINT(152)
25013 ELSE
25014 PARI(66)=PARI(65)
25015 PARI(69)=PARI(65)
25016 ENDIF
25017
25018C...Store various other pieces of information into PARI.
25019 PARI(61)=VINT(148)
25020 PARI(75)=VINT(155)
25021 PARI(76)=VINT(156)
25022 PARI(77)=VINT(159)
25023 PARI(78)=VINT(160)
25024 PARI(81)=VINT(138)
25025
25026C...Store information on lepton -> lepton + gamma in PYGAGA.
25027 MSTI(71)=MINT(141)
25028 MSTI(72)=MINT(142)
25029 PARI(101)=VINT(301)
25030 PARI(102)=VINT(302)
25031 DO 160 I=103,114
25032 PARI(I)=VINT(I+202)
25033 160 CONTINUE
25034
25035C...Set information for PYTABU.
25036 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
25037 MSTU(161)=MINT(21)
25038 MSTU(162)=0
25039 ELSEIF(ISET(ISUB).EQ.5) THEN
25040 MSTU(161)=MINT(23)
25041 MSTU(162)=0
25042 ELSE
25043 MSTU(161)=MINT(21)
25044 MSTU(162)=MINT(22)
25045 ENDIF
25046
25047 RETURN
25048 END
25049
25050C*********************************************************************
25051
25052C...PYFRAM
25053C...Performs transformations between different coordinate frames.
25054
25055 SUBROUTINE PYFRAM(IFRAME)
25056
25057C...Double precision and integer declarations.
25058 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25059 IMPLICIT INTEGER(I-N)
25060 INTEGER PYK,PYCHGE,PYCOMP
25061C...Commonblocks.
25062 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25063 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25064 COMMON/PYINT1/MINT(400),VINT(400)
25065 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
25066
25067C...Check that transformation can and should be done.
25068 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
25069 &MINT(91).EQ.1)) THEN
25070 IF(IFRAME.EQ.MINT(6)) RETURN
25071 ELSE
25072 WRITE(MSTU(11),5000) IFRAME,MINT(6)
25073 RETURN
25074 ENDIF
25075
25076 IF(MINT(6).EQ.1) THEN
25077C...Transform from fixed target or user specified frame to
25078C...overall CM frame.
25079 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
25080 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
25081 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
25082 ELSEIF(MINT(6).EQ.3) THEN
25083C...Transform from hadronic CM frame in DIS to overall CM frame.
25084 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
25085 & -VINT(225))
25086 ENDIF
25087
25088 IF(IFRAME.EQ.1) THEN
25089C...Transform from overall CM frame to fixed target or user specified
25090C...frame.
25091 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
25092 ELSEIF(IFRAME.EQ.3) THEN
25093C...Transform from overall CM frame to hadronic CM frame in DIS.
25094 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
25095 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
25096 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
25097 ENDIF
25098
25099C...Set information about new frame.
25100 MINT(6)=IFRAME
25101 MSTI(6)=IFRAME
25102
25103 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
25104 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
25105 &1X,I5)
25106
25107 RETURN
25108 END
25109
25110C*********************************************************************
25111
25112C...PYWIDT
25113C...Calculates full and partial widths of resonances.
25114
25115 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
25116
25117C...Double precision and integer declarations.
25118 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25119 IMPLICIT INTEGER(I-N)
25120 INTEGER PYK,PYCHGE,PYCOMP
25121C...Parameter statement to help give large particle numbers.
25122 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
25123 &KEXCIT=4000000,KDIMEN=5000000)
25124C...Commonblocks.
25125 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25126 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25127 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
25128 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
25129 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25130 COMMON/PYINT1/MINT(400),VINT(400)
25131 COMMON/PYINT4/MWID(500),WIDS(500,5)
25132 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
25133 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
25134 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
25135 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
25136 COMMON/PYPUED/IUED(0:99),RUED(0:99)
25137 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
25138 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/
25139C...Local arrays and saved variables.
25140 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
25141 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
25142 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
25143C...UED: equivalences between ordered particles (451->475)
25144C...and UED particle code (5 000 000 + id)
25145 PARAMETER(KKFLMI=451,KKFLMA=475)
25146 DIMENSION CHIDEL(3), IUEDPR(25)
25147 DIMENSION IUEDEQ(KKFLMA),MUED(2)
25148 COMMON/SW1/SW21,CW21
25149 DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/
25150 & 6100001,6100002,6100003,6100004,6100005,6100006,
25151 & 5100001,5100002,5100003,5100004,5100005,5100006,
25152 & 6100011,6100013,6100015,
25153 & 5100012,5100011,5100014,5100013,5100016,5100015,
25154 & 5100021,5100022,5100023,5100024/
25155C...Save local variables
25156 SAVE MOFSV,WIDWSV,WID2SV
25157C...Initial values
25158 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
25159 DATA CHIDEL/1.1D-03,1.D0,7.4D+2/
25160 DATA IUEDPR/25*0/
25161C...UED: inline functions used in kk width calculus
25162 FKAC1(X,Y)=1.-X**2/Y**2
25163 FKAC2(X,Y)=2.+X**2/Y**2
25164
25165C...Compressed code and sign; mass.
25166 KFLA=IABS(KFLR)
25167 KFLS=ISIGN(1,KFLR)
25168 KC=PYCOMP(KFLA)
25169 SHR=SQRT(SH)
25170 PMR=PMAS(KC,1)
25171
25172C...Reset width information.
25173 DO 110 I=0,MDCY(KC,3)
25174 WDTP(I)=0D0
25175 DO 100 J=0,5
25176 WDTE(I,J)=0D0
25177 100 CONTINUE
25178 110 CONTINUE
25179
25180C...Allow for fudge factor to rescale resonance width.
25181 FUDGE=1D0
25182 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
25183 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
25184 IF(MSTP(110).EQ.KFLA) THEN
25185 FUDGE=PARP(110)
25186 ELSEIF(MSTP(110).EQ.-1) THEN
25187 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
25188 ELSEIF(MSTP(110).EQ.-2) THEN
25189 FUDGE=PARP(110)
25190 ENDIF
25191 ENDIF
25192
25193C...Not to be treated as a resonance: return.
25194 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
25195 &KFLA.NE.22) THEN
25196 WDTP(0)=1D0
25197 WDTE(0,0)=1D0
25198 MINT(61)=0
25199 MINT(62)=0
25200 MINT(63)=0
25201 RETURN
25202
25203C...Treatment as a resonance based on tabulated branching ratios.
25204 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
25205C...Loop over possible decay channels; skip irrelevant ones.
25206 DO 120 I=1,MDCY(KC,3)
25207 IDC=I+MDCY(KC,2)-1
25208 IF(MDME(IDC,1).LT.0) GOTO 120
25209
25210C...Read out decay products and nominal masses.
25211 KFD1=KFDP(IDC,1)
25212 KFC1=PYCOMP(KFD1)
25213C...Skip dummy modes or unrecognized particles
25214 IF (KFD1.EQ.0.OR.KFC1.EQ.0) GOTO 120
25215 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
25216 PM1=PMAS(KFC1,1)
25217 KFD2=KFDP(IDC,2)
25218 KFC2=PYCOMP(KFD2)
25219 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
25220 PM2=PMAS(KFC2,1)
25221 KFD3=KFDP(IDC,3)
25222 PM3=0D0
25223 IF(KFD3.NE.0) THEN
25224 KFC3=PYCOMP(KFD3)
25225 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
25226 PM3=PMAS(KFC3,1)
25227 ENDIF
25228
25229C...Naive partial width and alternative threshold factors.
25230 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
25231 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
25232 & PM1+PM2+PM3.GE.SHR) THEN
25233 WDTP(I)=0D0
25234 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
25235 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
25236 & 4D0*PM1**2*PM2**2))/SH
25237 ELSEIF(MDME(IDC,2).EQ.52) THEN
25238 PMA=MAX(PM1,PM2,PM3)
25239 PMC=MIN(PM1,PM2,PM3)
25240 PMB=PM1+PM2+PM3-PMA-PMC
25241 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
25242 PMAN=PMA**2/SH
25243 PMBN=PMB**2/SH
25244 PMCN=PMC**2/SH
25245 PMBCN=PMBC**2/SH
25246 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
25247 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
25248 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
25249 & ((SHR-PMA)**2-(PMB+PMC)**2)*
25250 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
25251 & ((1D0-PMBCN)*PMBCN*SH)
25252 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
25253 WDTP(I)=WDTP(I)*SQRT(
25254 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
25255 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
25256 ELSEIF(MDME(IDC,2).EQ.53) THEN
25257 PMA=MAX(PM1,PM2,PM3)
25258 PMC=MIN(PM1,PM2,PM3)
25259 PMB=PM1+PM2+PM3-PMA-PMC
25260 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
25261 PMAN=PMA**2/SH
25262 PMBN=PMB**2/SH
25263 PMCN=PMC**2/SH
25264 PMBCN=PMBC**2/SH
25265 FACACT=SQRT(MAX(0D0,
25266 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
25267 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
25268 & ((SHR-PMA)**2-(PMB+PMC)**2)*
25269 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
25270 & ((1D0-PMBCN)*PMBCN*SH)
25271 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
25272 PMAN=PMA**2/PMR**2
25273 PMBN=PMB**2/PMR**2
25274 PMCN=PMC**2/PMR**2
25275 PMBCN=PMBC**2/PMR**2
25276 FACNOM=SQRT(MAX(0D0,
25277 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
25278 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
25279 & ((PMR-PMA)**2-(PMB+PMC)**2)*
25280 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
25281 & ((1D0-PMBCN)*PMBCN*PMR**2)
25282 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
25283 ENDIF
25284 WDTP(I)=FUDGE*WDTP(I)
25285 WDTP(0)=WDTP(0)+WDTP(I)
25286
25287C...Calculate secondary width (at most two identical/opposite).
25288 WID2=1D0
25289 IF(MDME(IDC,1).GT.0) THEN
25290 IF(KFD2.EQ.KFD1) THEN
25291 IF(KCHG(KFC1,3).EQ.0) THEN
25292 WID2=WIDS(KFC1,1)
25293 ELSEIF(KFD1.GT.0) THEN
25294 WID2=WIDS(KFC1,4)
25295 ELSE
25296 WID2=WIDS(KFC1,5)
25297 ENDIF
25298 IF(KFD3.GT.0) THEN
25299 WID2=WID2*WIDS(KFC3,2)
25300 ELSEIF(KFD3.LT.0) THEN
25301 WID2=WID2*WIDS(KFC3,3)
25302 ENDIF
25303 ELSEIF(KFD2.EQ.-KFD1) THEN
25304 WID2=WIDS(KFC1,1)
25305 IF(KFD3.GT.0) THEN
25306 WID2=WID2*WIDS(KFC3,2)
25307 ELSEIF(KFD3.LT.0) THEN
25308 WID2=WID2*WIDS(KFC3,3)
25309 ENDIF
25310 ELSEIF(KFD3.EQ.KFD1) THEN
25311 IF(KCHG(KFC1,3).EQ.0) THEN
25312 WID2=WIDS(KFC1,1)
25313 ELSEIF(KFD1.GT.0) THEN
25314 WID2=WIDS(KFC1,4)
25315 ELSE
25316 WID2=WIDS(KFC1,5)
25317 ENDIF
25318 IF(KFD2.GT.0) THEN
25319 WID2=WID2*WIDS(KFC2,2)
25320 ELSEIF(KFD2.LT.0) THEN
25321 WID2=WID2*WIDS(KFC2,3)
25322 ENDIF
25323 ELSEIF(KFD3.EQ.-KFD1) THEN
25324 WID2=WIDS(KFC1,1)
25325 IF(KFD2.GT.0) THEN
25326 WID2=WID2*WIDS(KFC2,2)
25327 ELSEIF(KFD2.LT.0) THEN
25328 WID2=WID2*WIDS(KFC2,3)
25329 ENDIF
25330 ELSEIF(KFD3.EQ.KFD2) THEN
25331 IF(KCHG(KFC2,3).EQ.0) THEN
25332 WID2=WIDS(KFC2,1)
25333 ELSEIF(KFD2.GT.0) THEN
25334 WID2=WIDS(KFC2,4)
25335 ELSE
25336 WID2=WIDS(KFC2,5)
25337 ENDIF
25338 IF(KFD1.GT.0) THEN
25339 WID2=WID2*WIDS(KFC1,2)
25340 ELSEIF(KFD1.LT.0) THEN
25341 WID2=WID2*WIDS(KFC1,3)
25342 ENDIF
25343 ELSEIF(KFD3.EQ.-KFD2) THEN
25344 WID2=WIDS(KFC2,1)
25345 IF(KFD1.GT.0) THEN
25346 WID2=WID2*WIDS(KFC1,2)
25347 ELSEIF(KFD1.LT.0) THEN
25348 WID2=WID2*WIDS(KFC1,3)
25349 ENDIF
25350 ELSE
25351 IF(KFD1.GT.0) THEN
25352 WID2=WIDS(KFC1,2)
25353 ELSE
25354 WID2=WIDS(KFC1,3)
25355 ENDIF
25356 IF(KFD2.GT.0) THEN
25357 WID2=WID2*WIDS(KFC2,2)
25358 ELSE
25359 WID2=WID2*WIDS(KFC2,3)
25360 ENDIF
25361 IF(KFD3.GT.0) THEN
25362 WID2=WID2*WIDS(KFC3,2)
25363 ELSEIF(KFD3.LT.0) THEN
25364 WID2=WID2*WIDS(KFC3,3)
25365 ENDIF
25366 ENDIF
25367
25368C...Store effective widths according to case.
25369 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25370 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25371 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25372 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25373 ENDIF
25374 120 CONTINUE
25375C...Return.
25376 MINT(61)=0
25377 MINT(62)=0
25378 MINT(63)=0
25379 RETURN
25380 ENDIF
25381
25382C...Here begins detailed dynamical calculation of resonance widths.
25383C...Shared treatment of Higgs states.
25384 KFHIGG=25
25385 IHIGG=1
25386 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
25387 KFHIGG=KFLA
25388 IHIGG=KFLA-33
25389 ENDIF
25390
25391C...Common electroweak and strong constants.
25392 XW=PARU(102)
25393 XWV=XW
25394 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
25395 XW1=1D0-XW
25396 AEM=PYALEM(SH)
25397 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
25398 AS=PYALPS(SH)
25399 RADC=1D0+AS/PARU(1)
25400
25401 IF(KFLA.EQ.6) THEN
25402C...t quark.
25403 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25404 RADCT=1D0-2.5D0*AS/PARU(1)
25405 DO 140 I=1,MDCY(KC,3)
25406 IDC=I+MDCY(KC,2)-1
25407 IF(MDME(IDC,1).LT.0) GOTO 140
25408 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25409 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25410 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
25411 WID2=1D0
25412 IF(I.GE.4.AND.I.LE.7) THEN
25413C...t -> W + q; including approximate QCD correction factor.
25414 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
25415 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25416 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25417 IF(KFLR.GT.0) THEN
25418 WID2=WIDS(24,2)
25419 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
25420 ELSE
25421 WID2=WIDS(24,3)
25422 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
25423 ENDIF
25424 ELSEIF(I.EQ.9) THEN
25425C...t -> H + b.
25426 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25427 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25428 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
25429 & 4D0*SQRT(RM2R*RM2))
25430 WID2=WIDS(37,2)
25431 IF(KFLR.LT.0) WID2=WIDS(37,3)
25432CMRENNA++
25433 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
25434C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
25435 BETA=ATAN(RMSS(5))
25436 SINB=SIN(BETA)
25437 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
25438 ET=KCHG(6,1)/3D0
25439 T3L=SIGN(0.5D0,ET)
25440 KFC1=PYCOMP(KFDP(IDC,1))
25441 KFC2=PYCOMP(KFDP(IDC,2))
25442 PMNCHI=PMAS(KFC1,1)
25443 PMSTOP=PMAS(KFC2,1)
25444 IF(SHR.GT.PMNCHI+PMSTOP) THEN
25445 IZ=I-9
25446 DO 130 IK=1,4
25447 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
25448 130 CONTINUE
25449 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
25450 AR=-ET*ZMIXC(IZ,1)*TANW
25451 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
25452 BR=AL
25453 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
25454 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
25455 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
25456 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
25457 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
25458 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
25459 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
25460 IF(KFLR.GT.0) THEN
25461 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
25462 ELSE
25463 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
25464 ENDIF
25465 ENDIF
25466 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
25467C...t -> ~g + ~t
25468 KFC1=PYCOMP(KFDP(IDC,1))
25469 KFC2=PYCOMP(KFDP(IDC,2))
25470 PMNCHI=PMAS(KFC1,1)
25471 PMSTOP=PMAS(KFC2,1)
25472 IF(SHR.GT.PMNCHI+PMSTOP) THEN
25473 RL=SFMIX(6,1)
25474 RR=-SFMIX(6,2)
25475 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
25476 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
25477 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
25478 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
25479 IF(KFLR.GT.0) THEN
25480 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
25481 ELSE
25482 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
25483 ENDIF
25484 ENDIF
25485 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
25486C...t -> ~gravitino + ~t
25487 XMP2=RMSS(29)**2
25488 KFC1=PYCOMP(KFDP(IDC,1))
25489 XMGR2=PMAS(KFC1,1)**2
25490 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
25491 KFC2=PYCOMP(KFDP(IDC,2))
25492 WID2=WIDS(KFC2,2)
25493 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
25494CMRENNA--
25495 ENDIF
25496 WDTP(I)=FUDGE*WDTP(I)
25497 WDTP(0)=WDTP(0)+WDTP(I)
25498 IF(MDME(IDC,1).GT.0) THEN
25499 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25500 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25501 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25502 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25503 ENDIF
25504 140 CONTINUE
25505
25506 ELSEIF(KFLA.EQ.7) THEN
25507C...b' quark.
25508 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25509 DO 150 I=1,MDCY(KC,3)
25510 IDC=I+MDCY(KC,2)-1
25511 IF(MDME(IDC,1).LT.0) GOTO 150
25512 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25513 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25514 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
25515 WID2=1D0
25516 IF(I.GE.4.AND.I.LE.7) THEN
25517C...b' -> W + q.
25518 WDTP(I)=FAC*VCKM(I-3,4)*
25519 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25520 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25521 IF(KFLR.GT.0) THEN
25522 WID2=WIDS(24,3)
25523 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
25524 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
25525 ELSE
25526 WID2=WIDS(24,2)
25527 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
25528 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
25529 ENDIF
25530 WID2=WIDS(24,3)
25531 IF(KFLR.LT.0) WID2=WIDS(24,2)
25532 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
25533C...b' -> H + q.
25534 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25535 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
25536 IF(KFLR.GT.0) THEN
25537 WID2=WIDS(37,3)
25538 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
25539 ELSE
25540 WID2=WIDS(37,2)
25541 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
25542 ENDIF
25543 ENDIF
25544 WDTP(I)=FUDGE*WDTP(I)
25545 WDTP(0)=WDTP(0)+WDTP(I)
25546 IF(MDME(IDC,1).GT.0) THEN
25547 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25548 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25549 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25550 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25551 ENDIF
25552 150 CONTINUE
25553
25554 ELSEIF(KFLA.EQ.8) THEN
25555C...t' quark.
25556 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25557 DO 160 I=1,MDCY(KC,3)
25558 IDC=I+MDCY(KC,2)-1
25559 IF(MDME(IDC,1).LT.0) GOTO 160
25560 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25561 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25562 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
25563 WID2=1D0
25564 IF(I.GE.4.AND.I.LE.7) THEN
25565C...t' -> W + q.
25566 WDTP(I)=FAC*VCKM(4,I-3)*
25567 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25568 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25569 IF(KFLR.GT.0) THEN
25570 WID2=WIDS(24,2)
25571 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
25572 ELSE
25573 WID2=WIDS(24,3)
25574 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
25575 ENDIF
25576 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
25577C...t' -> H + q.
25578 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25579 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
25580 IF(KFLR.GT.0) THEN
25581 WID2=WIDS(37,2)
25582 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
25583 ELSE
25584 WID2=WIDS(37,3)
25585 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
25586 ENDIF
25587 ENDIF
25588 WDTP(I)=FUDGE*WDTP(I)
25589 WDTP(0)=WDTP(0)+WDTP(I)
25590 IF(MDME(IDC,1).GT.0) THEN
25591 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25592 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25593 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25594 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25595 ENDIF
25596 160 CONTINUE
25597
25598 ELSEIF(KFLA.EQ.17) THEN
25599C...tau' lepton.
25600 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25601 DO 170 I=1,MDCY(KC,3)
25602 IDC=I+MDCY(KC,2)-1
25603 IF(MDME(IDC,1).LT.0) GOTO 170
25604 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25605 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25606 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
25607 WID2=1D0
25608 IF(I.EQ.3) THEN
25609C...tau' -> W + nu'_tau.
25610 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25611 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25612 IF(KFLR.GT.0) THEN
25613 WID2=WIDS(24,3)
25614 WID2=WID2*WIDS(18,2)
25615 ELSE
25616 WID2=WIDS(24,2)
25617 WID2=WID2*WIDS(18,3)
25618 ENDIF
25619 ELSEIF(I.EQ.5) THEN
25620C...tau' -> H + nu'_tau.
25621 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25622 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
25623 IF(KFLR.GT.0) THEN
25624 WID2=WIDS(37,3)
25625 WID2=WID2*WIDS(18,2)
25626 ELSE
25627 WID2=WIDS(37,2)
25628 WID2=WID2*WIDS(18,3)
25629 ENDIF
25630 ENDIF
25631 WDTP(I)=FUDGE*WDTP(I)
25632 WDTP(0)=WDTP(0)+WDTP(I)
25633 IF(MDME(IDC,1).GT.0) THEN
25634 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25635 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25636 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25637 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25638 ENDIF
25639 170 CONTINUE
25640
25641 ELSEIF(KFLA.EQ.18) THEN
25642C...nu'_tau neutrino.
25643 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25644 DO 180 I=1,MDCY(KC,3)
25645 IDC=I+MDCY(KC,2)-1
25646 IF(MDME(IDC,1).LT.0) GOTO 180
25647 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25648 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25649 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
25650 WID2=1D0
25651 IF(I.EQ.2) THEN
25652C...nu'_tau -> W + tau'.
25653 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25654 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25655 IF(KFLR.GT.0) THEN
25656 WID2=WIDS(24,2)
25657 WID2=WID2*WIDS(17,2)
25658 ELSE
25659 WID2=WIDS(24,3)
25660 WID2=WID2*WIDS(17,3)
25661 ENDIF
25662 ELSEIF(I.EQ.3) THEN
25663C...nu'_tau -> H + tau'.
25664 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25665 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
25666 IF(KFLR.GT.0) THEN
25667 WID2=WIDS(37,2)
25668 WID2=WID2*WIDS(17,2)
25669 ELSE
25670 WID2=WIDS(37,3)
25671 WID2=WID2*WIDS(17,3)
25672 ENDIF
25673 ENDIF
25674 WDTP(I)=FUDGE*WDTP(I)
25675 WDTP(0)=WDTP(0)+WDTP(I)
25676 IF(MDME(IDC,1).GT.0) THEN
25677 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25678 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25679 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25680 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25681 ENDIF
25682 180 CONTINUE
25683
25684 ELSEIF(KFLA.EQ.21) THEN
25685C...QCD:
25686C***Note that widths are not given in dimensional quantities here.
25687 DO 190 I=1,MDCY(KC,3)
25688 IDC=I+MDCY(KC,2)-1
25689 IF(MDME(IDC,1).LT.0) GOTO 190
25690 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25691 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25692 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
25693 WID2=1D0
25694 IF(I.LE.8) THEN
25695C...QCD -> q + qbar
25696 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25697 IF(I.EQ.6) WID2=WIDS(6,1)
25698 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25699 ENDIF
25700 WDTP(I)=FUDGE*WDTP(I)
25701 WDTP(0)=WDTP(0)+WDTP(I)
25702 IF(MDME(IDC,1).GT.0) THEN
25703 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25704 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25705 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25706 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25707 ENDIF
25708 190 CONTINUE
25709
25710 ELSEIF(KFLA.EQ.22) THEN
25711C...QED photon.
25712C***Note that widths are not given in dimensional quantities here.
25713 DO 200 I=1,MDCY(KC,3)
25714 IDC=I+MDCY(KC,2)-1
25715 IF(MDME(IDC,1).LT.0) GOTO 200
25716 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25717 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25718 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
25719 WID2=1D0
25720 IF(I.LE.8) THEN
25721C...QED -> q + qbar.
25722 EF=KCHG(I,1)/3D0
25723 FCOF=3D0*RADC
25724 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25725 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25726 IF(I.EQ.6) WID2=WIDS(6,1)
25727 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25728 ELSEIF(I.LE.12) THEN
25729C...QED -> l+ + l-.
25730 EF=KCHG(9+2*(I-8),1)/3D0
25731 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25732 IF(I.EQ.12) WID2=WIDS(17,1)
25733 ENDIF
25734 WDTP(I)=FUDGE*WDTP(I)
25735 WDTP(0)=WDTP(0)+WDTP(I)
25736 IF(MDME(IDC,1).GT.0) THEN
25737 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25738 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25739 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25740 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25741 ENDIF
25742 200 CONTINUE
25743
25744 ELSEIF(KFLA.EQ.23) THEN
25745C...Z0:
25746 ICASE=1
25747 XWC=1D0/(16D0*XW*XW1)
25748 FAC=(AEM*XWC/3D0)*SHR
25749 210 CONTINUE
25750 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25751 VINT(111)=0D0
25752 VINT(112)=0D0
25753 VINT(114)=0D0
25754 ENDIF
25755 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25756 KFI=IABS(MINT(15))
25757 IF(KFI.GT.20) KFI=IABS(MINT(16))
25758 EI=KCHG(KFI,1)/3D0
25759 AI=SIGN(1D0,EI)
25760 VI=AI-4D0*EI*XWV
25761 SQMZ=PMAS(23,1)**2
25762 HZ=SHR*WDTP(0)
25763 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
25764 IF(MSTP(43).EQ.3) VINT(112)=
25765 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25766 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25767 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25768 ENDIF
25769 DO 220 I=1,MDCY(KC,3)
25770 IDC=I+MDCY(KC,2)-1
25771 IF(MDME(IDC,1).LT.0) GOTO 220
25772 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25773 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25774 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
25775 WID2=1D0
25776 IF(I.LE.8) THEN
25777C...Z0 -> q + qbar
25778 EF=KCHG(I,1)/3D0
25779 AF=SIGN(1D0,EF+0.1D0)
25780 VF=AF-4D0*EF*XWV
25781 FCOF=3D0*RADC
25782 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25783 IF(I.EQ.6) WID2=WIDS(6,1)
25784 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25785 ELSEIF(I.LE.16) THEN
25786C...Z0 -> l+ + l-, nu + nubar
25787 EF=KCHG(I+2,1)/3D0
25788 AF=SIGN(1D0,EF+0.1D0)
25789 VF=AF-4D0*EF*XWV
25790 FCOF=1D0
25791 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25792 ENDIF
25793 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25794 IF(ICASE.EQ.1) THEN
25795 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
25796 & BE34
25797 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25798 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25799 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
25800 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
25801 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25802 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25803 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25804 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25805 ENDIF
25806 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
25807 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
25808 IF(MDME(IDC,1).GT.0) THEN
25809 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25810 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25811 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25812 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25813 & WDTE(I,MDME(IDC,1))
25814 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25815 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25816 ENDIF
25817 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25818 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
25819 & VINT(111)+FGGF*WID2
25820 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
25821 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25822 & VINT(114)+FZZF*WID2
25823 ENDIF
25824 ENDIF
25825 220 CONTINUE
25826 IF(MINT(61).GE.1) ICASE=3-ICASE
25827 IF(ICASE.EQ.2) GOTO 210
25828
25829 ELSEIF(KFLA.EQ.24) THEN
25830C...W+/-:
25831 FAC=(AEM/(24D0*XW))*SHR
25832 DO 230 I=1,MDCY(KC,3)
25833 IDC=I+MDCY(KC,2)-1
25834 IF(MDME(IDC,1).LT.0) GOTO 230
25835 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25836 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25837 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
25838 WID2=1D0
25839 IF(I.LE.16) THEN
25840C...W+/- -> q + qbar'
25841 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
25842 IF(KFLR.GT.0) THEN
25843 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25844 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25845 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25846 ELSE
25847 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25848 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25849 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25850 ENDIF
25851 ELSEIF(I.LE.20) THEN
25852C...W+/- -> l+/- + nu
25853 FCOF=1D0
25854 IF(KFLR.GT.0) THEN
25855 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25856 ELSE
25857 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25858 ENDIF
25859 ENDIF
25860 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25861 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25862 WDTP(I)=FUDGE*WDTP(I)
25863 WDTP(0)=WDTP(0)+WDTP(I)
25864 IF(MDME(IDC,1).GT.0) THEN
25865 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25866 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25867 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25868 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25869 ENDIF
25870 230 CONTINUE
25871
25872 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
25873C...h0 (or H0, or A0):
25874 SHFS=SH
25875 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25876 DO 270 I=1,MDCY(KFHIGG,3)
25877 IDC=I+MDCY(KFHIGG,2)-1
25878 IF(MDME(IDC,1).LT.0) GOTO 270
25879 KFC1=PYCOMP(KFDP(IDC,1))
25880 KFC2=PYCOMP(KFDP(IDC,2))
25881 RM1=PMAS(KFC1,1)**2/SH
25882 RM2=PMAS(KFC2,1)**2/SH
25883 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
25884 & GOTO 270
25885 WID2=1D0
25886
25887 IF(I.LE.8) THEN
25888C...h0 -> q + qbar
25889 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
25890 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
25891C...A0 behaves like beta, ho and H0 like beta**3.
25892 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25893 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25894 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
25895 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
25896 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
25897 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
25898 IF(IHIGG.NE.3) THEN
25899 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
25900 & PARU(151+10*IHIGG))**2
25901 ENDIF
25902 ENDIF
25903 ENDIF
25904 IF(I.EQ.6) WID2=WIDS(6,1)
25905 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25906 ELSEIF(I.LE.12) THEN
25907C...h0 -> l+ + l-
25908 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
25909C...A0 behaves like beta, ho and H0 like beta**3.
25910 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25911 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25912 & PARU(153+10*IHIGG)**2
25913 IF(I.EQ.12) WID2=WIDS(17,1)
25914
25915 ELSEIF(I.EQ.13) THEN
25916C...h0 -> g + g; quark loop contribution only
25917 ETARE=0D0
25918 ETAIM=0D0
25919 DO 240 J=1,2*MSTP(1)
25920 EPS=(2D0*PMAS(J,1))**2/SH
25921C...Loop integral; function of eps=4m^2/shat; different for A0.
25922 IF(EPS.LE.1D0) THEN
25923 IF(EPS.GT.1D-4) THEN
25924 ROOT=SQRT(1D0-EPS)
25925 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25926 ELSE
25927 RLN=LOG(4D0/EPS-2D0)
25928 ENDIF
25929 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25930 PHIIM=0.5D0*PARU(1)*RLN
25931 ELSE
25932 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25933 PHIIM=0D0
25934 ENDIF
25935 IF(IHIGG.LE.2) THEN
25936 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25937 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
25938 ELSE
25939 ETAREJ=-0.5D0*EPS*PHIRE
25940 ETAIMJ=-0.5D0*EPS*PHIIM
25941 ENDIF
25942C...Couplings (=1 for standard model Higgs).
25943 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25944 IF(MOD(J,2).EQ.1) THEN
25945 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
25946 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
25947 ELSE
25948 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
25949 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
25950 ENDIF
25951 ENDIF
25952 ETARE=ETARE+ETAREJ
25953 ETAIM=ETAIM+ETAIMJ
25954 240 CONTINUE
25955 ETA2=ETARE**2+ETAIM**2
25956 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
25957
25958 ELSEIF(I.EQ.14) THEN
25959C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
25960 ETARE=0D0
25961 ETAIM=0D0
25962 JMAX=3*MSTP(1)+1
25963 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25964 DO 250 J=1,JMAX
25965 IF(J.LE.2*MSTP(1)) THEN
25966 EJ=KCHG(J,1)/3D0
25967 EPS=(2D0*PMAS(J,1))**2/SH
25968 ELSEIF(J.LE.3*MSTP(1)) THEN
25969 JL=2*(J-2*MSTP(1))-1
25970 EJ=KCHG(10+JL,1)/3D0
25971 EPS=(2D0*PMAS(10+JL,1))**2/SH
25972 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25973 EPS=(2D0*PMAS(24,1))**2/SH
25974 ELSE
25975 EPS=(2D0*PMAS(37,1))**2/SH
25976 ENDIF
25977C...Loop integral; function of eps=4m^2/shat.
25978 IF(EPS.LE.1D0) THEN
25979 IF(EPS.GT.1D-4) THEN
25980 ROOT=SQRT(1D0-EPS)
25981 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25982 ELSE
25983 RLN=LOG(4D0/EPS-2D0)
25984 ENDIF
25985 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25986 PHIIM=0.5D0*PARU(1)*RLN
25987 ELSE
25988 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25989 PHIIM=0D0
25990 ENDIF
25991 IF(J.LE.3*MSTP(1)) THEN
25992C...Fermion loops: loop integral different for A0; charges.
25993 IF(IHIGG.LE.2) THEN
25994 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25995 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
25996 ELSE
25997 PHIPRE=-0.5D0*EPS*PHIRE
25998 PHIPIM=-0.5D0*EPS*PHIIM
25999 ENDIF
26000 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
26001 EJC=3D0*EJ**2
26002 EJH=PARU(151+10*IHIGG)
26003 ELSEIF(J.LE.2*MSTP(1)) THEN
26004 EJC=3D0*EJ**2
26005 EJH=PARU(152+10*IHIGG)
26006 ELSE
26007 EJC=EJ**2
26008 EJH=PARU(153+10*IHIGG)
26009 ENDIF
26010 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
26011 ETAREJ=EJC*EJH*PHIPRE
26012 ETAIMJ=EJC*EJH*PHIPIM
26013 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
26014C...W loops: loop integral and charges.
26015 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
26016 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
26017 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
26018 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
26019 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
26020 ENDIF
26021 ELSE
26022C...Charged H loops: loop integral and charges.
26023 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
26024 & PARU(158+10*IHIGG+2*(IHIGG/3))
26025 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
26026 ETAIMJ=-EPS**2*PHIIM*FACHHH
26027 ENDIF
26028 ETARE=ETARE+ETAREJ
26029 ETAIM=ETAIM+ETAIMJ
26030 250 CONTINUE
26031 ETA2=ETARE**2+ETAIM**2
26032 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
26033
26034 ELSEIF(I.EQ.15) THEN
26035C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
26036 ETARE=0D0
26037 ETAIM=0D0
26038 JMAX=3*MSTP(1)+1
26039 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
26040 DO 260 J=1,JMAX
26041 IF(J.LE.2*MSTP(1)) THEN
26042 EJ=KCHG(J,1)/3D0
26043 AJ=SIGN(1D0,EJ+0.1D0)
26044 VJ=AJ-4D0*EJ*XWV
26045 EPS=(2D0*PMAS(J,1))**2/SH
26046 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
26047 ELSEIF(J.LE.3*MSTP(1)) THEN
26048 JL=2*(J-2*MSTP(1))-1
26049 EJ=KCHG(10+JL,1)/3D0
26050 AJ=SIGN(1D0,EJ+0.1D0)
26051 VJ=AJ-4D0*EJ*XWV
26052 EPS=(2D0*PMAS(10+JL,1))**2/SH
26053 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
26054 ELSE
26055 EPS=(2D0*PMAS(24,1))**2/SH
26056 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
26057 ENDIF
26058C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
26059 IF(EPS.LE.1D0) THEN
26060 ROOT=SQRT(1D0-EPS)
26061 IF(EPS.GT.1D-4) THEN
26062 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
26063 ELSE
26064 RLN=LOG(4D0/EPS-2D0)
26065 ENDIF
26066 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
26067 PHIIM=0.5D0*PARU(1)*RLN
26068 PSIRE=0.5D0*ROOT*RLN
26069 PSIIM=-0.5D0*ROOT*PARU(1)
26070 ELSE
26071 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
26072 PHIIM=0D0
26073 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
26074 PSIIM=0D0
26075 ENDIF
26076 IF(EPSP.LE.1D0) THEN
26077 ROOT=SQRT(1D0-EPSP)
26078 IF(EPSP.GT.1D-4) THEN
26079 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
26080 ELSE
26081 RLN=LOG(4D0/EPSP-2D0)
26082 ENDIF
26083 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
26084 PHIIMP=0.5D0*PARU(1)*RLN
26085 PSIREP=0.5D0*ROOT*RLN
26086 PSIIMP=-0.5D0*ROOT*PARU(1)
26087 ELSE
26088 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
26089 PHIIMP=0D0
26090 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
26091 PSIIMP=0D0
26092 ENDIF
26093 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
26094 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
26095 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
26096 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
26097 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
26098 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
26099 IF(J.LE.3*MSTP(1)) THEN
26100C...Fermion loops: loop integral different for A0; charges.
26101 IF(IHIGG.EQ.3) FXYRE=0D0
26102 IF(IHIGG.EQ.3) FXYIM=0D0
26103 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
26104 EJC=-3D0*EJ*VJ
26105 EJH=PARU(151+10*IHIGG)
26106 ELSEIF(J.LE.2*MSTP(1)) THEN
26107 EJC=-3D0*EJ*VJ
26108 EJH=PARU(152+10*IHIGG)
26109 ELSE
26110 EJC=-EJ*VJ
26111 EJH=PARU(153+10*IHIGG)
26112 ENDIF
26113 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
26114 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
26115 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
26116 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
26117C...W loops: loop integral and charges.
26118 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
26119 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
26120 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
26121 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
26122 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
26123 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
26124 ENDIF
26125 ELSE
26126C...Charged H loops: loop integral and charges.
26127 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
26128 & PARU(158+10*IHIGG+2*(IHIGG/3))
26129 ETAREJ=FACHHH*FXYRE
26130 ETAIMJ=FACHHH*FXYIM
26131 ENDIF
26132 ETARE=ETARE+ETAREJ
26133 ETAIM=ETAIM+ETAIMJ
26134 260 CONTINUE
26135 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
26136 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
26137 WID2=WIDS(23,2)
26138
26139 ELSEIF(I.LE.17) THEN
26140C...h0 -> Z0 + Z0, W+ + W-
26141 PM1=PMAS(IABS(KFDP(IDC,1)),1)
26142 PG1=PMAS(IABS(KFDP(IDC,1)),2)
26143 IF(MINT(62).GE.1) THEN
26144 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
26145 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
26146 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
26147 MOFSV(IHIGG,I-15)=0
26148 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
26149 & 1D0-4D0*RM1))
26150 WID2=1D0
26151 ELSE
26152 MOFSV(IHIGG,I-15)=1
26153 RMAS=SQRT(MAX(0D0,SH))
26154 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
26155 & WID2)
26156 WIDWSV(IHIGG,I-15)=WIDW
26157 WID2SV(IHIGG,I-15)=WID2
26158 ENDIF
26159 ELSE
26160 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
26161 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
26162 & 1D0-4D0*RM1))
26163 WID2=1D0
26164 ELSE
26165 WIDW=WIDWSV(IHIGG,I-15)
26166 WID2=WID2SV(IHIGG,I-15)
26167 ENDIF
26168 ENDIF
26169 WDTP(I)=FAC*WIDW/(2D0*(18-I))
26170 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
26171 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
26172 & PARU(138+I+10*IHIGG)**2
26173 WID2=WID2*WIDS(7+I,1)
26174
26175 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
26176C...H0 -> Z0 + h0, A0-> Z0 + h0
26177 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
26178 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26179 IF(IHIGG.EQ.2) THEN
26180 WDTP(I)=WDTP(I)*PARU(179)**2
26181 ELSEIF(IHIGG.EQ.3) THEN
26182 WDTP(I)=WDTP(I)*PARU(186)**2
26183 ENDIF
26184 WID2=WIDS(23,2)*WIDS(25,2)
26185
26186 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
26187C...H0 -> h0 + h0, A0-> h0 + h0
26188 WDTP(I)=FAC*0.25D0*
26189 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
26190 IF(IHIGG.EQ.2) THEN
26191 WDTP(I)=WDTP(I)*PARU(176)**2
26192 ELSEIF(IHIGG.EQ.3) THEN
26193 WDTP(I)=WDTP(I)*PARU(169)**2
26194 ENDIF
26195 WID2=WIDS(25,1)
26196 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
26197C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
26198 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
26199 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26200 & *PARU(195+IHIGG)**2
26201 IF(I.EQ.20) THEN
26202 WID2=WIDS(24,2)*WIDS(37,3)
26203 ELSEIF(I.EQ.21) THEN
26204 WID2=WIDS(24,3)*WIDS(37,2)
26205 ENDIF
26206
26207 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
26208C...H0 -> Z0 + A0.
26209 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
26210 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26211 WID2=WIDS(36,2)*WIDS(23,2)
26212
26213 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
26214C...H0 -> h0 + A0.
26215 WDTP(I)=FAC*0.5D0*PARU(180)**2*
26216 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
26217 WID2=WIDS(25,2)*WIDS(36,2)
26218
26219 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
26220C...H0 -> A0 + A0
26221 WDTP(I)=FAC*0.25D0*PARU(177)**2*
26222 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
26223 WID2=WIDS(36,1)
26224
26225CMRENNA++
26226 ELSE
26227C...Add in SUSY decays (two-body) by rescaling by phase space factor.
26228 RM10=RM1*SH/PMR**2
26229 RM20=RM2*SH/PMR**2
26230 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
26231 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
26232 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
26233 WFAC=0D0
26234 ELSE
26235 WFAC=WFAC/WFAC0
26236 ENDIF
26237 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
26238CMRENNA--
26239 IF(KFC2.EQ.KFC1) THEN
26240 WID2=WIDS(KFC1,1)
26241 ELSE
26242 KSGN1=2
26243 IF(KFDP(IDC,1).LT.0) KSGN1=3
26244 KSGN2=2
26245 IF(KFDP(IDC,2).LT.0) KSGN2=3
26246 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
26247 ENDIF
26248 ENDIF
26249 WDTP(I)=FUDGE*WDTP(I)
26250 WDTP(0)=WDTP(0)+WDTP(I)
26251 IF(MDME(IDC,1).GT.0) THEN
26252 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26253 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26254 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26255 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26256 ENDIF
26257 270 CONTINUE
26258
26259 ELSEIF(KFLA.EQ.32) THEN
26260C...Z'0:
26261 ICASE=1
26262 XWC=1D0/(16D0*XW*XW1)
26263 FAC=(AEM*XWC/3D0)*SHR
26264 VINT(117)=0D0
26265 280 CONTINUE
26266 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
26267 VINT(111)=0D0
26268 VINT(112)=0D0
26269 VINT(113)=0D0
26270 VINT(114)=0D0
26271 VINT(115)=0D0
26272 VINT(116)=0D0
26273 ENDIF
26274 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26275 KFAI=IABS(MINT(15))
26276 EI=KCHG(KFAI,1)/3D0
26277 AI=SIGN(1D0,EI+0.1D0)
26278 VI=AI-4D0*EI*XWV
26279 KFAIC=1
26280 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
26281 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
26282 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
26283 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
26284 VPI=PARU(119+2*KFAIC)
26285 API=PARU(120+2*KFAIC)
26286 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
26287 VPI=PARJ(178+2*KFAIC)
26288 API=PARJ(179+2*KFAIC)
26289 ELSE
26290 VPI=PARJ(186+2*KFAIC)
26291 API=PARJ(187+2*KFAIC)
26292 ENDIF
26293 SQMZ=PMAS(23,1)**2
26294 HZ=SHR*VINT(117)
26295 SQMZP=PMAS(32,1)**2
26296 HZP=SHR*WDTP(0)
26297 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
26298 & MSTP(44).EQ.7) VINT(111)=1D0
26299 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
26300 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
26301 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
26302 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
26303 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
26304 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
26305 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
26306 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
26307 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
26308 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
26309 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
26310 ENDIF
26311 DO 290 I=1,MDCY(KC,3)
26312 IDC=I+MDCY(KC,2)-1
26313 IF(MDME(IDC,1).LT.0) GOTO 290
26314 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26315 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26316 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
26317 WID2=1D0
26318 IF(I.LE.16) THEN
26319 IF(I.LE.8) THEN
26320C...Z'0 -> q + qbar
26321 EF=KCHG(I,1)/3D0
26322 AF=SIGN(1D0,EF+0.1D0)
26323 VF=AF-4D0*EF*XWV
26324 IF(I.LE.2) THEN
26325 VPF=PARU(123-2*MOD(I,2))
26326 APF=PARU(124-2*MOD(I,2))
26327 ELSEIF(I.LE.4) THEN
26328 VPF=PARJ(182-2*MOD(I,2))
26329 APF=PARJ(183-2*MOD(I,2))
26330 ELSE
26331 VPF=PARJ(190-2*MOD(I,2))
26332 APF=PARJ(191-2*MOD(I,2))
26333 ENDIF
26334 FCOF=3D0*RADC
26335 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
26336 & PYHFTH(SH,SH*RM1,1D0)
26337 IF(I.EQ.6) WID2=WIDS(6,1)
26338 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
26339 ELSEIF(I.LE.16) THEN
26340C...Z'0 -> l+ + l-, nu + nubar
26341 EF=KCHG(I+2,1)/3D0
26342 AF=SIGN(1D0,EF+0.1D0)
26343 VF=AF-4D0*EF*XWV
26344 IF(I.LE.10) THEN
26345 VPF=PARU(127-2*MOD(I,2))
26346 APF=PARU(128-2*MOD(I,2))
26347 ELSEIF(I.LE.12) THEN
26348 VPF=PARJ(186-2*MOD(I,2))
26349 APF=PARJ(187-2*MOD(I,2))
26350 ELSE
26351 VPF=PARJ(194-2*MOD(I,2))
26352 APF=PARJ(195-2*MOD(I,2))
26353 ENDIF
26354 FCOF=1D0
26355 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
26356 ENDIF
26357 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
26358 IF(ICASE.EQ.1) THEN
26359 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
26360 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
26361 & APF**2*(1D0-4D0*RM1))*BE34
26362 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26363 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
26364 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
26365 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
26366 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
26367 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
26368 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
26369 ELSEIF(MINT(61).EQ.2) THEN
26370 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
26371 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
26372 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
26373 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
26374 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
26375 & BE34
26376 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
26377 & BE34
26378 ENDIF
26379 ELSEIF(I.EQ.17) THEN
26380C...Z'0 -> W+ + W-
26381 WDTPZP=PARU(129)**2*XW1**2*
26382 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26383 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
26384 IF(ICASE.EQ.1) THEN
26385 WDTPZ=0D0
26386 WDTP(I)=FAC*WDTPZP
26387 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26388 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
26389 ELSEIF(MINT(61).EQ.2) THEN
26390 FGGF=0D0
26391 FGZF=0D0
26392 FGZPF=0D0
26393 FZZF=0D0
26394 FZZPF=0D0
26395 FZPZPF=WDTPZP
26396 ENDIF
26397 WID2=WIDS(24,1)
26398 ELSEIF(I.EQ.18) THEN
26399C...Z'0 -> H+ + H-
26400 CZC=2D0*(1D0-2D0*XW)
26401 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
26402 IF(ICASE.EQ.1) THEN
26403 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
26404 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
26405 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26406 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
26407 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
26408 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
26409 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
26410 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
26411 ELSEIF(MINT(61).EQ.2) THEN
26412 FGGF=0.25D0*BE34C
26413 FGZF=0.25D0*PARU(142)*CZC*BE34C
26414 FGZPF=0.25D0*PARU(143)*CZC*BE34C
26415 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
26416 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
26417 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
26418 ENDIF
26419 WID2=WIDS(37,1)
26420 ELSEIF(I.EQ.19) THEN
26421C...Z'0 -> Z0 + gamma.
26422 ELSEIF(I.EQ.20) THEN
26423C...Z'0 -> Z0 + h0
26424 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26425 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
26426 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
26427 IF(ICASE.EQ.1) THEN
26428 WDTPZ=0D0
26429 WDTP(I)=FAC*WDTPZP
26430 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26431 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
26432 ELSEIF(MINT(61).EQ.2) THEN
26433 FGGF=0D0
26434 FGZF=0D0
26435 FGZPF=0D0
26436 FZZF=0D0
26437 FZZPF=0D0
26438 FZPZPF=WDTPZP
26439 ENDIF
26440 WID2=WIDS(23,2)*WIDS(25,2)
26441 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
26442C...Z' -> h0 + A0 or H0 + A0.
26443 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26444 IF(I.EQ.21) THEN
26445 CZAH=PARU(186)
26446 CZPAH=PARU(188)
26447 ELSE
26448 CZAH=PARU(187)
26449 CZPAH=PARU(189)
26450 ENDIF
26451 IF(ICASE.EQ.1) THEN
26452 WDTPZ=CZAH**2*BE34C
26453 WDTP(I)=FAC*CZPAH**2*BE34C
26454 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26455 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
26456 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
26457 & VINT(116))*BE34C
26458 ELSEIF(MINT(61).EQ.2) THEN
26459 FGGF=0D0
26460 FGZF=0D0
26461 FGZPF=0D0
26462 FZZF=CZAH**2*BE34C
26463 FZZPF=CZAH*CZPAH*BE34C
26464 FZPZPF=CZPAH**2*BE34C
26465 ENDIF
26466 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
26467 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
26468 ENDIF
26469 IF(ICASE.EQ.1) THEN
26470 VINT(117)=VINT(117)+FAC*WDTPZ
26471 WDTP(I)=FUDGE*WDTP(I)
26472 WDTP(0)=WDTP(0)+WDTP(I)
26473 ENDIF
26474 IF(MDME(IDC,1).GT.0) THEN
26475 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
26476 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
26477 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26478 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
26479 & WDTE(I,MDME(IDC,1))
26480 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26481 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26482 ENDIF
26483 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
26484 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
26485 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
26486 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
26487 & FGZF*WID2
26488 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
26489 & FGZPF*WID2
26490 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
26491 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
26492 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
26493 & FZZPF*WID2
26494 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
26495 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
26496 ENDIF
26497 ENDIF
26498 290 CONTINUE
26499 IF(MINT(61).GE.1) ICASE=3-ICASE
26500 IF(ICASE.EQ.2) GOTO 280
26501
26502 ELSEIF(KFLA.EQ.34) THEN
26503C...W'+/-:
26504 FAC=(AEM/(24D0*XW))*SHR
26505 DO 300 I=1,MDCY(KC,3)
26506 IDC=I+MDCY(KC,2)-1
26507 IF(MDME(IDC,1).LT.0) GOTO 300
26508 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26509 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26510 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
26511 WID2=1D0
26512 IF(I.LE.20) THEN
26513 IF(I.LE.16) THEN
26514C...W'+/- -> q + qbar'
26515 CKMFAC = VCKM((I-1)/4+1,MOD(I-1,4)+1)
26516 FCOF=3D0*CKMFAC*RADC*(PARU(131)**2+PARU(132)**2)
26517 FCOF2=3D0*CKMFAC*RADC*(PARU(131)**2-PARU(132)**2)
26518 IF(KFLR.GT.0) THEN
26519 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
26520 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
26521 IF(I.GE.13) WID2=WID2*WIDS(7,3)
26522 ELSE
26523 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
26524 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
26525 IF(I.GE.13) WID2=WID2*WIDS(7,2)
26526 ENDIF
26527 ELSEIF(I.LE.20) THEN
26528C...W'+/- -> l+/- + nu
26529 FCOF=PARU(133)**2+PARU(134)**2
26530 FCOF2=PARU(133)**2-PARU(134)**2
26531 IF(KFLR.GT.0) THEN
26532 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26533 ELSE
26534 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26535 ENDIF
26536 ENDIF
26537 WDTP(I)=FAC*0.5*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)
26538 & *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26539 IF (RM1.GT.0D0.AND.RM2.GT.0D0) THEN
26540C...PS 28/06/2010
26541C...Inserted (gV2-gA2)*sqrt(m1*m2) term (FCOF2), following M. Chizhov
26542 WDTP(I)=WDTP(I) + FAC*0.5*6D0*FCOF2*SQRT(RM1*RM2)
26543 & *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26544 ENDIF
26545 ELSEIF(I.EQ.21) THEN
26546C...W'+/- -> W+/- + Z0
26547 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
26548 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26549 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
26550 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
26551 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
26552 ELSEIF(I.EQ.23) THEN
26553C...W'+/- -> W+/- + h0
26554 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26555 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
26556 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
26557 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
26558 ENDIF
26559 WDTP(I)=FUDGE*WDTP(I)
26560 WDTP(0)=WDTP(0)+WDTP(I)
26561 IF(MDME(IDC,1).GT.0) THEN
26562 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26563 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26564 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26565 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26566 ENDIF
26567 300 CONTINUE
26568
26569 ELSEIF(KFLA.EQ.37) THEN
26570C...H+/-:
26571C IF(MSTP(49).EQ.0) THEN
26572 SHFS=SH
26573C ELSE
26574C SHFS=PMAS(37,1)**2
26575C ENDIF
26576 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
26577 DO 310 I=1,MDCY(KC,3)
26578 IDC=I+MDCY(KC,2)-1
26579 IF(MDME(IDC,1).LT.0) GOTO 310
26580 KFC1=PYCOMP(KFDP(IDC,1))
26581 KFC2=PYCOMP(KFDP(IDC,2))
26582 RM1=PMAS(KFC1,1)**2/SH
26583 RM2=PMAS(KFC2,1)**2/SH
26584 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
26585 WID2=1D0
26586 IF(I.LE.4) THEN
26587C...H+/- -> q + qbar'
26588 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
26589 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
26590 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
26591 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
26592 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
26593 IF(KFLR.GT.0) THEN
26594 IF(I.EQ.3) WID2=WIDS(6,2)
26595 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
26596 ELSE
26597 IF(I.EQ.3) WID2=WIDS(6,3)
26598 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
26599 ENDIF
26600 ELSEIF(I.LE.8) THEN
26601C...H+/- -> l+/- + nu
26602 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
26603 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
26604 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
26605 IF(KFLR.GT.0) THEN
26606 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
26607 ELSE
26608 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
26609 ENDIF
26610 ELSEIF(I.EQ.9) THEN
26611C...H+/- -> W+/- + h0.
26612 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
26613 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26614 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
26615 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
26616
26617CMRENNA++
26618 ELSE
26619C...Add in SUSY decays (two-body) by rescaling by phase space factor.
26620 RM10=RM1*SH/PMR**2
26621 RM20=RM2*SH/PMR**2
26622 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
26623 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
26624 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
26625 WFAC=0D0
26626 ELSE
26627 WFAC=WFAC/WFAC0
26628 ENDIF
26629 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
26630CMRENNA--
26631 KSGN1=2
26632 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
26633 KSGN2=2
26634 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
26635 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
26636 ENDIF
26637 WDTP(I)=FUDGE*WDTP(I)
26638 WDTP(0)=WDTP(0)+WDTP(I)
26639 IF(MDME(IDC,1).GT.0) THEN
26640 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26641 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26642 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26643 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26644 ENDIF
26645 310 CONTINUE
26646
26647 ELSEIF(KFLA.EQ.41) THEN
26648C...R:
26649 FAC=(AEM/(12D0*XW))*SHR
26650 DO 320 I=1,MDCY(KC,3)
26651 IDC=I+MDCY(KC,2)-1
26652 IF(MDME(IDC,1).LT.0) GOTO 320
26653 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26654 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26655 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
26656 WID2=1D0
26657 IF(I.LE.6) THEN
26658C...R -> q + qbar'
26659 FCOF=3D0*RADC
26660 ELSEIF(I.LE.9) THEN
26661C...R -> l+ + l'-
26662 FCOF=1D0
26663 ENDIF
26664 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26665 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26666 IF(KFLR.GT.0) THEN
26667 IF(I.EQ.4) WID2=WIDS(6,3)
26668 IF(I.EQ.5) WID2=WIDS(7,3)
26669 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
26670 IF(I.EQ.9) WID2=WIDS(17,3)
26671 ELSE
26672 IF(I.EQ.4) WID2=WIDS(6,2)
26673 IF(I.EQ.5) WID2=WIDS(7,2)
26674 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
26675 IF(I.EQ.9) WID2=WIDS(17,2)
26676 ENDIF
26677 WDTP(I)=FUDGE*WDTP(I)
26678 WDTP(0)=WDTP(0)+WDTP(I)
26679 IF(MDME(IDC,1).GT.0) THEN
26680 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26681 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26682 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26683 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26684 ENDIF
26685 320 CONTINUE
26686
26687 ELSEIF(KFLA.EQ.42) THEN
26688C...LQ (leptoquark).
26689 FAC=(AEM/4D0)*PARU(151)*SHR
26690 DO 330 I=1,MDCY(KC,3)
26691 IDC=I+MDCY(KC,2)-1
26692 IF(MDME(IDC,1).LT.0) GOTO 330
26693 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26694 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26695 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
26696 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26697 WID2=1D0
26698 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
26699 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
26700 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
26701 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
26702 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
26703 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
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 330 CONTINUE
26713
26714C...UED: kk state width decays : flav: 451 476
26715 ELSEIF(IUED(1).EQ.1.AND.
26716 & PYCOMP(ABS(KFLA)).GE.KKFLMI.AND.
26717 & PYCOMP(ABS(KFLA)).LE.KKFLMA) THEN
26718 KCLA=PYCOMP(KFLA)
26719C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
26720 RMFLAS=PMAS(KCLA,1)
26721 FACSH=SH/PMAS(KCLA,1)**2
26722 ALPHEM=PYALEM(RMFLAS**2)
26723 ALPHS=PYALPS(RMFLAS**2)
26724
26725C...uedcor parameters (alpha_s is calculated at mkk scale)
26726C...alpha_em is calculated at z pole !
26727 ALPHEM=PARU(101)
26728 FACSH=1.
26729
26730 DO 1070 I=1,MDCY(KCLA,3)
26731 IDC=I+MDCY(KCLA,2)-1
26732
26733 IF(MDME(IDC,1).LT.0) GOTO 1070
26734 KFC1=PYCOMP(ABS(KFDP(IDC,1)))
26735 KFC2=PYCOMP(ABS(KFDP(IDC,2)))
26736 RM1=PMAS(KFC1,1)**2/SH
26737 RM2=PMAS(KFC2,1)**2/SH
26738 IF(SQRT(RM1)+SQRT(RM2).GT.1D0)
26739 & GOTO 1070
26740 WID2=1D0
26741
26742C...N.B. RINV=RUED(1)
26743 RMKK=RUED(1)
26744 RMWKK=PMAS(475,1)
26745 RMZKK=PMAS(474,1)
26746 SW2=PARU(102)
26747 CW2=1.-SW2
26748 KKCLA=KCLA-KKFLMI+1
26749 IF(ABS(KFC1).GE.KKFLMI)KKPART=KFC1
26750 IF(ABS(KFC2).GE.KKFLMI)KKPART=KFC2
26751 IF(KKCLA.LE.6) THEN
26752C...q*_S -> q + gamma* (in first time sw21=0)
26753 FAC=0.25*ALPHEM*RMFLAS*0.5*CW21/CW2*KCHG(KCLA,1)**2/9.
26754C...Eventually change the following by enabling a choice of open or closed.
26755C...Only the gamma_kk channel is open.
26756 IF(MOD(I,2).EQ.0)
26757 + WDTP(I)=FAC*FKAC2(RMFLAS,RMKK)*FKAC1(RMKK,RMFLAS)**2
26758 WDTP(I)=FACSH*WDTP(I)
26759 WID2=WIDS(473,2)
26760 ELSEIF(KKCLA.GT.6.AND.KKCLA.LE.12)THEN
26761C...q*_D -> q + Z*/W*
26762 FAC=0.25*ALPHEM*RMFLAS/(4.*SW2)
26763 GAMMAW=FAC*FKAC2(RMFLAS,RMWKK)*FKAC1(RMWKK,RMFLAS)**2
26764 IF(I.EQ.1)THEN
26765C...q*_D -> q + Z*
26766 WDTP(I)=0.5*GAMMAW
26767 WID2=WIDS(474,2)
26768 ELSEIF(I.EQ.2)THEN
26769C...q*_D -> q + W*
26770 WDTP(I)=GAMMAW
26771 WID2=WIDS(475,2)
26772 ENDIF
26773 WDTP(I)=FACSH*WDTP(I)
26774C...q*_D -> q + gamma* is closed
26775 ELSEIF(KKCLA.GT.12.AND.KKCLA.LE.21)THEN
26776C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
26777 FAC=ALPHEM/4.*RMFLAS/CW2/8.
26778 RMGAKK=PMAS(473,1)
26779 WDTP(I)=FAC*FKAC2(RMFLAS,RMGAKK)*
26780 + FKAC1(RMGAKK,RMFLAS)**2
26781 WDTP(I)=FACSH*WDTP(I)
26782 WID2=WIDS(473,2)
26783 ELSEIF(KKCLA.EQ.22)THEN
26784 RMQST=PMAS(KKPART,1)
26785 WID2=WIDS(KKPART,2)
26786C...g* -> q*_S/q*_D + q
26787 FAC=10.*ALPHS/12.*RMFLAS
26788 WDTP(I)=FAC*FKAC1(RMQST,RMFLAS)**2*FKAC2(RMQST,RMFLAS)
26789 WDTP(I)=FACSH*WDTP(I)
26790 ELSEIF(KKCLA.EQ.23)THEN
26791C...gamma* decays to graviton + gamma : initial value is used
26792 ICHI=IUED(4)/2
26793 WDTP(I)=RMFLAS*(RMFLAS/RUED(2))**(IUED(4)+2)
26794 & *CHIDEL(ICHI)
26795 ELSEIF(KKCLA.EQ.24)THEN
26796C...Z* -> l*_S + l is closed
26797C... Z* -> l*_D + l
26798 IF(I.LE.3)GOTO 1070
26799c... After closing the channels for a Z* decaying into positively charged
26800C... KK lepton singlets, close the channels for a Z* decaying into negatively
26801C... charged KK lepton singlets + positively charged SM particles
26802 IF(I.GE.10.AND.I.LE.12)GOTO 1070
26803 FAC=3./2.*ALPHEM/24./SW2*RMZKK
26804 RMLST=PMAS(KKPART,1)
26805 WDTP(I)=FAC*FKAC1(RMLST,RMZKK)**2*FKAC2(RMLST,RMZKK)
26806 WDTP(I)=FACSH*WDTP(I)
26807 WID2=WIDS(KKPART,2)
26808 ELSEIF(KKCLA.EQ.25)THEN
26809C...W* -> l*_D lbar
26810 FAC=3.*ALPHEM/12./SW2*RMWKK
26811 RMLST=PMAS(KKPART,1)
26812 WDTP(I)=FAC*FKAC1(RMLST,RMWKK)**2*FKAC2(RMLST,RMWKK)
26813 WDTP(I)=FACSH*WDTP(I)
26814 WID2=WIDS(KKPART,2)
26815 ENDIF
26816 WDTP(0)=WDTP(0)+WDTP(I)
26817 IF(MDME(IDC,1).GT.0) THEN
26818 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26819 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26820 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26821 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26822 ENDIF
26823 1070 CONTINUE
26824 IUEDPR(KKCLA)=1
26825
26826 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
26827C...Techni-pi0 and techni-pi0':
26828 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26829 DO 340 I=1,MDCY(KC,3)
26830 IDC=I+MDCY(KC,2)-1
26831 IF(MDME(IDC,1).LT.0) GOTO 340
26832 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26833 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26834 RM1=PM1**2/SH
26835 RM2=PM2**2/SH
26836 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
26837 WID2=1D0
26838C...pi_tc -> g + g
26839 IF(I.EQ.8) THEN
26840 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
26841 & /(8D0*PARU(1))*SH*SHR
26842 IF(KFLA.EQ.KTECHN+111) THEN
26843 FACP=FACP*RTCM(9)
26844 ELSE
26845 FACP=FACP*RTCM(10)
26846 ENDIF
26847 WDTP(I)=FACP
26848 ELSE
26849C...pi_tc -> f + fbar.
26850 FCOF=1D0
26851 IKA=IABS(KFDP(IDC,1))
26852 IF(IKA.LT.10) FCOF=3D0*RADC
26853 HM1=PM1
26854 HM2=PM2
26855 IF(IKA.GE.4.AND.IKA.LE.6) THEN
26856 FCOF=FCOF*RTCM(1+IKA)**2
26857 HM1=PYMRUN(KFDP(IDC,1),SH)
26858 HM2=PYMRUN(KFDP(IDC,2),SH)
26859 ELSEIF(IKA.EQ.15) THEN
26860 FCOF=FCOF*RTCM(8)**2
26861 ENDIF
26862 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26863 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26864 ENDIF
26865 WDTP(I)=FUDGE*WDTP(I)
26866 WDTP(0)=WDTP(0)+WDTP(I)
26867 IF(MDME(IDC,1).GT.0) THEN
26868 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26869 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26870 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26871 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26872 ENDIF
26873 340 CONTINUE
26874
26875 ELSEIF(KFLA.EQ.KTECHN+211) THEN
26876C...pi+_tc
26877 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26878 DO 350 I=1,MDCY(KC,3)
26879 IDC=I+MDCY(KC,2)-1
26880 IF(MDME(IDC,1).LT.0) GOTO 350
26881 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26882 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26883 PM3=0D0
26884 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26885 RM1=PM1**2/SH
26886 RM2=PM2**2/SH
26887 RM3=PM3**2/SH
26888 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
26889 WID2=1D0
26890C...pi_tc -> f + f'.
26891 FCOF=1D0
26892 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
26893C...pi_tc+ -> W b b~
26894 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
26895 FCOF=3D0*RADC
26896 XMT2=PMAS(6,1)**2/SH
26897 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
26898 KFC3=PYCOMP(KFDP(IDC,3))
26899 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
26900 CHECK = SQRT(RM1)
26901 T0 = (1D0-CHECK**2)*
26902 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
26903 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
26904 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
26905 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
26906 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
26907 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
26908 & +T3*LOG(CHECK))
26909 IF(KFLR.GT.0) THEN
26910 WID2=WIDS(24,2)
26911 ELSE
26912 WID2=WIDS(24,3)
26913 ENDIF
26914 ELSE
26915 FCOF=1D0
26916 IKA=IABS(KFDP(IDC,1))
26917 IF(IKA.LT.10) FCOF=3D0*RADC
26918 HM1=PM1
26919 HM2=PM2
26920 IF(I.GE.1.AND.I.LE.5) THEN
26921 IF(I.LE.2) THEN
26922 FCOF=FCOF*RTCM(5)**2
26923 ELSEIF(I.LE.4) THEN
26924 FCOF=FCOF*RTCM(6)**2
26925 ELSEIF(I.EQ.5) THEN
26926 FCOF=FCOF*RTCM(7)**2
26927 ENDIF
26928 HM1=PYMRUN(KFDP(IDC,1),SH)
26929 HM2=PYMRUN(KFDP(IDC,2),SH)
26930 ELSEIF(I.EQ.8) THEN
26931 FCOF=FCOF*RTCM(8)**2
26932 ENDIF
26933 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26934 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26935 ENDIF
26936 WDTP(I)=FUDGE*WDTP(I)
26937 WDTP(0)=WDTP(0)+WDTP(I)
26938 IF(MDME(IDC,1).GT.0) THEN
26939 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26940 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26941 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26942 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26943 ENDIF
26944 350 CONTINUE
26945
26946 ELSEIF(KFLA.EQ.KTECHN+331) THEN
26947C...Techni-eta.
26948 FAC=(SH/PARP(46)**2)*SHR
26949 DO 360 I=1,MDCY(KC,3)
26950 IDC=I+MDCY(KC,2)-1
26951 IF(MDME(IDC,1).LT.0) GOTO 360
26952 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26953 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26954 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
26955 WID2=1D0
26956 IF(I.LE.2) THEN
26957 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
26958 IF(I.EQ.2) WID2=WIDS(6,1)
26959 ELSE
26960 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
26961 ENDIF
26962 WDTP(I)=FUDGE*WDTP(I)
26963 WDTP(0)=WDTP(0)+WDTP(I)
26964 IF(MDME(IDC,1).GT.0) THEN
26965 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26966 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26967 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26968 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26969 ENDIF
26970 360 CONTINUE
26971
26972 ELSEIF(KFLA.EQ.KTECHN+113) THEN
26973C...Techni-rho0:
26974 ALPRHT=2.16D0*(3D0/ITCM(1))
26975 FAC=(ALPRHT/12D0)*SHR
26976 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26977 SQMZ=PMAS(23,1)**2
26978 SQMW=PMAS(24,1)**2
26979 SHP=SH
26980 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26981 GMMZ=SHR*WDTPP(0)
26982 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26983 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26984 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26985 DO 370 I=1,MDCY(KC,3)
26986 IDC=I+MDCY(KC,2)-1
26987 IF(MDME(IDC,1).LT.0) GOTO 370
26988 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26989 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26990 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
26991 WID2=1D0
26992 IF(I.EQ.1) THEN
26993C...rho_tc0 -> W+ + W-.
26994C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26995 WDTP(I)=FAC*RTCM(3)**4*
26996 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26997 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26998 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26999 & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
27000 WID2=WIDS(24,1)
27001 ELSEIF(I.EQ.2) THEN
27002C...rho_tc0 -> W+ + pi_tc-.
27003C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
27004 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
27005 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27006 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
27007 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
27008 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
27009 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27010 ELSEIF(I.EQ.3) THEN
27011C...rho_tc0 -> pi_tc+ + W-.
27012 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
27013 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27014 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
27015 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
27016 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
27017 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
27018 ELSEIF(I.EQ.4) THEN
27019C...rho_tc0 -> pi_tc+ + pi_tc-.
27020 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
27021 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27022 WID2=WIDS(PYCOMP(KTECHN+211),1)
27023 ELSEIF(I.EQ.5) THEN
27024C...rho_tc0 -> gamma + pi_tc0
27025 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27026 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27027 & SHR**3
27028 WID2=WIDS(PYCOMP(KTECHN+111),2)
27029 ELSEIF(I.EQ.6) THEN
27030C...rho_tc0 -> gamma + pi_tc0'
27031 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27032 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
27033 WID2=WIDS(PYCOMP(KTECHN+221),2)
27034 ELSEIF(I.EQ.7) THEN
27035C...rho_tc0 -> Z0 + pi_tc0
27036 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27037 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27038 & XW/XW1*SHR**3
27039 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
27040 ELSEIF(I.EQ.8) THEN
27041C...rho_tc0 -> Z0 + pi_tc0'
27042 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27043 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
27044 & XW/XW1*SHR**3
27045 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27046 ELSEIF(I.EQ.9) THEN
27047C...rho_tc0 -> gamma + Z0
27048 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27049 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
27050 WID2=WIDS(23,2)
27051 ELSEIF(I.EQ.10) THEN
27052C...rho_tc0 -> Z0 + Z0
27053 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27054 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
27055 & SHR**3
27056 WID2=WIDS(23,1)
27057 ELSE
27058C...rho_tc0 -> f + fbar.
27059 WID2=1D0
27060 IF(I.LE.18) THEN
27061 IA=I-10
27062 FCOF=3D0*RADC
27063 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27064 ELSE
27065 IA=I-6
27066 FCOF=1D0
27067 IF(IA.GE.17) WID2=WIDS(IA,1)
27068 ENDIF
27069 EI=KCHG(IA,1)/3D0
27070 AI=SIGN(1D0,EI+0.1D0)
27071 VI=AI-4D0*EI*XWV
27072 VALI=0.5D0*(VI+AI)
27073 VARI=0.5D0*(VI-AI)
27074 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27075 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
27076 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27077 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
27078 ENDIF
27079 WDTP(I)=FUDGE*WDTP(I)
27080 WDTP(0)=WDTP(0)+WDTP(I)
27081 IF(MDME(IDC,1).GT.0) THEN
27082 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27083 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27084 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27085 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27086 ENDIF
27087 370 CONTINUE
27088
27089 ELSEIF(KFLA.EQ.KTECHN+213) THEN
27090C...Techni-rho+/-:
27091 ALPRHT=2.16D0*(3D0/ITCM(1))
27092 FAC=(ALPRHT/12D0)*SHR
27093 SQMZ=PMAS(23,1)**2
27094 SQMW=PMAS(24,1)**2
27095 SHP=SH
27096 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
27097 GMMW=SHR*WDTPP(0)
27098 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
27099 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
27100 DO 380 I=1,MDCY(KC,3)
27101 IDC=I+MDCY(KC,2)-1
27102 IF(MDME(IDC,1).LT.0) GOTO 380
27103 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27104 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27105 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
27106 WID2=1D0
27107 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27108c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27109c & /3D0*SHR**3
27110 IF(I.EQ.1) THEN
27111C...rho_tc+ -> W+ + Z0.
27112C......Goldstone
27113 WDTP(I)=FAC*RTCM(3)**4*
27114 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27115 VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
27116 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
27117C......W_L Z_T
27118 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
27119 & /3D0*SHR**3
27120 VA2=0D0
27121 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
27122C......W_T Z_L
27123 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27124 & /3D0*SHR**3
27125 IF(KFLR.GT.0) THEN
27126 WID2=WIDS(24,2)*WIDS(23,2)
27127 ELSE
27128 WID2=WIDS(24,3)*WIDS(23,2)
27129 ENDIF
27130 ELSEIF(I.EQ.2) THEN
27131C...rho_tc+ -> W+ + pi_tc0.
27132 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
27133 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27134 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
27135 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
27136 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
27137 IF(KFLR.GT.0) THEN
27138 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
27139 ELSE
27140 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
27141 ENDIF
27142 ELSEIF(I.EQ.3) THEN
27143C...rho_tc+ -> pi_tc+ + Z0.
27144 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
27145 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27146 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
27147 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
27148 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
27149 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27150 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27151 & SHR**3*XW/XW1
27152 IF(KFLR.GT.0) THEN
27153 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
27154 ELSE
27155 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
27156 ENDIF
27157 ELSEIF(I.EQ.4) THEN
27158C...rho_tc+ -> pi_tc+ + pi_tc0.
27159 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
27160 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27161 IF(KFLR.GT.0) THEN
27162 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
27163 ELSE
27164 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
27165 ENDIF
27166 ELSEIF(I.EQ.5) THEN
27167C...rho_tc+ -> pi_tc+ + gamma
27168 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27169 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27170 & SHR**3
27171 IF(KFLR.GT.0) THEN
27172 WID2=WIDS(PYCOMP(KTECHN+211),2)
27173 ELSE
27174 WID2=WIDS(PYCOMP(KTECHN+211),3)
27175 ENDIF
27176 ELSEIF(I.EQ.6) THEN
27177C...rho_tc+ -> W+ + pi_tc0'
27178 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27179 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
27180 IF(KFLR.GT.0) THEN
27181 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
27182 ELSE
27183 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
27184 ENDIF
27185 ELSEIF(I.EQ.7) THEN
27186C...rho_tc+ -> W+ + gamma
27187 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27188 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
27189 IF(KFLR.GT.0) THEN
27190 WID2=WIDS(24,2)
27191 ELSE
27192 WID2=WIDS(24,3)
27193 ENDIF
27194 ELSE
27195C...rho_tc+ -> f + fbar'.
27196 IA=I-7
27197 WID2=1D0
27198 IF(IA.LE.16) THEN
27199 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
27200 IF(KFLR.GT.0) THEN
27201 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
27202 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
27203 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
27204 ELSE
27205 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
27206 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
27207 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
27208 ENDIF
27209 ELSE
27210 FCOF=1D0
27211 IF(KFLR.GT.0) THEN
27212 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
27213 ELSE
27214 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
27215 ENDIF
27216 ENDIF
27217 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27218 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27219 ENDIF
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 380 CONTINUE
27229
27230 ELSEIF(KFLA.EQ.KTECHN+223) THEN
27231C...Techni-omega:
27232 ALPRHT=2.16D0*(3D0/ITCM(1))
27233 FAC=(ALPRHT/12D0)*SHR
27234 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
27235 SQMZ=PMAS(23,1)**2
27236 SHP=SH
27237 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
27238 GMMZ=SHR*WDTPP(0)
27239 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
27240 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
27241 DO 390 I=1,MDCY(KC,3)
27242 IDC=I+MDCY(KC,2)-1
27243 IF(MDME(IDC,1).LT.0) GOTO 390
27244 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27245 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27246 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
27247 WID2=1D0
27248 IF(I.EQ.1) THEN
27249C...omega_tc0 -> gamma + pi_tc0.
27250 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
27251 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
27252 WID2=WIDS(PYCOMP(KTECHN+111),2)
27253 ELSEIF(I.EQ.2) THEN
27254C...omega_tc0 -> Z0 + pi_tc0
27255 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27256 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
27257 & XW/XW1*SHR**3
27258 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
27259 ELSEIF(I.EQ.3) THEN
27260C...omega_tc0 -> gamma + pi_tc0'
27261 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27262 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
27263 & SHR**3
27264 WID2=WIDS(PYCOMP(KTECHN+221),2)
27265 ELSEIF(I.EQ.4) THEN
27266C...omega_tc0 -> Z0 + pi_tc0'
27267 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27268 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
27269 & XW/XW1*SHR**3
27270 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27271 ELSEIF(I.EQ.5) THEN
27272C...omega_tc0 -> W+ + pi_tc-
27273 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27274 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
27275 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
27276 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27277 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27278 ELSEIF(I.EQ.6) THEN
27279C...omega_tc0 -> pi_tc+ + W-
27280 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27281 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
27282 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
27283 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27284 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
27285 ELSEIF(I.EQ.7) THEN
27286C...omega_tc0 -> W+ + W-.
27287C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
27288 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
27289 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27290 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27291 & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
27292 WID2=WIDS(24,1)
27293 ELSEIF(I.EQ.8) THEN
27294C...omega_tc0 -> pi_tc+ + pi_tc-.
27295 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
27296 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27297 WID2=WIDS(PYCOMP(KTECHN+211),1)
27298C...omega_tc0 -> gamma + Z0
27299 ELSEIF(I.EQ.9) THEN
27300 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27301 & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
27302 WID2=WIDS(23,2)
27303C...omega_tc0 -> Z0 + Z0
27304 ELSEIF(I.EQ.10) THEN
27305 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27306 & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
27307 & /24D0/RTCM(12)**2*SHR**3
27308 WID2=WIDS(23,1)
27309 ELSE
27310C...omega_tc0 -> f + fbar.
27311 WID2=1D0
27312 IF(I.LE.18) THEN
27313 IA=I-10
27314 FCOF=3D0*RADC
27315 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27316 ELSE
27317 IA=I-8
27318 FCOF=1D0
27319 IF(IA.GE.17) WID2=WIDS(IA,1)
27320 ENDIF
27321 EI=KCHG(IA,1)/3D0
27322 AI=SIGN(1D0,EI+0.1D0)
27323 VI=AI-4D0*EI*XWV
27324 VALI=-0.5D0*(VI+AI)
27325 VARI=-0.5D0*(VI-AI)
27326 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27327 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
27328 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27329 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
27330 ENDIF
27331 WDTP(I)=FUDGE*WDTP(I)
27332 WDTP(0)=WDTP(0)+WDTP(I)
27333 IF(MDME(IDC,1).GT.0) THEN
27334 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27335 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27336 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27337 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27338 ENDIF
27339 390 CONTINUE
27340
27341C.....V8 -> quark anti-quark
27342 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
27343 FAC=AS/6D0*SHR
27344 TANT3=RTCM(21)
27345 IF(ITCM(2).EQ.0) THEN
27346 IMDL=1
27347 ELSEIF(ITCM(2).EQ.1) THEN
27348 IMDL=2
27349 ENDIF
27350 DO 400 I=1,MDCY(KC,3)
27351 IDC=I+MDCY(KC,2)-1
27352 IF(MDME(IDC,1).LT.0) GOTO 400
27353 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
27354 RM1=PM1**2/SH
27355 IF(RM1.GT.0.25D0) GOTO 400
27356 WID2=1D0
27357 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
27358 FMIX=1D0/TANT3**2
27359 ELSE
27360 FMIX=TANT3**2
27361 ENDIF
27362 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
27363 IF(I.EQ.6) WID2=WIDS(6,1)
27364 WDTP(I)=FUDGE*WDTP(I)
27365 WDTP(0)=WDTP(0)+WDTP(I)
27366 IF(MDME(IDC,1).GT.0) THEN
27367 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27368 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27369 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27370 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27371 ENDIF
27372 400 CONTINUE
27373
27374 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
27375 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
27376 CLEBF=0D0
27377 DO 410 I=1,MDCY(KC,3)
27378 IDC=I+MDCY(KC,2)-1
27379 IF(MDME(IDC,1).LT.0) GOTO 410
27380 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27381 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27382 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
27383 WID2=1D0
27384C...pi_tc -> g + g
27385 IF(I.EQ.7) THEN
27386 IF(KFLA.EQ.KTECHN+100111) THEN
27387 CLEBG=4D0/3D0
27388 ELSE
27389 CLEBG=5D0/3D0
27390 ENDIF
27391 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
27392 & /(2D0*PARU(1))*SH*SHR*CLEBG
27393 WDTP(I)=FACP
27394 ELSE
27395C...pi_tc -> f + fbar.
27396 IF(I.EQ.6) WID2=WIDS(6,1)
27397 FCOF=1D0
27398 IKA=IABS(KFDP(IDC,1))
27399 IF(IKA.LT.10) FCOF=3D0*RADC
27400 HM1=PYMRUN(KFDP(IDC,1),SH)
27401 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
27402 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27403 ENDIF
27404 WDTP(I)=FUDGE*WDTP(I)
27405 WDTP(0)=WDTP(0)+WDTP(I)
27406 IF(MDME(IDC,1).GT.0) THEN
27407 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27408 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27409 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27410 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27411 ENDIF
27412 410 CONTINUE
27413
27414 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
27415 FAC=AS/6D0*SHR
27416 ALPRHT=2.16D0*(3D0/ITCM(1))
27417 TANT3=RTCM(21)
27418 SIN2T=2D0*TANT3/(TANT3**2+1D0)
27419 SINT3=TANT3/SQRT(TANT3**2+1D0)
27420 CSXPP=RTCM(22)
27421 RM82=RTCM(27)**2
27422 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
27423 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
27424 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
27425 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
27426 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
27427 & SINT3**2)*2D0
27428 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
27429 & SINT3**2)*2D0
27430 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
27431
27432 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
27433 GMV8=SHR*WDTPP(0)
27434 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
27435 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
27436 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
27437 IF(ITCM(2).EQ.0) THEN
27438 IMDL=1
27439 ELSE
27440 IMDL=2
27441 ENDIF
27442 DO 420 I=1,MDCY(KC,3)
27443 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
27444 & KFLA.EQ.KTECHN+300113)) GOTO 420
27445 IDC=I+MDCY(KC,2)-1
27446 IF(MDME(IDC,1).LT.0) GOTO 420
27447 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27448 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27449 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
27450 WID2=1D0
27451 IF(I.LE.6) THEN
27452 IF(I.EQ.6) WID2=WIDS(6,1)
27453 XIG=1D0
27454 IF(KFLA.EQ.KTECHN+200113) THEN
27455 XIG=0D0
27456 XIJ=X12
27457 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
27458 XIG=0D0
27459 XIJ=X21
27460 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
27461 XIJ=X11
27462 ELSE
27463 XIJ=X22
27464 ENDIF
27465 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
27466 FMIX=1D0/TANT3/SIN2T
27467 ELSE
27468 FMIX=-TANT3/SIN2T
27469 ENDIF
27470 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
27471 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
27472 ELSEIF(I.EQ.7) THEN
27473 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
27474 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
27475 PSH=SHR*(1D0-RM1)/2D0
27476 WDTP(I)=AS/9D0*PSH**3/RM82
27477 IF(I.EQ.8) THEN
27478 WDTP(I)=2D0*WDTP(I)*CSXPP**2
27479 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
27480 ELSE
27481 WDTP(I)=5D0*WDTP(I)
27482 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
27483 ENDIF
27484 ENDIF
27485 WDTP(I)=FUDGE*WDTP(I)
27486 WDTP(0)=WDTP(0)+WDTP(I)
27487 IF(MDME(IDC,1).GT.0) THEN
27488 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27489 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27490 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27491 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27492 ENDIF
27493 420 CONTINUE
27494
27495 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
27496C...d* excited quark.
27497 FAC=(SH/RTCM(41)**2)*SHR
27498 DO 430 I=1,MDCY(KC,3)
27499 IDC=I+MDCY(KC,2)-1
27500 IF(MDME(IDC,1).LT.0) GOTO 430
27501 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27502 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27503 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
27504 WID2=1D0
27505 IF(I.EQ.1) THEN
27506C...d* -> g + d.
27507 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
27508 WID2=1D0
27509 ELSEIF(I.EQ.2) THEN
27510C...d* -> gamma + d.
27511 QF=-RTCM(43)/2D0+RTCM(44)/6D0
27512 WDTP(I)=FAC*AEM*QF**2/4D0
27513 WID2=1D0
27514 ELSEIF(I.EQ.3) THEN
27515C...d* -> Z0 + d.
27516 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
27517 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27518 & (1D0-RM1)**2*(2D0+RM1)
27519 WID2=WIDS(23,2)
27520 ELSEIF(I.EQ.4) THEN
27521C...d* -> W- + u.
27522 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27523 & (1D0-RM1)**2*(2D0+RM1)
27524 IF(KFLR.GT.0) WID2=WIDS(24,3)
27525 IF(KFLR.LT.0) WID2=WIDS(24,2)
27526 ENDIF
27527 WDTP(I)=FUDGE*WDTP(I)
27528 WDTP(0)=WDTP(0)+WDTP(I)
27529 IF(MDME(IDC,1).GT.0) THEN
27530 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27531 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27532 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27533 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27534 ENDIF
27535 430 CONTINUE
27536
27537 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
27538C...u* excited quark.
27539 FAC=(SH/RTCM(41)**2)*SHR
27540 DO 440 I=1,MDCY(KC,3)
27541 IDC=I+MDCY(KC,2)-1
27542 IF(MDME(IDC,1).LT.0) GOTO 440
27543 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27544 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27545 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
27546 WID2=1D0
27547 IF(I.EQ.1) THEN
27548C...u* -> g + u.
27549 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
27550 WID2=1D0
27551 ELSEIF(I.EQ.2) THEN
27552C...u* -> gamma + u.
27553 QF=RTCM(43)/2D0+RTCM(44)/6D0
27554 WDTP(I)=FAC*AEM*QF**2/4D0
27555 WID2=1D0
27556 ELSEIF(I.EQ.3) THEN
27557C...u* -> Z0 + u.
27558 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
27559 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27560 & (1D0-RM1)**2*(2D0+RM1)
27561 WID2=WIDS(23,2)
27562 ELSEIF(I.EQ.4) THEN
27563C...u* -> W+ + d.
27564 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27565 & (1D0-RM1)**2*(2D0+RM1)
27566 IF(KFLR.GT.0) WID2=WIDS(24,2)
27567 IF(KFLR.LT.0) WID2=WIDS(24,3)
27568 ENDIF
27569 WDTP(I)=FUDGE*WDTP(I)
27570 WDTP(0)=WDTP(0)+WDTP(I)
27571 IF(MDME(IDC,1).GT.0) THEN
27572 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27573 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27574 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27575 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27576 ENDIF
27577 440 CONTINUE
27578
27579 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
27580C...e* excited lepton.
27581 FAC=(SH/RTCM(41)**2)*SHR
27582 DO 450 I=1,MDCY(KC,3)
27583 IDC=I+MDCY(KC,2)-1
27584 IF(MDME(IDC,1).LT.0) GOTO 450
27585 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27586 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27587 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
27588 WID2=1D0
27589 IF(I.EQ.1) THEN
27590C...e* -> gamma + e.
27591 QF=-RTCM(43)/2D0-RTCM(44)/2D0
27592 WDTP(I)=FAC*AEM*QF**2/4D0
27593 WID2=1D0
27594 ELSEIF(I.EQ.2) THEN
27595C...e* -> Z0 + e.
27596 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
27597 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27598 & (1D0-RM1)**2*(2D0+RM1)
27599 WID2=WIDS(23,2)
27600 ELSEIF(I.EQ.3) THEN
27601C...e* -> W- + nu.
27602 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27603 & (1D0-RM1)**2*(2D0+RM1)
27604 IF(KFLR.GT.0) WID2=WIDS(24,3)
27605 IF(KFLR.LT.0) WID2=WIDS(24,2)
27606 ENDIF
27607 WDTP(I)=FUDGE*WDTP(I)
27608 WDTP(0)=WDTP(0)+WDTP(I)
27609 IF(MDME(IDC,1).GT.0) THEN
27610 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27611 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27612 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27613 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27614 ENDIF
27615 450 CONTINUE
27616
27617 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
27618C...nu*_e excited neutrino.
27619 FAC=(SH/RTCM(41)**2)*SHR
27620 DO 460 I=1,MDCY(KC,3)
27621 IDC=I+MDCY(KC,2)-1
27622 IF(MDME(IDC,1).LT.0) GOTO 460
27623 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27624 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27625 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
27626 WID2=1D0
27627 IF(I.EQ.1) THEN
27628C...nu*_e -> Z0 + nu*_e.
27629 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
27630 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27631 & (1D0-RM1)**2*(2D0+RM1)
27632 WID2=WIDS(23,2)
27633 ELSEIF(I.EQ.2) THEN
27634C...nu*_e -> W+ + e.
27635 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27636 & (1D0-RM1)**2*(2D0+RM1)
27637 IF(KFLR.GT.0) WID2=WIDS(24,2)
27638 IF(KFLR.LT.0) WID2=WIDS(24,3)
27639 ENDIF
27640 WDTP(I)=FUDGE*WDTP(I)
27641 WDTP(0)=WDTP(0)+WDTP(I)
27642 IF(MDME(IDC,1).GT.0) THEN
27643 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27644 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27645 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27646 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27647 ENDIF
27648 460 CONTINUE
27649
27650 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
27651C...G* (graviton resonance):
27652 FAC=(PARP(50)**2/PARU(1))*SHR
27653 DO 470 I=1,MDCY(KC,3)
27654 IDC=I+MDCY(KC,2)-1
27655 IF(MDME(IDC,1).LT.0) GOTO 470
27656 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27657 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27658 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
27659 WID2=1D0
27660 IF(I.LE.8) THEN
27661C...G* -> q + qbar
27662 FCOF=3D0*RADC
27663 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
27664 & PYHFTH(SH,SH*RM1,1D0)
27665 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27666 & (1D0+8D0*RM1/3D0)/320D0
27667 IF(I.EQ.6) WID2=WIDS(6,1)
27668 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
27669 ELSEIF(I.LE.16) THEN
27670C...G* -> l+ + l-, nu + nubar
27671 FCOF=1D0
27672 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27673 & (1D0+8D0*RM1/3D0)/320D0
27674 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
27675 ELSEIF(I.EQ.17) THEN
27676C...G* -> g + g.
27677 WDTP(I)=FAC/20D0
27678 ELSEIF(I.EQ.18) THEN
27679C...G* -> gamma + gamma.
27680 WDTP(I)=FAC/160D0
27681 ELSEIF(I.EQ.19) THEN
27682C...G* -> Z0 + Z0.
27683 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27684 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
27685 WID2=WIDS(23,1)
27686 ELSEIF(I.EQ.20) THEN
27687C...G* -> W+ + W-.
27688 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27689 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
27690 WID2=WIDS(24,1)
27691 ENDIF
27692 WDTP(I)=FUDGE*WDTP(I)
27693 WDTP(0)=WDTP(0)+WDTP(I)
27694 IF(MDME(IDC,1).GT.0) THEN
27695 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27696 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27697 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27698 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27699 ENDIF
27700 470 CONTINUE
27701
27702 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
27703C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
27704 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
27705 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
27706 DO 480 I=1,MDCY(KC,3)
27707 IDC=I+MDCY(KC,2)-1
27708 IF(MDME(IDC,1).LT.0) GOTO 480
27709 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
27710 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
27711 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
27712 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
27713 WID2=1D0
27714 IF(I.LE.9) THEN
27715C...nu_lR -> l- qbar q'
27716 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27717 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27718 ELSEIF(I.LE.18) THEN
27719C...nu_lR -> l+ q qbar'
27720 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
27721 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
27722 ELSE
27723C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
27724 FCOF=1D0
27725 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
27726 ENDIF
27727 X=(PM1+PM2+PM3)/SHR
27728 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
27729 Y=(SHR/PMWR)**2
27730 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
27731 WDTP(I)=FAC*FCOF*FX*FY
27732 WDTP(I)=FUDGE*WDTP(I)
27733 WDTP(0)=WDTP(0)+WDTP(I)
27734 IF(MDME(IDC,1).GT.0) THEN
27735 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27736 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27737 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27738 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27739 ENDIF
27740 480 CONTINUE
27741
27742 ELSEIF(KFLA.EQ.9900023) THEN
27743C...Z_R0:
27744 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
27745 DO 490 I=1,MDCY(KC,3)
27746 IDC=I+MDCY(KC,2)-1
27747 IF(MDME(IDC,1).LT.0) GOTO 490
27748 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27749 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27750 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
27751 WID2=1D0
27752 SYMMET=1D0
27753 IF(I.LE.6) THEN
27754C...Z_R0 -> q + qbar
27755 EF=KCHG(I,1)/3D0
27756 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
27757 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
27758 FCOF=3D0*RADC
27759 IF(I.EQ.6) WID2=WIDS(6,1)
27760 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
27761C...Z_R0 -> l+ + l-
27762 AF=-(1D0-2D0*XW)
27763 VF=-1D0+4D0*XW
27764 FCOF=1D0
27765 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
27766C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
27767 AF=-2D0*XW
27768 VF=0D0
27769 FCOF=1D0
27770 SYMMET=0.5D0
27771 ELSEIF(I.LE.15) THEN
27772C...Z0 -> nu_R + nu_R, assumed Majorana.
27773 AF=2D0*XW1
27774 VF=0D0
27775 FCOF=1D0
27776 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
27777 SYMMET=0.5D0
27778 ENDIF
27779 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
27780 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
27781 WDTP(I)=FUDGE*WDTP(I)
27782 WDTP(0)=WDTP(0)+WDTP(I)
27783 IF(MDME(IDC,1).GT.0) THEN
27784 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27785 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27786 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27787 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27788 ENDIF
27789 490 CONTINUE
27790
27791 ELSEIF(KFLA.EQ.9900024) THEN
27792C...W_R+/-:
27793 FAC=(AEM/(24D0*XW))*SHR
27794 DO 500 I=1,MDCY(KC,3)
27795 IDC=I+MDCY(KC,2)-1
27796 IF(MDME(IDC,1).LT.0) GOTO 500
27797 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27798 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27799 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
27800 WID2=1D0
27801 IF(I.LE.9) THEN
27802C...W_R+/- -> q + qbar'
27803 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27804 IF(KFLR.GT.0) THEN
27805 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27806 ELSE
27807 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
27808 ENDIF
27809 ELSEIF(I.LE.12) THEN
27810C...W_R+/- -> l+/- + nu_R
27811 FCOF=1D0
27812 ENDIF
27813 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27814 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27815 WDTP(I)=FUDGE*WDTP(I)
27816 WDTP(0)=WDTP(0)+WDTP(I)
27817 IF(MDME(IDC,1).GT.0) THEN
27818 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27819 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27820 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27821 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27822 ENDIF
27823 500 CONTINUE
27824
27825 ELSEIF(KFLA.EQ.9900041) THEN
27826C...H_L++/--:
27827 FAC=(1D0/(8D0*PARU(1)))*SHR
27828 DO 510 I=1,MDCY(KC,3)
27829 IDC=I+MDCY(KC,2)-1
27830 IF(MDME(IDC,1).LT.0) GOTO 510
27831 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27832 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27833 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
27834 WID2=1D0
27835 IF(I.LE.6) THEN
27836C...H_L++/-- -> l+/- + l'+/-
27837 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27838 & (IABS(KFDP(IDC,2))-9)/2)**2
27839 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27840 ELSEIF(I.EQ.7) THEN
27841C...H_L++/-- -> W_L+/- + W_L+/-
27842 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
27843 & (3D0*RM1+0.25D0/RM1-1D0)
27844 WID2=WIDS(24,4+(1-KFLS)/2)
27845 ENDIF
27846 WDTP(I)=FAC*FCOF*
27847 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27848 WDTP(I)=FUDGE*WDTP(I)
27849 WDTP(0)=WDTP(0)+WDTP(I)
27850 IF(MDME(IDC,1).GT.0) THEN
27851 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27852 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27853 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27854 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27855 ENDIF
27856 510 CONTINUE
27857
27858 ELSEIF(KFLA.EQ.9900042) THEN
27859C...H_R++/--:
27860 FAC=(1D0/(8D0*PARU(1)))*SHR
27861 DO 520 I=1,MDCY(KC,3)
27862 IDC=I+MDCY(KC,2)-1
27863 IF(MDME(IDC,1).LT.0) GOTO 520
27864 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27865 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27866 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
27867 WID2=1D0
27868 IF(I.LE.6) THEN
27869C...H_R++/-- -> l+/- + l'+/-
27870 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27871 & (IABS(KFDP(IDC,2))-9)/2)**2
27872 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27873 ELSEIF(I.EQ.7) THEN
27874C...H_R++/-- -> W_R+/- + W_R+/-
27875 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
27876 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
27877 ENDIF
27878 WDTP(I)=FAC*FCOF*
27879 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27880 WDTP(I)=FUDGE*WDTP(I)
27881 WDTP(0)=WDTP(0)+WDTP(I)
27882 IF(MDME(IDC,1).GT.0) THEN
27883 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27884 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27885 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27886 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27887 ENDIF
27888 520 CONTINUE
27889
27890 ELSEIF(KFLA.EQ.KTECHN+115) THEN
27891C...Techni-a2:
27892C...Need to update to alpha_rho
27893 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27894 FAC=(ALPRHT/12D0)*SHR
27895 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
27896 SQMZ=PMAS(23,1)**2
27897 SQMW=PMAS(24,1)**2
27898 SHP=SH
27899 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
27900 GMMZ=SHR*WDTPP(0)
27901 XWRHT=1D0/(4D0*XW*(1D0-XW))
27902 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
27903 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
27904 DO 530 I=1,MDCY(KC,3)
27905 IDC=I+MDCY(KC,2)-1
27906 IF(MDME(IDC,1).LT.0) GOTO 530
27907 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27908 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27909 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
27910 WID2=1D0
27911 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27912 IF(I.LE.4) THEN
27913 FACPV=PCM**2
27914 FACPA=PCM**2+1.5D0*RM1
27915 VA2=0D0
27916 AA2=0D0
27917C...a2_tc0 -> W+ + W-
27918 IF(I.EQ.1) THEN
27919 AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
27920C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
27921 WID2=WIDS(24,1)
27922C...a2_tc0 -> W+ + pi_tc- + c.c.
27923 ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
27924 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27925 IF(I.EQ.6) THEN
27926 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27927 ELSE
27928 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
27929 ENDIF
27930 ELSEIF(I.EQ.4) THEN
27931C...a2_tc0 -> Z0 + pi_tc0'
27932 VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
27933 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27934 ENDIF
27935 WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
27936 ELSEIF(I.GE.5.AND.I.LE.10) THEN
27937 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27938 FACPA=PCM**2*(1D0+RM1+RM2)
27939 VA2=0D0
27940 AA2=0D0
27941 IF(I.EQ.5) THEN
27942C...a_T^0 -> gamma rho_T^0
27943 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27944 WID2=WIDS(PYCOMP(KTECHN+113),2)
27945 ELSEIF(I.EQ.6) THEN
27946C...a_T^0 -> gamma omega_T
27947 VA2=1D0/RTCM(50)**4
27948 WID2=WIDS(PYCOMP(KTECHN+223),2)
27949 ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
27950C...a_T^0 -> W^+- rho_T^-+
27951 AA2=.25D0/XW/RTCM(51)**4
27952 IF(I.EQ.7) THEN
27953 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
27954 ELSE
27955 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
27956 ENDIF
27957 ELSEIF(I.EQ.9) THEN
27958C...a_T^0 -> Z^0 rho_T^0
27959 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27960 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
27961 ELSEIF(I.EQ.10) THEN
27962C...a_T^0 -> Z^0 omega_T
27963 VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
27964 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
27965 ENDIF
27966 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27967 ELSE
27968C...a2_tc0 -> f + fbar.
27969 WID2=1D0
27970 IF(I.LE.18) THEN
27971 IA=I-10
27972 FCOF=3D0*RADC
27973 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27974 ELSE
27975 IA=I-8
27976 FCOF=1D0
27977 IF(IA.GE.17) WID2=WIDS(IA,1)
27978 ENDIF
27979 EI=KCHG(IA,1)/3D0
27980 AI=SIGN(1D0,EI+0.1D0)
27981 VI=AI-4D0*EI*XWV
27982 VALI=0.5D0*(VI+AI)
27983 VARI=0.5D0*(VI-AI)
27984 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27985 & ((VALI*BWZR)**2+(VALI*BWZI)**2+
27986 & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27987 & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
27988 ENDIF
27989 WDTP(I)=FUDGE*WDTP(I)
27990 WDTP(0)=WDTP(0)+WDTP(I)
27991 IF(MDME(IDC,1).GT.0) THEN
27992 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27993 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27994 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27995 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27996 ENDIF
27997 530 CONTINUE
27998
27999 ELSEIF(KFLA.EQ.KTECHN+215) THEN
28000C...Techni-a2+/-:
28001 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
28002 FAC=(ALPRHT/12D0)*SHR
28003 SQMZ=PMAS(23,1)**2
28004 SQMW=PMAS(24,1)**2
28005 SHP=SH
28006 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
28007 GMMW=SHR*WDTPP(0)
28008 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
28009 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
28010 DO 540 I=1,MDCY(KC,3)
28011 IDC=I+MDCY(KC,2)-1
28012 IF(MDME(IDC,1).LT.0) GOTO 540
28013 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
28014 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
28015 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
28016 WID2=1D0
28017 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28018 IF(KFLR.GT.0) THEN
28019 ICHANN=2
28020 ELSE
28021 ICHANN=3
28022 ENDIF
28023 IF(I.LE.7) THEN
28024 AA2=0
28025 VA2=0
28026C...a2_tc+ -> gamma + W+.
28027 IF(I.EQ.1) THEN
28028 AA2=RTCM(3)**2/RTCM(49)**2
28029 WID2=WIDS(24,ICHANN)
28030C...a2_tc+ -> gamma + pi_tc+.
28031 ELSEIF(I.EQ.2) THEN
28032 AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
28033 WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
28034C...a2_tc+ -> W+ + Z
28035 ELSEIF(I.EQ.3) THEN
28036 AA2=RTCM(3)**2*(1D0/4D0/XW1 +
28037 & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
28038 WID2=WIDS(24,ICHANN)*WIDS(23,2)
28039C...a2_tc+ -> W+ + pi_tc0.
28040 ELSEIF(I.EQ.4) THEN
28041 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
28042 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
28043C...a2_tc+ -> W+ + pi_tc'0.
28044 ELSEIF(I.EQ.5) THEN
28045 VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
28046 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
28047C...a2_tc+ -> Z0 + pi_tc+.
28048 ELSEIF(I.EQ.6) THEN
28049 AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
28050 & RTCM(49)**2
28051 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
28052 ENDIF
28053 WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
28054 & /3D0*SHR**3
28055 ELSEIF(I.LE.10) THEN
28056 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
28057 FACPA=PCM**2*(1D0+RM1+RM2)
28058 VA2=0D0
28059 AA2=0D0
28060C...a2_tc+ -> gamma + rho_tc+
28061 IF(I.EQ.7) THEN
28062 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
28063 WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
28064C...a2_tc+ -> W+ + rho_T^0
28065 ELSEIF(I.EQ.8) THEN
28066 AA2=1D0/(4D0*XW)/RTCM(51)**4
28067 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
28068C...a2_tc+ -> W+ + omega_T
28069 ELSEIF(I.EQ.9) THEN
28070 VA2=.25D0/XW/RTCM(50)**4
28071 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
28072C...a2_tc+ -> Z^0 + rho_T^+
28073 ELSEIF(I.EQ.10) THEN
28074 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
28075 AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
28076 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
28077 ENDIF
28078 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
28079 ELSE
28080C...a2_tc+ -> f + fbar'.
28081 IA=I-10
28082 WID2=1D0
28083 IF(IA.LE.16) THEN
28084 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
28085 IF(KFLR.GT.0) THEN
28086 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
28087 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
28088 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
28089 ELSE
28090 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
28091 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
28092 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
28093 ENDIF
28094 ELSE
28095 FCOF=1D0
28096 IF(KFLR.GT.0) THEN
28097 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
28098 ELSE
28099 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
28100 ENDIF
28101 ENDIF
28102 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
28103 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28104 ENDIF
28105 WDTP(I)=FUDGE*WDTP(I)
28106 WDTP(0)=WDTP(0)+WDTP(I)
28107 IF(MDME(IDC,1).GT.0) THEN
28108 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
28109 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
28110 WDTE(I,0)=WDTE(I,MDME(IDC,1))
28111 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
28112 ENDIF
28113 540 CONTINUE
28114
28115 ENDIF
28116 MINT(61)=0
28117 MINT(62)=0
28118 MINT(63)=0
28119 RETURN
28120 END
28121
28122C***********************************************************************
28123
28124C...PYOFSH
28125C...Calculates partial width and differential cross-section maxima
28126C...of channels/processes not allowed on mass-shell, and selects
28127C...masses in such channels/processes.
28128
28129 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
28130
28131C...Double precision and integer declarations.
28132 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28133 IMPLICIT INTEGER(I-N)
28134 INTEGER PYK,PYCHGE,PYCOMP
28135C...Commonblocks.
28136 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28137 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28138 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28139 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28140 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28141 COMMON/PYINT1/MINT(400),VINT(400)
28142 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28143 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
28144 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
28145 &/PYINT2/,/PYINT5/
28146C...Local arrays.
28147 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
28148 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
28149 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
28150 &WDTE(0:400,0:5)
28151
28152C...Find if particles equal, maximum mass, matrix elements, etc.
28153 MINT(51)=0
28154 ISUB=MINT(1)
28155 KFD(1)=IABS(KFD1)
28156 KFD(2)=IABS(KFD2)
28157 MEQL=0
28158 IF(KFD(1).EQ.KFD(2)) MEQL=1
28159 MLM=0
28160 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
28161 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
28162 NOFF=44
28163 PMMX=PMMO
28164 ELSE
28165 NOFF=40
28166 PMMX=VINT(1)
28167 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
28168 ENDIF
28169 MMED=0
28170 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
28171 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
28172 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
28173 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
28174 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
28175 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
28176 LOOP=1
28177
28178C...Find where Breit-Wigners are required, else select discrete masses.
28179 100 DO 110 I=1,2
28180 KFCA=PYCOMP(KFD(I))
28181 IF(KFCA.GT.0) THEN
28182 PMD(I)=PMAS(KFCA,1)
28183 PGD(I)=PMAS(KFCA,2)
28184 ELSE
28185 PMD(I)=0D0
28186 PGD(I)=0D0
28187 ENDIF
28188 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
28189 MBW(I)=0
28190 PMG(I)=PMD(I)
28191 RMG(I)=(PMG(I)/PMMX)**2
28192 ELSE
28193 MBW(I)=1
28194 ENDIF
28195 110 CONTINUE
28196
28197C...Find allowed mass range and Breit-Wigner parameters.
28198 DO 120 I=1,2
28199 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
28200 PML(I)=PARP(42)
28201 PMU(I)=PMMX-PARP(42)
28202 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
28203 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
28204 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
28205 ILM=I
28206 IF(MLM.EQ.2) ILM=3-I
28207 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
28208 IF(MBW(3-I).EQ.0) THEN
28209 PMU(I)=PMMX-PMD(3-I)
28210 ELSE
28211 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
28212 ENDIF
28213 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
28214 & MIN(PMU(I),CKIN(NOFF+2*ILM))
28215 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
28216 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
28217 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
28218 IF(MBW(I).EQ.1) THEN
28219 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28220 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28221 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
28222 & PGD(I)))
28223 ENDIF
28224 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
28225 ILM=I
28226 IF(MLM.EQ.2) ILM=3-I
28227 PML(I)=MAX(CKIN(48+I),PARP(42))
28228 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
28229 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
28230 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
28231 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
28232 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
28233 IF(MBW(I).EQ.1) THEN
28234 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28235 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28236 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
28237 & PGD(I)))
28238 ENDIF
28239 ENDIF
28240 120 CONTINUE
28241 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
28242 &THEN
28243 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
28244 MINT(51)=1
28245 RETURN
28246 ENDIF
28247
28248C...Calculation of partial width of resonance.
28249 IF(MOFSH.EQ.1) THEN
28250
28251C..If only one integration, pick that to be the inner.
28252 IF(MBW(1).EQ.0) THEN
28253 PM2=PMD(1)
28254 PMD(1)=PMD(2)
28255 PGD(1)=PGD(2)
28256 PML(1)=PML(2)
28257 PMU(1)=PMU(2)
28258 ELSEIF(MBW(2).EQ.0) THEN
28259 PM2=PMD(2)
28260 ENDIF
28261
28262C...Start outer loop of integration.
28263 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
28264 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
28265 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
28266 NPT2=1
28267 XPT2(1)=1D0
28268 INX2(1)=0
28269 FMAX2=0D0
28270 ENDIF
28271 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
28272 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
28273 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
28274 ENDIF
28275 RM2=(PM2/PMMX)**2
28276
28277C...Start inner loop of integration.
28278 PML1=PML(1)
28279 PMU1=MIN(PMU(1),PMMX-PM2)
28280 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
28281 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
28282 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
28283 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
28284 FUNC2=0D0
28285 GOTO 180
28286 ENDIF
28287 NPT1=1
28288 XPT1(1)=1D0
28289 INX1(1)=0
28290 FMAX1=0D0
28291 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
28292 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
28293 RM1=(PM1/PMMX)**2
28294
28295C...Evaluate function value - inner loop.
28296 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28297 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
28298 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
28299 & RM2**2+10D0*RM1*RM2)
28300 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
28301 FPT1(NPT1)=FUNC1
28302
28303C...Go to next position in inner loop.
28304 IF(NPT1.EQ.1) THEN
28305 NPT1=NPT1+1
28306 XPT1(NPT1)=0D0
28307 INX1(NPT1)=1
28308 GOTO 140
28309 ELSEIF(NPT1.LE.8) THEN
28310 NPT1=NPT1+1
28311 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
28312 ISH1=ISH1+1
28313 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
28314 INX1(NPT1)=INX1(ISH1)
28315 INX1(ISH1)=NPT1
28316 GOTO 140
28317 ELSEIF(NPT1.LT.100) THEN
28318 ISN1=ISH1
28319 150 ISH1=ISH1+1
28320 IF(ISH1.GT.NPT1) ISH1=2
28321 IF(ISH1.EQ.ISN1) GOTO 160
28322 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
28323 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
28324 NPT1=NPT1+1
28325 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
28326 INX1(NPT1)=INX1(ISH1)
28327 INX1(ISH1)=NPT1
28328 GOTO 140
28329 ENDIF
28330
28331C...Calculate integral over inner loop.
28332 160 FSUM1=0D0
28333 DO 170 IPT1=2,NPT1
28334 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
28335 & (XPT1(INX1(IPT1))-XPT1(IPT1))
28336 170 CONTINUE
28337 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
28338 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
28339 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
28340 FPT2(NPT2)=FUNC2
28341
28342C...Go to next position in outer loop.
28343 IF(NPT2.EQ.1) THEN
28344 NPT2=NPT2+1
28345 XPT2(NPT2)=0D0
28346 INX2(NPT2)=1
28347 GOTO 130
28348 ELSEIF(NPT2.LE.8) THEN
28349 NPT2=NPT2+1
28350 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
28351 ISH2=ISH2+1
28352 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
28353 INX2(NPT2)=INX2(ISH2)
28354 INX2(ISH2)=NPT2
28355 GOTO 130
28356 ELSEIF(NPT2.LT.100) THEN
28357 ISN2=ISH2
28358 190 ISH2=ISH2+1
28359 IF(ISH2.GT.NPT2) ISH2=2
28360 IF(ISH2.EQ.ISN2) GOTO 200
28361 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
28362 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
28363 NPT2=NPT2+1
28364 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
28365 INX2(NPT2)=INX2(ISH2)
28366 INX2(ISH2)=NPT2
28367 GOTO 130
28368 ENDIF
28369
28370C...Calculate integral over outer loop.
28371 200 FSUM2=0D0
28372 DO 210 IPT2=2,NPT2
28373 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
28374 & (XPT2(INX2(IPT2))-XPT2(IPT2))
28375 210 CONTINUE
28376 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
28377 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
28378 ELSE
28379 FSUM2=FUNC2
28380 ENDIF
28381
28382C...Save result; second integration for user-selected mass range.
28383 IF(LOOP.EQ.1) WIDW=FSUM2
28384 WID2=FSUM2
28385 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
28386 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
28387 LOOP=2
28388 GOTO 100
28389 ENDIF
28390 RET1=WIDW
28391 RET2=WID2/WIDW
28392
28393C...Select two decay product masses of a resonance.
28394 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
28395 220 DO 230 I=1,2
28396 IF(MBW(I).EQ.0) GOTO 230
28397 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
28398 & (ATU(I)-ATL(I)))
28399 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
28400 RMG(I)=(PMG(I)/PMMX)**2
28401 230 CONTINUE
28402 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
28403 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
28404
28405C...Weight with matrix element (if none known, use beta factor).
28406 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
28407 IF(MMED.EQ.1) THEN
28408 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
28409 ELSEIF(MMED.EQ.2) THEN
28410 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
28411 & RMG(2)**2+10D0*RMG(1)*RMG(2))
28412 ELSEIF(MMED.EQ.3) THEN
28413 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
28414 ELSE
28415 WTBE=FLAM
28416 ENDIF
28417 IF(WTBE.LT.PYR(0)) GOTO 220
28418 RET1=PMG(1)
28419 RET2=PMG(2)
28420
28421C...Find suitable set of masses for initialization of 2 -> 2 processes.
28422 ELSEIF(MOFSH.EQ.3) THEN
28423 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
28424 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
28425 PMG(2)=PMD(2)
28426 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
28427 PMG(1)=PMD(1)
28428 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
28429 ELSE
28430 IDIV=-1
28431 240 IDIV=IDIV+1
28432 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
28433 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
28434 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
28435 ENDIF
28436 RET1=PMG(1)
28437 RET2=PMG(2)
28438
28439C...Evaluate importance of excluded tails of Breit-Wigners.
28440 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
28441 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
28442 IF(MEQL.LE.1) THEN
28443 VINT(80)=1D0
28444 DO 250 I=1,2
28445 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
28446 & PARU(1)
28447 250 CONTINUE
28448 ELSE
28449 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
28450 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
28451 ENDIF
28452 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
28453 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
28454 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
28455 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
28456
28457C...Pick one particle to be the lighter (if improves efficiency).
28458 ELSEIF(MOFSH.EQ.4) THEN
28459 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
28460 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
28461 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
28462
28463C...Select two masses according to Breit-Wigner + flat in s + 1/s.
28464 DO 270 I=1,2
28465 IF(MBW(I).EQ.0) GOTO 270
28466 PMV=PMU(I)
28467 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
28468 ATV=ATU(I)
28469 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
28470 RBR=PYR(0)
28471 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
28472 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
28473 IF(RBR.LT.0.8D0) THEN
28474 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
28475 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
28476 ELSEIF(RBR.LT.0.9D0) THEN
28477 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
28478 ELSEIF(RBR.LT.1.5D0) THEN
28479 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
28480 ELSE
28481 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
28482 & (PMV**2-PML(I)**2))))
28483 ENDIF
28484 270 CONTINUE
28485 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
28486 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
28487 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
28488 NGEN(0,1)=NGEN(0,1)+1
28489 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
28490 GOTO 260
28491 ELSE
28492 MINT(51)=1
28493 RETURN
28494 ENDIF
28495 ENDIF
28496 RET1=PMG(1)
28497 RET2=PMG(2)
28498
28499C...Give weight for selected mass distribution.
28500 VINT(80)=1D0
28501 DO 280 I=1,2
28502 IF(MBW(I).EQ.0) GOTO 280
28503 PMV=PMU(I)
28504 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
28505 ATV=ATU(I)
28506 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
28507 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
28508 & (PMD(I)*PGD(I))**2)/PARU(1)
28509 F1=1D0
28510 F2=1D0/PMG(I)**2
28511 F3=1D0/PMG(I)**4
28512 FI0=(ATV-ATL(I))/PARU(1)
28513 FI1=PMV**2-PML(I)**2
28514 FI2=2D0*LOG(PMV/PML(I))
28515 FI3=1D0/PML(I)**2-1D0/PMV**2
28516 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
28517 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
28518 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
28519 & 5D0*F3/FI3))
28520 ELSE
28521 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
28522 ENDIF
28523 VINT(80)=VINT(80)*FI0
28524 280 CONTINUE
28525 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
28526 ENDIF
28527
28528 RETURN
28529 END
28530
28531C***********************************************************************
28532
28533C...PYRECO
28534C...Handles the possibility of colour reconnection in W+W- events,
28535C...Based on the main scenarios of the Sjostrand and Khoze study:
28536C...I, II, II', intermediate and instantaneous; plus one model
28537C...along the lines of the Gustafson and Hakkinen: GH.
28538C...Note: also handles Z0 Z0 and W-W+ events, but notation below
28539C...is as if first resonance is W+ and second W-.
28540
28541 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
28542
28543C...Double precision and integer declarations.
28544 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28545 IMPLICIT INTEGER(I-N)
28546 INTEGER PYK,PYCHGE,PYCOMP
28547C...Parameter value; number of points in MC integration.
28548 PARAMETER (NPT=100)
28549C...Commonblocks.
28550 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28551 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28552 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28553 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28554 COMMON/PYINT1/MINT(400),VINT(400)
28555 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28556C...Local arrays.
28557 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
28558 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
28559 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
28560 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
28561 &TMC(20),IJOIN(100)
28562
28563C...Functions to give four-product and to do determinants.
28564 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)
28565 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
28566 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
28567 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
28568
28569C...Only allow fraction of recoupling for GH, intermediate and
28570C...instantaneous.
28571 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
28572 IF(PYR(0).GT.PARP(120)) RETURN
28573 ENDIF
28574 ISUB=MINT(1)
28575
28576C...Common part for scenarios I, II, II', and GH.
28577 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
28578 &MSTP(115).EQ.5) THEN
28579
28580C...Read out frequently-used parameters.
28581 PI=PARU(1)
28582 HBAR=PARU(3)
28583 PMW=PMAS(24,1)
28584 IF(ISUB.EQ.22) PMW=PMAS(23,1)
28585 PGW=PMAS(24,2)
28586 IF(ISUB.EQ.22) PGW=PMAS(23,2)
28587 TFRAG=PARP(115)
28588 RHAD=PARP(116)
28589 FACT=PARP(117)
28590 BLOWR=PARP(118)
28591 BLOWT=PARP(119)
28592
28593C...Find range of decay products of the W's.
28594C...Background: the W's are stored in IW1 and IW2.
28595C...Their direct decay products in NSD1+1 through NSD1+4.
28596C...Products after shower (if any) in NSD1+5 through NAFT1
28597C...for first W and in NAFT1+1 through N for the second.
28598 IF(NAFT1.GT.NSD1+4) THEN
28599 NBEG(1)=NSD1+5
28600 NEND(1)=NAFT1
28601 ELSE
28602 NBEG(1)=NSD1+1
28603 NEND(1)=NSD1+2
28604 ENDIF
28605 IF(N.GT.NAFT1) THEN
28606 NBEG(2)=NAFT1+1
28607 NEND(2)=N
28608 ELSE
28609 NBEG(2)=NSD1+3
28610 NEND(2)=NSD1+4
28611 ENDIF
28612
28613C...Rearrange parton shower products along strings.
28614 NOLD=N
28615 CALL PYPREP(NSD1+1)
28616 IF(MINT(51).NE.0) RETURN
28617
28618C...Find partons pointing back to W+ and W-; store them with quark
28619C...end of string first.
28620 NNP=0
28621 NNM=0
28622 ISGP=0
28623 ISGM=0
28624 DO 120 I=NOLD+1,N
28625 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
28626 IF(IABS(K(I,2)).GE.22) GOTO 120
28627 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
28628 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
28629 NNP=NNP+1
28630 IF(ISGP.EQ.1) THEN
28631 INP(NNP)=I
28632 ELSE
28633 DO 100 I1=NNP,2,-1
28634 INP(I1)=INP(I1-1)
28635 100 CONTINUE
28636 INP(1)=I
28637 ENDIF
28638 IF(K(I,1).EQ.1) ISGP=0
28639 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
28640 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
28641 NNM=NNM+1
28642 IF(ISGM.EQ.1) THEN
28643 INM(NNM)=I
28644 ELSE
28645 DO 110 I1=NNM,2,-1
28646 INM(I1)=INM(I1-1)
28647 110 CONTINUE
28648 INM(1)=I
28649 ENDIF
28650 IF(K(I,1).EQ.1) ISGM=0
28651 ENDIF
28652 120 CONTINUE
28653
28654C...Boost to W+W- rest frame (not strictly needed).
28655 DO 130 J=1,3
28656 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
28657 130 CONTINUE
28658 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28659 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28660 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28661
28662C...Select decay vertices of W+ and W-.
28663 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
28664 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
28665 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
28666 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
28667 GTMAX=MAX(TP,TM)
28668 DO 140 J=1,3
28669 XP(J)=TP*P(IW1,J)/P(IW1,4)
28670 XM(J)=TM*P(IW2,J)/P(IW2,4)
28671 140 CONTINUE
28672
28673C...Begin scenario I specifics.
28674 IF(MSTP(115).EQ.1) THEN
28675
28676C...Reconstruct velocity and direction of W+ string pieces.
28677 DO 170 IIP=1,NNP-1
28678 IF(K(INP(IIP),2).LT.0) GOTO 170
28679 I1=INP(IIP)
28680 I2=INP(IIP+1)
28681 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28682 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28683 DO 150 J=1,3
28684 V1(J)=P(I1,J)/P1A
28685 V2(J)=P(I2,J)/P2A
28686 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
28687 DIRP(IIP,J)=V1(J)-V2(J)
28688 150 CONTINUE
28689 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
28690 & BETP(IIP,3)**2)
28691 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
28692 DO 160 J=1,3
28693 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
28694 160 CONTINUE
28695 170 CONTINUE
28696
28697C...Reconstruct velocity and direction of W- string pieces.
28698 DO 200 IIM=1,NNM-1
28699 IF(K(INM(IIM),2).LT.0) GOTO 200
28700 I1=INM(IIM)
28701 I2=INM(IIM+1)
28702 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28703 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28704 DO 180 J=1,3
28705 V1(J)=P(I1,J)/P1A
28706 V2(J)=P(I2,J)/P2A
28707 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
28708 DIRM(IIM,J)=V1(J)-V2(J)
28709 180 CONTINUE
28710 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
28711 & BETM(IIM,3)**2)
28712 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
28713 DO 190 J=1,3
28714 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
28715 190 CONTINUE
28716 200 CONTINUE
28717
28718C...Loop over number of space-time points.
28719 NACC=0
28720 SUM=0D0
28721 DO 250 IPT=1,NPT
28722
28723C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
28724 R=SQRT(-LOG(PYR(0)))
28725 PHI=2D0*PI*PYR(0)
28726 X=BLOWR*RHAD*R*COS(PHI)
28727 Y=BLOWR*RHAD*R*SIN(PHI)
28728 R=SQRT(-LOG(PYR(0)))
28729 PHI=2D0*PI*PYR(0)
28730 Z=BLOWR*RHAD*R*COS(PHI)
28731 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
28732
28733C...Reject impossible points. Weight for sample distribution.
28734 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
28735 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
28736 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
28737
28738C...Loop over W+ string pieces and find one with largest weight.
28739 IMAXP=0
28740 WTMAXP=1D-10
28741 XD(1)=X-XP(1)
28742 XD(2)=Y-XP(2)
28743 XD(3)=Z-XP(3)
28744 XD(4)=T-TP
28745 DO 220 IIP=1,NNP-1
28746 IF(K(INP(IIP),2).LT.0) GOTO 220
28747 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
28748 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
28749 DO 210 J=1,3
28750 XB(J)=XD(J)+BEDG*BETP(IIP,J)
28751 210 CONTINUE
28752 XB(4)=BETP(IIP,4)*(XD(4)-BED)
28753 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28754 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
28755 & DIRP(IIP,3)*XB(3))**2
28756 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28757 & TFRAG**2)
28758 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
28759 IF(WTP.GT.WTMAXP) THEN
28760 IMAXP=IIP
28761 WTMAXP=WTP
28762 ENDIF
28763 220 CONTINUE
28764
28765C...Loop over W- string pieces and find one with largest weight.
28766 IMAXM=0
28767 WTMAXM=1D-10
28768 XD(1)=X-XM(1)
28769 XD(2)=Y-XM(2)
28770 XD(3)=Z-XM(3)
28771 XD(4)=T-TM
28772 DO 240 IIM=1,NNM-1
28773 IF(K(INM(IIM),2).LT.0) GOTO 240
28774 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
28775 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
28776 DO 230 J=1,3
28777 XB(J)=XD(J)+BEDG*BETM(IIM,J)
28778 230 CONTINUE
28779 XB(4)=BETM(IIM,4)*(XD(4)-BED)
28780 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28781 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
28782 & DIRM(IIM,3)*XB(3))**2
28783 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28784 & TFRAG**2)
28785 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
28786 IF(WTM.GT.WTMAXM) THEN
28787 IMAXM=IIM
28788 WTMAXM=WTM
28789 ENDIF
28790 240 CONTINUE
28791
28792C...Result of integration.
28793 WT=0D0
28794 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
28795 WT=WTMAXP*WTMAXM/WTSMP
28796 SUM=SUM+WT
28797 NACC=NACC+1
28798 IAP(NACC)=IMAXP
28799 IAM(NACC)=IMAXM
28800 WTA(NACC)=WT
28801 ENDIF
28802 250 CONTINUE
28803 RES=BLOWR**3*BLOWT*SUM/NPT
28804
28805C...Decide whether to reconnect and, if so, where.
28806 IACC=0
28807 PREC=1D0-EXP(-FACT*RES)
28808 IF(PREC.GT.PYR(0)) THEN
28809 RSUM=PYR(0)*SUM
28810 DO 260 IA=1,NACC
28811 IACC=IA
28812 RSUM=RSUM-WTA(IA)
28813 IF(RSUM.LE.0D0) GOTO 270
28814 260 CONTINUE
28815 270 IIP=IAP(IACC)
28816 IIM=IAM(IACC)
28817 ENDIF
28818
28819C...Begin scenario II and II' specifics.
28820 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
28821
28822C...Loop through all string pieces, one from W+ and one from W-.
28823 NCROSS=0
28824 TC(0)=0D0
28825 DO 340 IIP=1,NNP-1
28826 IF(K(INP(IIP),2).LT.0) GOTO 340
28827 I1P=INP(IIP)
28828 I2P=INP(IIP+1)
28829 DO 330 IIM=1,NNM-1
28830 IF(K(INM(IIM),2).LT.0) GOTO 330
28831 I1M=INM(IIM)
28832 I2M=INM(IIM+1)
28833
28834C...Find endpoint velocity vectors.
28835 DO 280 J=1,3
28836 V1P(J)=P(I1P,J)/P(I1P,4)
28837 V2P(J)=P(I2P,J)/P(I2P,4)
28838 V1M(J)=P(I1M,J)/P(I1M,4)
28839 V2M(J)=P(I2M,J)/P(I2M,4)
28840 280 CONTINUE
28841
28842C...Define q matrix and find t.
28843 DO 290 J=1,3
28844 Q(1,J)=V2P(J)-V1P(J)
28845 Q(2,J)=-(V2M(J)-V1M(J))
28846 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
28847 Q(4,J)=V1P(J)-V1M(J)
28848 290 CONTINUE
28849 T=-DETER(1,2,3)/DETER(1,2,4)
28850
28851C...Find alpha and beta; i.e. coordinates of crossing point.
28852 S11=Q(1,1)*(T-TP)
28853 S12=Q(2,1)*(T-TM)
28854 S13=Q(3,1)+Q(4,1)*T
28855 S21=Q(1,2)*(T-TP)
28856 S22=Q(2,2)*(T-TM)
28857 S23=Q(3,2)+Q(4,2)*T
28858 DEN=S11*S22-S12*S21
28859 ALP=(S12*S23-S22*S13)/DEN
28860 BET=(S21*S13-S11*S23)/DEN
28861
28862C...Check if solution acceptable.
28863 IANSW=1
28864 IF(T.LT.GTMAX) IANSW=0
28865 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
28866 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
28867
28868C...Find point of crossing and check that not inconsistent.
28869 DO 300 J=1,3
28870 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
28871 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
28872 300 CONTINUE
28873 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
28874 & (XPP(3)-XMM(3))**2
28875 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
28876 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
28877 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
28878
28879C...Find string eigentimes at crossing.
28880 IF(IANSW.EQ.1) THEN
28881 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
28882 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
28883 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
28884 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
28885 ELSE
28886 TAUP=0D0
28887 TAUM=0D0
28888 ENDIF
28889
28890C...Order crossings by time. End loop over crossings.
28891 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
28892 NCROSS=NCROSS+1
28893 DO 310 I1=NCROSS,1,-1
28894 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
28895 IPC(I1)=IIP
28896 IMC(I1)=IIM
28897 TC(I1)=T
28898 TPC(I1)=TAUP
28899 TMC(I1)=TAUM
28900 GOTO 320
28901 ELSE
28902 IPC(I1)=IPC(I1-1)
28903 IMC(I1)=IMC(I1-1)
28904 TC(I1)=TC(I1-1)
28905 TPC(I1)=TPC(I1-1)
28906 TMC(I1)=TMC(I1-1)
28907 ENDIF
28908 310 CONTINUE
28909 320 CONTINUE
28910 ENDIF
28911 330 CONTINUE
28912 340 CONTINUE
28913
28914C...Loop over crossings; find first (if any) acceptable one.
28915 IACC=0
28916 IF(NCROSS.GE.1) THEN
28917 DO 350 IC=1,NCROSS
28918 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
28919 IF(PNFRAG.GT.PYR(0)) THEN
28920C...Scenario II: only compare with fragmentation time.
28921 IF(MSTP(115).EQ.2) THEN
28922 IACC=IC
28923 IIP=IPC(IACC)
28924 IIM=IMC(IACC)
28925 GOTO 360
28926C...Scenario II': also require that string length decreases.
28927 ELSE
28928 IIP=IPC(IC)
28929 IIM=IMC(IC)
28930 I1P=INP(IIP)
28931 I2P=INP(IIP+1)
28932 I1M=INM(IIM)
28933 I2M=INM(IIM+1)
28934 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28935 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28936 IF(ELNEW.LT.ELOLD) THEN
28937 IACC=IC
28938 IIP=IPC(IACC)
28939 IIM=IMC(IACC)
28940 GOTO 360
28941 ENDIF
28942 ENDIF
28943 ENDIF
28944 350 CONTINUE
28945 360 CONTINUE
28946 ENDIF
28947
28948C...Begin scenario GH specifics.
28949 ELSEIF(MSTP(115).EQ.5) THEN
28950
28951C...Loop through all string pieces, one from W+ and one from W-.
28952 IACC=0
28953 ELMIN=1D0
28954 DO 380 IIP=1,NNP-1
28955 IF(K(INP(IIP),2).LT.0) GOTO 380
28956 I1P=INP(IIP)
28957 I2P=INP(IIP+1)
28958 DO 370 IIM=1,NNM-1
28959 IF(K(INM(IIM),2).LT.0) GOTO 370
28960 I1M=INM(IIM)
28961 I2M=INM(IIM+1)
28962
28963C...Look for largest decrease of (exponent of) Lambda measure.
28964 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28965 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28966 ELDIF=ELNEW/MAX(1D-10,ELOLD)
28967 IF(ELDIF.LT.ELMIN) THEN
28968 IACC=IIP+IIM
28969 ELMIN=ELDIF
28970 IPC(1)=IIP
28971 IMC(1)=IIM
28972 ENDIF
28973 370 CONTINUE
28974 380 CONTINUE
28975 IIP=IPC(1)
28976 IIM=IMC(1)
28977 ENDIF
28978
28979C...Common for scenarios I, II, II' and GH: reconnect strings.
28980 IF(IACC.NE.0) THEN
28981 MINT(32)=1
28982 NJOIN=0
28983 DO 390 IS=1,NNP+NNM
28984 NJOIN=NJOIN+1
28985 IF(IS.LE.IIP) THEN
28986 I=INP(IS)
28987 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
28988 I=INM(IS-IIP+IIM)
28989 ELSEIF(IS.LE.IIP+NNM) THEN
28990 I=INM(IS-IIP-NNM+IIM)
28991 ELSE
28992 I=INP(IS-NNM)
28993 ENDIF
28994 IJOIN(NJOIN)=I
28995 IF(K(I,2).LT.0) THEN
28996 CALL PYJOIN(NJOIN,IJOIN)
28997 NJOIN=0
28998 ENDIF
28999 390 CONTINUE
29000
29001C...Restore original event record if no reconnection.
29002 ELSE
29003 DO 400 I=NSD1+1,NOLD
29004 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
29005 K(I,4)=MOD(K(I,4),MSTU(5)**2)
29006 K(I,5)=MOD(K(I,5),MSTU(5)**2)
29007 ENDIF
29008 400 CONTINUE
29009 DO 410 I=NOLD+1,N
29010 K(K(I,3),1)=3
29011 410 CONTINUE
29012 N=NOLD
29013 ENDIF
29014
29015C...Boost back system.
29016 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
29017 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
29018 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
29019 & BEWW(1),BEWW(2),BEWW(3))
29020
29021C...Common part for intermediate and instantaneous scenarios.
29022 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
29023 MINT(32)=1
29024
29025C...Remove old shower products and reset showering ones.
29026 N=NSD1+4
29027 DO 420 I=NSD1+1,NSD1+4
29028 K(I,1)=3
29029 K(I,4)=MOD(K(I,4),MSTU(5)**2)
29030 K(I,5)=MOD(K(I,5),MSTU(5)**2)
29031 420 CONTINUE
29032
29033C...Identify quark-antiquark pairs.
29034 IQ1=NSD1+1
29035 IQ2=NSD1+2
29036 IQ3=NSD1+3
29037 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
29038 IQ4=2*NSD1+7-IQ3
29039
29040C...Reconnect strings.
29041 IJOIN(1)=IQ1
29042 IJOIN(2)=IQ4
29043 CALL PYJOIN(2,IJOIN)
29044 IJOIN(1)=IQ3
29045 IJOIN(2)=IQ2
29046 CALL PYJOIN(2,IJOIN)
29047
29048C...Do new parton showers in intermediate scenario.
29049 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
29050 MSTJ50=MSTJ(50)
29051 MSTJ(50)=0
29052 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
29053 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
29054 MSTJ(50)=MSTJ50
29055
29056C...Do new parton showers in instantaneous scenario.
29057 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
29058 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
29059 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
29060 PPM=SQRT(MAX(0D0,PPM2))
29061 CALL PYSHOW(IQ1,IQ4,PPM)
29062 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
29063 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
29064 PPM=SQRT(MAX(0D0,PPM2))
29065 CALL PYSHOW(IQ3,IQ2,PPM)
29066 ENDIF
29067 ENDIF
29068
29069 RETURN
29070 END
29071
29072C***********************************************************************
29073
29074C...PYKLIM
29075C...Checks generated variables against pre-set kinematical limits;
29076C...also calculates limits on variables used in generation.
29077
29078 SUBROUTINE PYKLIM(ILIM)
29079
29080C...Double precision and integer declarations.
29081 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29082 IMPLICIT INTEGER(I-N)
29083 INTEGER PYK,PYCHGE,PYCOMP
29084C...Commonblocks.
29085 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
29086 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29087 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29088 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29089 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29090 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29091 COMMON/PYINT1/MINT(400),VINT(400)
29092 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29093 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
29094 &/PYINT1/,/PYINT2/
29095
29096C...Common kinematical expressions.
29097 MINT(51)=0
29098 ISUB=MINT(1)
29099 ISTSB=ISET(ISUB)
29100 IF(ISUB.EQ.96) GOTO 100
29101 SQM3=VINT(63)
29102 SQM4=VINT(64)
29103 IF(ILIM.NE.0) THEN
29104 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
29105 CKIN09=MAX(CKIN(9),CKIN(13))
29106 CKIN10=MIN(CKIN(10),CKIN(14))
29107 CKIN11=MAX(CKIN(11),CKIN(15))
29108 CKIN12=MIN(CKIN(12),CKIN(16))
29109 ELSE
29110 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
29111 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
29112 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
29113 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
29114 ENDIF
29115 ENDIF
29116 IF(ILIM.NE.1) THEN
29117 TAU=VINT(21)
29118 RM3=SQM3/(TAU*VINT(2))
29119 RM4=SQM4/(TAU*VINT(2))
29120 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
29121 ENDIF
29122 PTHMIN=CKIN(3)
29123 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
29124 &PTHMIN=MAX(CKIN(3),CKIN(5))
29125
29126 IF(ILIM.EQ.0) THEN
29127C...Check generated values of tau, y*, cos(theta-hat), and tau' against
29128C...pre-set kinematical limits.
29129 YST=VINT(22)
29130 CTH=VINT(23)
29131 TAUP=VINT(26)
29132 TAUE=TAU
29133 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
29134 X1=SQRT(TAUE)*EXP(YST)
29135 X2=SQRT(TAUE)*EXP(-YST)
29136 XF=X1-X2
29137 IF(MINT(47).NE.1) THEN
29138 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
29139 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
29140 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
29141 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
29142 ENDIF
29143 IF(MINT(45).NE.1) THEN
29144 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
29145 ENDIF
29146 IF(MINT(46).NE.1) THEN
29147 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
29148 ENDIF
29149 IF(MINT(45).EQ.2) THEN
29150 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
29151 ENDIF
29152 IF(MINT(46).EQ.2) THEN
29153 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
29154 ENDIF
29155 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
29156 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
29157 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
29158 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
29159 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
29160 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
29161 Y3=YST+0.5D0*LOG(EXPY3)
29162 Y4=YST+0.5D0*LOG(EXPY4)
29163 YLARGE=MAX(Y3,Y4)
29164 YSMALL=MIN(Y3,Y4)
29165 ETALAR=20D0
29166 ETASMA=-20D0
29167 STH=SQRT(MAX(0D0,1D0-CTH**2))
29168 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
29169 & CTH)**2-4D0*RM3))
29170 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
29171 & CTH)**2-4D0*RM4))
29172 IF(STH.GE.1D-10) THEN
29173 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
29174 & (BE34*STH)
29175 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
29176 & (BE34*STH)
29177 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
29178 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
29179 ETALAR=MAX(ETA3,ETA4)
29180 ETASMA=MIN(ETA3,ETA4)
29181 ENDIF
29182 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
29183 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
29184 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
29185 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
29186 SH=TAU*VINT(2)
29187 RPTS=4D0*VINT(71)**2/SH
29188 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
29189 RM34=MAX(1D-20,2D0*RM3*RM4)
29190 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
29191 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
29192 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
29193 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
29194 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
29195 IF(PTH.LT.PTHMIN) MINT(51)=1
29196 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
29197 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
29198 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
29199 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
29200 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
29201 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
29202 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
29203 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
29204 IF(THA.LT.CKIN(35)) MINT(51)=1
29205 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
29206 IF(UHA.LT.CKIN(37)) MINT(51)=1
29207 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
29208 ENDIF
29209 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29210 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
29211 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
29212 ENDIF
29213
29214C...Additional cuts on W2 (approximately) in DIS.
29215 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
29216 XBJ=X2
29217 IF(IABS(MINT(12)).LT.20) XBJ=X1
29218 Q2BJ=THA
29219 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
29220 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
29221 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
29222 ENDIF
29223
29224 ELSEIF(ILIM.EQ.1) THEN
29225C...Calculate limits on tau
29226C...0) due to definition
29227 TAUMN0=0D0
29228 TAUMX0=1D0
29229C...1) due to limits on subsystem mass
29230 TAUMN1=CKIN(1)**2/VINT(2)
29231 TAUMX1=1D0
29232 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
29233C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
29234 TM3=SQRT(SQM3+PTHMIN**2)
29235 TM4=SQRT(SQM4+PTHMIN**2)
29236 YDCOSH=1D0
29237 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
29238 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
29239 TAUMX2=1D0
29240C...3) due to limits on pT-hat and cos(theta-hat)
29241 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
29242 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
29243 TAUMN3=0D0
29244 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
29245 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
29246 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
29247 TAUMX3=1D0
29248 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
29249 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
29250 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
29251C...4) due to limits on x1 and x2
29252 TAUMN4=CKIN(21)*CKIN(23)
29253 TAUMX4=CKIN(22)*CKIN(24)
29254C...5) due to limits on xF
29255 TAUMN5=0D0
29256 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
29257C...6) due to limits on that and uhat
29258 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
29259 TAUMX6=1D0
29260 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
29261 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
29262
29263C...Net effect of all separate limits.
29264 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
29265 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
29266 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
29267 VINT(11)=1D0-1D-9
29268 VINT(31)=1D0+1D-9
29269 ELSEIF(MINT(47).EQ.5) THEN
29270 VINT(31)=MIN(VINT(31),1D0-2D-10)
29271 ELSEIF(MINT(47).GE.6) THEN
29272 VINT(31)=MIN(VINT(31),1D0-1D-10)
29273 ENDIF
29274 IF(VINT(31).LE.VINT(11)) MINT(51)=1
29275
29276 ELSEIF(ILIM.EQ.2) THEN
29277C...Calculate limits on y*
29278 TAUE=TAU
29279 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
29280 TAURT=SQRT(TAUE)
29281C...0) due to kinematics
29282 YSTMN0=LOG(TAURT)
29283 YSTMX0=-YSTMN0
29284C...1) due to explicit limits
29285 YSTMN1=CKIN(7)
29286 YSTMX1=CKIN(8)
29287C...2) due to limits on x1
29288 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
29289 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
29290C...3) due to limits on x2
29291 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
29292 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
29293C...4) due to limits on xF
29294 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
29295 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
29296 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
29297 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
29298C...5) due to simultaneous limits on y-large and y-small
29299 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
29300 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
29301 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
29302 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
29303 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
29304 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
29305C...6) due to simultaneous limits on cos(theta-hat) and y-large or
29306C... y-small
29307 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
29308 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
29309 RZMX=BE34*MIN(CKIN(28),CTHLIM)
29310 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
29311 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
29312 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
29313 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
29314 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
29315 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
29316
29317C...Net effect of all separate limits.
29318 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
29319 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
29320 IF(MINT(47).EQ.1) THEN
29321 VINT(12)=-1D-9
29322 VINT(32)=1D-9
29323 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
29324 VINT(12)=(1D0-1D-9)*YSTMX0
29325 VINT(32)=(1D0+1D-9)*YSTMX0
29326 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
29327 VINT(12)=-(1D0+1D-9)*YSTMX0
29328 VINT(32)=-(1D0-1D-9)*YSTMX0
29329 ELSEIF(MINT(47).EQ.5) THEN
29330 YSTEE=LOG((1D0-1D-10)/TAURT)
29331 VINT(12)=MAX(VINT(12),-YSTEE)
29332 VINT(32)=MIN(VINT(32),YSTEE)
29333 ENDIF
29334 IF(VINT(32).LE.VINT(12)) MINT(51)=1
29335
29336 ELSEIF(ILIM.EQ.3) THEN
29337C...Calculate limits on cos(theta-hat)
29338 YST=VINT(22)
29339C...0) due to definition
29340 CTNMN0=-1D0
29341 CTNMX0=0D0
29342 CTPMN0=0D0
29343 CTPMX0=1D0
29344C...1) due to explicit limits
29345 CTNMN1=MIN(0D0,CKIN(27))
29346 CTNMX1=MIN(0D0,CKIN(28))
29347 CTPMN1=MAX(0D0,CKIN(27))
29348 CTPMX1=MAX(0D0,CKIN(28))
29349C...2) due to limits on pT-hat
29350 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
29351 CTPMX2=-CTNMN2
29352 CTNMX2=0D0
29353 CTPMN2=0D0
29354 IF(CKIN(4).GE.0D0) THEN
29355 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
29356 & (BE34**2*TAU*VINT(2))))
29357 CTPMN2=-CTNMX2
29358 ENDIF
29359C...3) due to limits on y-large and y-small
29360 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
29361 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
29362 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
29363 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
29364 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
29365 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
29366 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
29367 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
29368C...4) due to limits on that
29369 CTNMN4=-1D0
29370 CTNMX4=0D0
29371 CTPMN4=0D0
29372 CTPMX4=1D0
29373 SH=TAU*VINT(2)
29374 IF(CKIN(35).GT.0D0) THEN
29375 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
29376 IF(CTLIM.GT.0D0) THEN
29377 CTPMX4=CTLIM
29378 ELSE
29379 CTPMX4=0D0
29380 CTNMX4=CTLIM
29381 ENDIF
29382 ENDIF
29383 IF(CKIN(36).GT.0D0) THEN
29384 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
29385 IF(CTLIM.LT.0D0) THEN
29386 CTNMN4=CTLIM
29387 ELSE
29388 CTNMN4=0D0
29389 CTPMN4=CTLIM
29390 ENDIF
29391 ENDIF
29392C...5) due to limits on uhat
29393 CTNMN5=-1D0
29394 CTNMX5=0D0
29395 CTPMN5=0D0
29396 CTPMX5=1D0
29397 IF(CKIN(37).GT.0D0) THEN
29398 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
29399 IF(CTLIM.LT.0D0) THEN
29400 CTNMN5=CTLIM
29401 ELSE
29402 CTNMN5=0D0
29403 CTPMN5=CTLIM
29404 ENDIF
29405 ENDIF
29406 IF(CKIN(38).GT.0D0) THEN
29407 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
29408 IF(CTLIM.GT.0D0) THEN
29409 CTPMX5=CTLIM
29410 ELSE
29411 CTPMX5=0D0
29412 CTNMX5=CTLIM
29413 ENDIF
29414 ENDIF
29415
29416C...Net effect of all separate limits.
29417 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
29418 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
29419 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
29420 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
29421 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
29422
29423 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
29424 IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
29425
29426 ELSEIF(ILIM.EQ.4) THEN
29427C...Calculate limits on tau'
29428C...0) due to kinematics
29429 TAPMN0=TAU
29430 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
29431 PQRAT=(VINT(201)+VINT(206))/VINT(1)
29432 TAPMN0=(SQRT(TAU)+PQRAT)**2
29433 ENDIF
29434 TAPMX0=1D0
29435C...1) due to explicit limits
29436 TAPMN1=CKIN(31)**2/VINT(2)
29437 TAPMX1=1D0
29438 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
29439
29440C...Net effect of all separate limits.
29441 VINT(16)=MAX(TAPMN0,TAPMN1)
29442 VINT(36)=MIN(TAPMX0,TAPMX1)
29443 IF(MINT(47).EQ.1) THEN
29444 VINT(16)=1D0-1D-9
29445 VINT(36)=1D0+1D-9
29446 ELSEIF(MINT(47).EQ.5) THEN
29447 VINT(36)=MIN(VINT(36),1D0-2D-10)
29448 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
29449 VINT(36)=MIN(VINT(36),1D0-1D-10)
29450 ENDIF
29451 IF(VINT(36).LE.VINT(16)) MINT(51)=1
29452
29453 ENDIF
29454 RETURN
29455
29456C...Special case for low-pT and multiple interactions:
29457C...effective kinematical limits for tau, y*, cos(theta-hat).
29458 100 IF(ILIM.EQ.0) THEN
29459 ELSEIF(ILIM.EQ.1) THEN
29460 IF(MSTP(82).LE.1) THEN
29461 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
29462 & VINT(2)
29463 ELSE
29464 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
29465 ENDIF
29466 VINT(31)=1D0
29467 ELSEIF(ILIM.EQ.2) THEN
29468 VINT(12)=0.5D0*LOG(VINT(21))
29469 VINT(32)=-VINT(12)
29470 ELSEIF(ILIM.EQ.3) THEN
29471 IF(MSTP(82).LE.1) THEN
29472 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
29473 & (VINT(21)*VINT(2))
29474 ELSE
29475 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
29476 & (VINT(21)*VINT(2))
29477 ENDIF
29478 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
29479 VINT(33)=0D0
29480 VINT(14)=0D0
29481 VINT(34)=-VINT(13)
29482 ENDIF
29483
29484 RETURN
29485 END
29486
29487C*********************************************************************
29488
29489C...PYKMAP
29490C...Maps a uniform distribution into a distribution of a kinematical
29491C...variable according to one of the possibilities allowed. It is
29492C...assumed that kinematical limits have been set by a PYKLIM call.
29493
29494 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
29495
29496C...Double precision and integer declarations.
29497 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29498 IMPLICIT INTEGER(I-N)
29499 INTEGER PYK,PYCHGE,PYCOMP
29500C...Commonblocks.
29501 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29502 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29503 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29504 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29505 COMMON/PYINT1/MINT(400),VINT(400)
29506 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29507 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
29508
29509C...Convert VVAR to tau variable.
29510 ISUB=MINT(1)
29511 ISTSB=ISET(ISUB)
29512 IF(IVAR.EQ.1) THEN
29513 TAUMIN=VINT(11)
29514 TAUMAX=VINT(31)
29515 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
29516 TAURE=VINT(73)
29517 GAMRE=VINT(74)
29518 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
29519 TAURE=VINT(75)
29520 GAMRE=VINT(76)
29521 ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
29522 TAURE=VINT(77)
29523 GAMRE=VINT(78)
29524 ENDIF
29525 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
29526 TAU=1D0
29527 ELSEIF(MVAR.EQ.1) THEN
29528 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
29529 ELSEIF(MVAR.EQ.2) THEN
29530 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
29531 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
29532 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
29533 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
29534 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
29535 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
29536 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
29537 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
29538 ELSEIF(MINT(47).EQ.5) THEN
29539 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
29540 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
29541 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29542 ELSE
29543 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
29544 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
29545 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29546 ENDIF
29547 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
29548
29549C...Convert VVAR to y* variable.
29550 ELSEIF(IVAR.EQ.2) THEN
29551 YSTMIN=VINT(12)
29552 YSTMAX=VINT(32)
29553 TAUE=VINT(21)
29554 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
29555 IF(MINT(47).EQ.1) THEN
29556 YST=0D0
29557 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
29558 YST=-0.5D0*LOG(TAUE)
29559 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
29560 YST=0.5D0*LOG(TAUE)
29561 ELSEIF(MVAR.EQ.1) THEN
29562 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
29563 ELSEIF(MVAR.EQ.2) THEN
29564 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
29565 ELSEIF(MVAR.EQ.3) THEN
29566 AUPP=ATAN(EXP(YSTMAX))
29567 ALOW=ATAN(EXP(YSTMIN))
29568 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
29569 ELSEIF(MVAR.EQ.4) THEN
29570 YST0=-0.5D0*LOG(TAUE)
29571 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
29572 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
29573 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
29574 ELSE
29575 YST0=-0.5D0*LOG(TAUE)
29576 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
29577 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
29578 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
29579 ENDIF
29580 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
29581
29582C...Convert VVAR to cos(theta-hat) variable.
29583 ELSEIF(IVAR.EQ.3) THEN
29584 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
29585 RSQM=1D0+RM34
29586 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
29587 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
29588 CTNMIN=VINT(13)
29589 CTNMAX=VINT(33)
29590 CTPMIN=VINT(14)
29591 CTPMAX=VINT(34)
29592 IF(MVAR.EQ.1) THEN
29593 ANEG=CTNMAX-CTNMIN
29594 APOS=CTPMAX-CTPMIN
29595 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29596 VCTN=VVAR*(ANEG+APOS)/ANEG
29597 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
29598 ELSE
29599 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29600 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
29601 ENDIF
29602 ELSEIF(MVAR.EQ.2) THEN
29603 RMNMIN=MAX(RM34,RSQM-CTNMIN)
29604 RMNMAX=MAX(RM34,RSQM-CTNMAX)
29605 RMPMIN=MAX(RM34,RSQM-CTPMIN)
29606 RMPMAX=MAX(RM34,RSQM-CTPMAX)
29607 ANEG=LOG(RMNMIN/RMNMAX)
29608 APOS=LOG(RMPMIN/RMPMAX)
29609 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29610 VCTN=VVAR*(ANEG+APOS)/ANEG
29611 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
29612 ELSE
29613 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29614 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
29615 ENDIF
29616 ELSEIF(MVAR.EQ.3) THEN
29617 RMNMIN=MAX(RM34,RSQM+CTNMIN)
29618 RMNMAX=MAX(RM34,RSQM+CTNMAX)
29619 RMPMIN=MAX(RM34,RSQM+CTPMIN)
29620 RMPMAX=MAX(RM34,RSQM+CTPMAX)
29621 ANEG=LOG(RMNMAX/RMNMIN)
29622 APOS=LOG(RMPMAX/RMPMIN)
29623 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29624 VCTN=VVAR*(ANEG+APOS)/ANEG
29625 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
29626 ELSE
29627 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29628 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
29629 ENDIF
29630 ELSEIF(MVAR.EQ.4) THEN
29631 RMNMIN=MAX(RM34,RSQM-CTNMIN)
29632 RMNMAX=MAX(RM34,RSQM-CTNMAX)
29633 RMPMIN=MAX(RM34,RSQM-CTPMIN)
29634 RMPMAX=MAX(RM34,RSQM-CTPMAX)
29635 ANEG=1D0/RMNMAX-1D0/RMNMIN
29636 APOS=1D0/RMPMAX-1D0/RMPMIN
29637 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29638 VCTN=VVAR*(ANEG+APOS)/ANEG
29639 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
29640 ELSE
29641 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29642 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
29643 ENDIF
29644 ELSEIF(MVAR.EQ.5) THEN
29645 RMNMIN=MAX(RM34,RSQM+CTNMIN)
29646 RMNMAX=MAX(RM34,RSQM+CTNMAX)
29647 RMPMIN=MAX(RM34,RSQM+CTPMIN)
29648 RMPMAX=MAX(RM34,RSQM+CTPMAX)
29649 ANEG=1D0/RMNMIN-1D0/RMNMAX
29650 APOS=1D0/RMPMIN-1D0/RMPMAX
29651 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29652 VCTN=VVAR*(ANEG+APOS)/ANEG
29653 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
29654 ELSE
29655 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29656 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
29657 ENDIF
29658 ENDIF
29659 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
29660 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
29661 VINT(23)=CTH
29662
29663C...Convert VVAR to tau' variable.
29664 ELSEIF(IVAR.EQ.4) THEN
29665 TAU=VINT(21)
29666 TAUPMN=VINT(16)
29667 TAUPMX=VINT(36)
29668 IF(MINT(47).EQ.1) THEN
29669 TAUP=1D0
29670 ELSEIF(MVAR.EQ.1) THEN
29671 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
29672 ELSEIF(MVAR.EQ.2) THEN
29673 AUPP=(1D0-TAU/TAUPMX)**4
29674 ALOW=(1D0-TAU/TAUPMN)**4
29675 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
29676 ELSEIF(MINT(47).EQ.5) THEN
29677 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
29678 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
29679 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29680 ELSE
29681 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
29682 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
29683 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29684 ENDIF
29685 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
29686
29687C...Selection of extra variables needed in 2 -> 3 process:
29688C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
29689C...Since no options are available, the functions of PYKLIM
29690C...and PYKMAP are joint for these choices.
29691 ELSEIF(IVAR.EQ.5) THEN
29692
29693C...Read out total energy and particle masses.
29694 MINT(51)=0
29695 MPTPK=1
29696 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
29697 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
29698 & MPTPK=2
29699 SHP=VINT(26)*VINT(2)
29700 SHPR=SQRT(SHP)
29701 PM1=VINT(201)
29702 PM2=VINT(206)
29703 PM3=SQRT(VINT(21))*VINT(1)
29704 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
29705 MINT(51)=1
29706 RETURN
29707 ENDIF
29708 PMRS1=VINT(204)**2
29709 PMRS2=VINT(209)**2
29710
29711C...Specify coefficients of pT choice; upper and lower limits.
29712 IF(MPTPK.EQ.1) THEN
29713 HWT1=0.4D0
29714 HWT2=0.4D0
29715 ELSE
29716 HWT1=0.05D0
29717 HWT2=0.05D0
29718 ENDIF
29719 HWT3=1D0-HWT1-HWT2
29720 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
29721 & (4D0*SHP)
29722 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
29723 PTSMN1=CKIN(51)**2
29724 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
29725 & (4D0*SHP)
29726 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
29727 PTSMN2=CKIN(53)**2
29728
29729C...Select transverse momenta according to
29730C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
29731 HMX=PMRS1+PTSMX1
29732 HMN=PMRS1+PTSMN1
29733 IF(HMX.LT.1.0001D0*HMN) THEN
29734 MINT(51)=1
29735 RETURN
29736 ENDIF
29737 HDE=PTSMX1-PTSMN1
29738 RPT=PYR(0)
29739 IF(RPT.LT.HWT1) THEN
29740 PTS1=PTSMN1+PYR(0)*HDE
29741 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29742 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
29743 ELSE
29744 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
29745 ENDIF
29746 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
29747 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
29748 HMX=PMRS2+PTSMX2
29749 HMN=PMRS2+PTSMN2
29750 IF(HMX.LT.1.0001D0*HMN) THEN
29751 MINT(51)=1
29752 RETURN
29753 ENDIF
29754 HDE=PTSMX2-PTSMN2
29755 RPT=PYR(0)
29756 IF(RPT.LT.HWT1) THEN
29757 PTS2=PTSMN2+PYR(0)*HDE
29758 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29759 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
29760 ELSE
29761 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
29762 ENDIF
29763 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
29764 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
29765
29766C...Select azimuthal angles and check pT choice.
29767 PHI1=PARU(2)*PYR(0)
29768 PHI2=PARU(2)*PYR(0)
29769 PHIR=PHI2-PHI1
29770 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
29771 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
29772 & CKIN(56)**2)) THEN
29773 MINT(51)=1
29774 RETURN
29775 ENDIF
29776
29777C...Calculate transverse masses and check phase space not closed.
29778 PMS1=PM1**2+PTS1
29779 PMS2=PM2**2+PTS2
29780 PMS3=PM3**2+PTS3
29781 PMT1=SQRT(PMS1)
29782 PMT2=SQRT(PMS2)
29783 PMT3=SQRT(PMS3)
29784 PM12=(PMT1+PMT2)**2
29785 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
29786 MINT(51)=1
29787 RETURN
29788 ENDIF
29789
29790C...Select rapidity for particle 3 and check phase space not closed.
29791 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
29792 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
29793 IF(Y3MAX.LT.1D-6) THEN
29794 MINT(51)=1
29795 RETURN
29796 ENDIF
29797 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
29798 PZ3=PMT3*SINH(Y3)
29799 PE3=PMT3*COSH(Y3)
29800
29801C...Find momentum transfers in two mirror solutions (in 1-2 frame).
29802 PZ12=-PZ3
29803 PE12=SHPR-PE3
29804 PMS12=PE12**2-PZ12**2
29805 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
29806 IF(SQL12.LT.1D-6*SHP) THEN
29807 MINT(51)=1
29808 RETURN
29809 ENDIF
29810 PMM1=PMS12+PMS1-PMS2
29811 PMM2=PMS12+PMS2-PMS1
29812 TFAC=-SHPR/(2D0*PMS12)
29813 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
29814 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
29815 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
29816 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
29817
29818C...Construct relative mirror weights and make choice.
29819 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
29820 WTPU=1D0
29821 WTNU=1D0
29822 ELSE
29823 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
29824 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
29825 ENDIF
29826 WTP=WTPU/(WTPU+WTNU)
29827 WTN=WTNU/(WTPU+WTNU)
29828 EPS=1D0
29829 IF(WTN.GT.PYR(0)) EPS=-1D0
29830
29831C...Store result of variable choice and associated weights.
29832 VINT(202)=PTS1
29833 VINT(207)=PTS2
29834 VINT(203)=PHI1
29835 VINT(208)=PHI2
29836 VINT(205)=WTPTS1
29837 VINT(210)=WTPTS2
29838 VINT(211)=Y3
29839 VINT(212)=Y3MAX
29840 VINT(213)=EPS
29841 IF(EPS.GT.0D0) THEN
29842 VINT(214)=1D0/WTP
29843 VINT(215)=T1P
29844 VINT(216)=T2P
29845 ELSE
29846 VINT(214)=1D0/WTN
29847 VINT(215)=T1N
29848 VINT(216)=T2N
29849 ENDIF
29850 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
29851 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
29852 VINT(219)=0.5D0*(PMS12-PTS3)
29853 VINT(220)=SQL12
29854 ENDIF
29855
29856 RETURN
29857 END
29858
29859C***********************************************************************
29860
29861C...PYSIGH
29862C...Differential matrix elements for all included subprocesses
29863C...Note that what is coded is (disregarding the COMFAC factor)
29864C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
29865C...when d(sigma-hat) is given in the zero-width limit, the delta
29866C...function in tau is replaced by a (modified) Breit-Wigner:
29867C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
29868C...where H_res = s-hat/m_res*Gamma_res(s-hat);
29869C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
29870C...i.e., dimensionless quantities
29871C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
29872C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
29873C...(2pi)^4 delta^4(P - sum p_i)
29874C...COMFAC contains the factor pi/s (or equivalent) and
29875C...the conversion factor from GeV^-2 to mb
29876
29877 SUBROUTINE PYSIGH(NCHN,SIGS)
29878
29879C...Double precision and integer declarations
29880 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29881 IMPLICIT INTEGER(I-N)
29882 INTEGER PYK,PYCHGE,PYCOMP
29883C...Parameter statement to help give large particle numbers.
29884 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29885 &KEXCIT=4000000,KDIMEN=5000000)
29886C...Commonblocks
29887 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
29888 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29889 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29890 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29891 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29892 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29893 COMMON/PYINT1/MINT(400),VINT(400)
29894 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29895 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29896 COMMON/PYINT4/MWID(500),WIDS(500,5)
29897 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
29898 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29899 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29900 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29901 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
29902 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
29903 COMMON/PYPUED/IUED(0:99),RUED(0:99)
29904 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29905 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29906 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29907 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29908 COMMON/PYTCCO/COEFX(194:380,2)
29909 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
29910 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
29911 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/
29912C...Local arrays and complex variables
29913 DIMENSION XPQ(-25:25)
29914
29915C...Map of processes onto which routine to call
29916C...in order to evaluate cross section:
29917C...0 = not implemented;
29918C...1 = standard QCD (including photons);
29919C...2 = heavy flavours;
29920C...3 = W/Z;
29921C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
29922C...5 = SUSY;
29923C...6 = Technicolor;
29924C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29925C...8 = Universal Extra Dimensions
29926 DIMENSION MAPPR(500)
29927 DATA (MAPPR(I),I=1,180)/
29928 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
29929 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
29930 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
29931 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
29932 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29933 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
29934 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
29935 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
29936 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29937 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
29938 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
29939 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
29940 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
29941 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29942 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
29943 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
29944 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
29945 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
29946 DATA (MAPPR(I),I=181,500)/
29947 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
29948 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
29949 & 100*5,
29950 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29951 & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
29952 1 20*0,
29953 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
29954 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
29955 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
29956 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
29957 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
29958 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
29959 & 4, 4, 18*0,
29960 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29961 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29962 4 20*0,
29963 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29964 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29965 8 7, 7, 18*0/
29966
29967C...Reset number of channels and cross-section
29968 NCHN=0
29969 SIGS=0D0
29970
29971C...Read process to consider.
29972 ISUB=MINT(1)
29973 ISUBSV=ISUB
29974 MAP=MAPPR(ISUB)
29975
29976C...Read kinematical variables and limits
29977 ISTSB=ISET(ISUBSV)
29978 TAUMIN=VINT(11)
29979 YSTMIN=VINT(12)
29980 CTNMIN=VINT(13)
29981 CTPMIN=VINT(14)
29982 TAUPMN=VINT(16)
29983 TAU=VINT(21)
29984 YST=VINT(22)
29985 CTH=VINT(23)
29986 XT2=VINT(25)
29987 TAUP=VINT(26)
29988 TAUMAX=VINT(31)
29989 YSTMAX=VINT(32)
29990 CTNMAX=VINT(33)
29991 CTPMAX=VINT(34)
29992 TAUPMX=VINT(36)
29993
29994C...Derive kinematical quantities
29995 TAUE=TAU
29996 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
29997 X(1)=SQRT(TAUE)*EXP(YST)
29998 X(2)=SQRT(TAUE)*EXP(-YST)
29999 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
30000 IF(X(1).GT.1D0-1D-7) RETURN
30001 ELSEIF(MINT(45).EQ.3) THEN
30002 X(1)=MIN(1D0-1.1D-10,X(1))
30003 ENDIF
30004 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
30005 IF(X(2).GT.1D0-1D-7) RETURN
30006 ELSEIF(MINT(46).EQ.3) THEN
30007 X(2)=MIN(1D0-1.1D-10,X(2))
30008 ENDIF
30009 SH=MAX(1D0,TAU*VINT(2))
30010 SQM3=VINT(63)
30011 SQM4=VINT(64)
30012 RM3=SQM3/SH
30013 RM4=SQM4/SH
30014 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
30015 RPTS=4D0*VINT(71)**2/SH
30016 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
30017 RM34=MAX(1D-20,2D0*RM3*RM4)
30018 RSQM=1D0+RM34
30019 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
30020 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
30021 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
30022 IF(ISTSB.EQ.0) THEN
30023 TH=VINT(45)
30024 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
30025 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
30026 ELSE
30027C...Kinematics with incoming masses tricky: now depends on how
30028C...subprocess has been set up w.r.t. order of incoming partons.
30029 RM1=0D0
30030 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
30031 RM2=0D0
30032 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
30033 IF(ISUB.EQ.35) THEN
30034 RM2=MIN(RM1,RM2)
30035 RM1=0D0
30036 ENDIF
30037 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
30038 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
30039 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
30040 & BE12*BE34*CTH)
30041 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
30042 & BE12*BE34*CTH)
30043 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
30044 ENDIF
30045 SHR=SQRT(SH)
30046 SH2=SH**2
30047 TH2=TH**2
30048 UH2=UH**2
30049
30050C...Choice of Q2 scale for hard process (e.g. alpha_s).
30051 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
30052 Q2=SH
30053 ELSEIF(ISTSB.EQ.8) THEN
30054 IF(MINT(107).EQ.4) Q2=VINT(307)
30055 IF(MINT(108).EQ.4) Q2=VINT(308)
30056 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
30057 Q2IN1=0D0
30058 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
30059 Q2IN2=0D0
30060 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
30061 IF(MSTP(32).EQ.1) THEN
30062 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
30063 ELSEIF(MSTP(32).EQ.2) THEN
30064 Q2=SQPTH+0.5D0*(SQM3+SQM4)
30065 ELSEIF(MSTP(32).EQ.3) THEN
30066 Q2=MIN(-TH,-UH)
30067 ELSEIF(MSTP(32).EQ.4) THEN
30068 Q2=SH
30069 ELSEIF(MSTP(32).EQ.5) THEN
30070 Q2=-TH
30071 ELSEIF(MSTP(32).EQ.6) THEN
30072 XSF1=X(1)
30073 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
30074 XSF2=X(2)
30075 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
30076 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
30077 & (SQPTH+0.5D0*(SQM3+SQM4))
30078 ELSEIF(MSTP(32).EQ.7) THEN
30079 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
30080 ELSEIF(MSTP(32).EQ.8) THEN
30081 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
30082 ELSEIF(MSTP(32).EQ.9) THEN
30083 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
30084 ELSEIF(MSTP(32).EQ.10) THEN
30085 Q2=VINT(2)
30086C..Begin JA 040914
30087 ELSEIF(MSTP(32).EQ.11) THEN
30088 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
30089 ELSEIF(MSTP(32).EQ.12) THEN
30090 Q2=PARP(193)
30091C..End JA
30092 ELSEIF(MSTP(32).EQ.13) THEN
30093 Q2=SQPTH
30094 ENDIF
30095 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
30096 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
30097 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
30098 ENDIF
30099
30100C...Choice of Q2 scale for parton densities.
30101 Q2SF=Q2
30102C..Begin JA 040914
30103 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
30104 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
30105 & Q2=PARP(194)
30106C..End JA
30107 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
30108 Q2SF=PMAS(23,1)**2
30109 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
30110 & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
30111 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
30112 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
30113 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
30114 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
30115 IF(MSTP(39).EQ.2) Q2SF=
30116 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
30117 IF(MSTP(39).EQ.3) Q2SF=SH
30118 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
30119 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
30120C..Begin JA 040914
30121 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
30122 IF(MSTP(39).EQ.7) Q2SF=
30123 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
30124 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
30125C..End JA
30126 ENDIF
30127 ENDIF
30128 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
30129
30130 Q2PS=Q2SF
30131 Q2SF=Q2SF*PARP(34)
30132 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
30133 IF(MSTP(69).GE.2) Q2SF=VINT(2)
30134
30135C...Identify to which class(es) subprocess belongs
30136 ISMECR=0
30137 ISQCD=0
30138 ISJETS=0
30139 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
30140 & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
30141 & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
30142 & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
30143 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
30144 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
30145 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
30146 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
30147 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
30148 IF (ISTSB.EQ.9) ISQCD=1
30149 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
30150 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
30151 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
30152 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
30153 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
30154 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
30155 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
30156 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
30157C...WBF is special case of ISJETS
30158 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
30159 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
30160 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
30161 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
30162 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
30163 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
30164 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
30165 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
30166 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
30167C...Some processes with photons also belong here.
30168 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
30169 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
30170 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
30171 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
30172 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
30173 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
30174
30175C...Choice of Q2 scale for parton-shower activity.
30176 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
30177 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
30178 XBJ=X(2)
30179 IF(MINT(43).EQ.3) XBJ=X(1)
30180 IF(MSTP(22).EQ.1) THEN
30181 Q2PS=-TH
30182 ELSEIF(MSTP(22).EQ.2) THEN
30183 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
30184 ELSEIF(MSTP(22).EQ.3) THEN
30185 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
30186 ELSE
30187 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
30188 ENDIF
30189 ENDIF
30190C...For multiple interactions, start from scale defined above
30191C...For all other QCD or "+jets"-type events, start shower from pThard.
30192 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
30193 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
30194C...Max shower scale = s for ME corrected processes.
30195C...(pT-ordering: max pT2 is s/4)
30196 Q2PS=VINT(2)
30197 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
30198 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
30199C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
30200C...(pT-ordering: max pT2 is s/4)
30201 Q2PS=VINT(2)
30202 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
30203 ENDIF
30204 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
30205
30206C...Elastic and diffractive events not associated with scales so set 0.
30207 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
30208 Q2SF=0D0
30209 Q2PS=0D0
30210 ENDIF
30211
30212C...Store derived kinematical quantities
30213 VINT(41)=X(1)
30214 VINT(42)=X(2)
30215 VINT(44)=SH
30216 VINT(43)=SQRT(SH)
30217 VINT(45)=TH
30218 VINT(46)=UH
30219 IF(ISTSB.NE.8) VINT(48)=SQPTH
30220 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
30221 VINT(50)=TAUP*VINT(2)
30222 VINT(49)=SQRT(MAX(0D0,VINT(50)))
30223 VINT(52)=Q2
30224 VINT(51)=SQRT(Q2)
30225 VINT(54)=Q2SF
30226 VINT(53)=SQRT(Q2SF)
30227 VINT(56)=Q2PS
30228 VINT(55)=SQRT(Q2PS)
30229
30230C...Set starting scale for multiple interactions
30231 IF (ISUBSV.EQ.95) THEN
30232 XT2GMX=0D0
30233 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
30234 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
30235 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
30236 & ISUBSV.NE.96)) THEN
30237C...All accessible phase space allowed.
30238 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
30239 ELSE
30240C...Scale of hard process sets limit.
30241C...2 -> 1. Limit is tau = x1*x2.
30242C...2 -> 2. Limit is XT2 for hard process + FS masses.
30243C...2 -> n > 2. Limit is tau' = tau of outer process.
30244 XT2GMX=VINT(25)
30245 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
30246 IF(ISTSB.EQ.2)
30247 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
30248 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
30249 ENDIF
30250 VINT(62)=0.25D0*XT2GMX*VINT(2)
30251 VINT(61)=SQRT(MAX(0D0,VINT(62)))
30252
30253C...Calculate parton distributions
30254 IF(ISTSB.LE.0) GOTO 160
30255 IF(MINT(47).GE.2) THEN
30256 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
30257 XSF=X(I)
30258 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
30259 IF(ISUB.EQ.99) THEN
30260 IF(MINT(140+I).EQ.0) THEN
30261 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
30262 ELSE
30263 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
30264 ENDIF
30265 VINT(40+I)=XSF
30266 Q2SF=VINT(309-I)
30267 ENDIF
30268 MINT(105)=MINT(102+I)
30269 MINT(109)=MINT(106+I)
30270 VINT(120)=VINT(2+I)
30271C...Default is to use standard PDFs, but for interactions after the first
30272C...in the new multiple-parton-interactions framework, set which side to
30273C...evaluate the MPI-modified PDFs on.
30274 MINT(30)=0
30275 IF (MINT(31).GE.1) MINT(30)=I
30276C.... ALICE
30277C.... Store side in MINT(124)
30278 MINT(124) = I
30279C....
30280 IF(MSTP(57).LE.1) THEN
30281 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
30282 ELSE
30283 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
30284 ENDIF
30285C...Safety margin against heavy flavour very close to threshold,
30286C...e.g. caused by mismatch in c and b masses.
30287 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
30288 XPQ(4)=0D0
30289 XPQ(-4)=0D0
30290 ENDIF
30291 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
30292 XPQ(5)=0D0
30293 XPQ(-5)=0D0
30294 ENDIF
30295 DO 100 KFL=-25,25
30296 XSFX(I,KFL)=XPQ(KFL)
30297 100 CONTINUE
30298 110 CONTINUE
30299 ENDIF
30300
30301C...Calculate alpha_em, alpha_strong and K-factor
30302 XW=PARU(102)
30303 XWV=XW
30304 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
30305 &1D0-(PMAS(24,1)/PMAS(23,1))**2
30306 XW1=1D0-XW
30307 XWC=1D0/(16D0*XW*XW1)
30308 AEM=PYALEM(Q2)
30309 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
30310 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
30311 FACK=1D0
30312 FACA=1D0
30313 IF(MSTP(33).EQ.1) THEN
30314 FACK=PARP(31)
30315 ELSEIF(MSTP(33).EQ.2) THEN
30316 FACK=PARP(31)
30317 FACA=PARP(32)/PARP(31)
30318 ELSEIF(MSTP(33).EQ.3) THEN
30319 Q2AS=PARP(33)*Q2
30320 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
30321 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
30322 AS=PYALPS(Q2AS)
30323C...PS (12 Feb 2010)
30324C...New options MSTP(33) = 10 and 11
30325C... 10: use K-factor = PARP(32) only for process 96 (MPI)
30326C... 11: as for 10, but also use K-factor = PARP(31) for other procs
30327 ELSEIF(MSTP(33).GE.10) THEN
30328 IF (ISUB.EQ.96) THEN
30329 FACK = PARP(32)
30330 ELSEIF (ISUB.NE.96.AND.MSTP(33).EQ.11) THEN
30331 FACK = PARP(31)
30332 ENDIF
30333 ENDIF
30334 VINT(138)=1D0
30335 VINT(57)=AEM
30336 VINT(58)=AS
30337
30338C...Set flags for allowed reacting partons/leptons
30339 DO 140 I=1,2
30340 DO 120 J=-25,25
30341 KFAC(I,J)=0
30342 120 CONTINUE
30343 IF(MINT(44+I).EQ.1) THEN
30344 KFAC(I,MINT(10+I))=1
30345 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
30346 KFAC(I,MINT(10+I))=1
30347 KFAC(I,22)=1
30348 KFAC(I,24)=1
30349 KFAC(I,-24)=1
30350 ELSE
30351 DO 130 J=-25,25
30352 KFAC(I,J)=KFIN(I,J)
30353 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
30354 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
30355 130 CONTINUE
30356 ENDIF
30357 140 CONTINUE
30358
30359C...Lower and upper limit for fermion flavour loops
30360 MMIN1=0
30361 MMAX1=0
30362 MMIN2=0
30363 MMAX2=0
30364 DO 150 J=-20,20
30365 IF(KFAC(1,-J).EQ.1) MMIN1=-J
30366 IF(KFAC(1,J).EQ.1) MMAX1=J
30367 IF(KFAC(2,-J).EQ.1) MMIN2=-J
30368 IF(KFAC(2,J).EQ.1) MMAX2=J
30369 150 CONTINUE
30370 MMINA=MIN(MMIN1,MMIN2)
30371 MMAXA=MAX(MMAX1,MMAX2)
30372
30373C...Common resonance mass and width combinations
30374 SQMZ=PMAS(23,1)**2
30375 SQMW=PMAS(24,1)**2
30376 GMMZ=PMAS(23,1)*PMAS(23,2)
30377 GMMW=PMAS(24,1)*PMAS(24,2)
30378
30379C...Polarization factors...implemented so far for W+W-(25)
30380 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
30381 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
30382 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
30383 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
30384
30385C...Phase space integral in tau
30386 COMFAC=PARU(1)*PARU(5)/VINT(2)
30387 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
30388 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
30389 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
30390 ATAU1=LOG(TAUMAX/TAUMIN)
30391 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
30392 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
30393 IF(MINT(72).GE.1) THEN
30394 TAUR1=VINT(73)
30395 GAMR1=VINT(74)
30396 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
30397 ATAU3=ATAUD/TAUR1
30398 IF(ATAUD.GT.1D-10) H1=H1+
30399 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
30400 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
30401 ATAU4=ATAUD/GAMR1
30402 IF(ATAUD.GT.1D-10) H1=H1+
30403 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
30404 ENDIF
30405 IF(MINT(72).GE.2) THEN
30406 TAUR2=VINT(75)
30407 GAMR2=VINT(76)
30408 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
30409 ATAU5=ATAUD/TAUR2
30410 IF(ATAUD.GT.1D-10) H1=H1+
30411 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
30412 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
30413 ATAU6=ATAUD/GAMR2
30414 IF(ATAUD.GT.1D-10) H1=H1+
30415 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
30416 ENDIF
30417 IF(MINT(72).EQ.3) THEN
30418 TAUR3=VINT(77)
30419 GAMR3=VINT(78)
30420 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
30421 ATAU50=ATAUD/TAUR3
30422 IF(ATAUD.GT.1D-10) H1=H1+
30423 & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
30424 ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
30425 ATAU60=ATAUD/GAMR3
30426 IF(ATAUD.GT.1D-10) H1=H1+
30427 & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
30428 ENDIF
30429 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
30430 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
30431 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
30432 & MAX(2D-10,1D0-TAU)
30433 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
30434 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
30435 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
30436 & MAX(1D-10,1D0-TAU)
30437 ENDIF
30438 COMFAC=COMFAC*ATAU1/(TAU*H1)
30439 ENDIF
30440
30441C...Phase space integral in y*
30442 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
30443 &THEN
30444 AYST0=YSTMAX-YSTMIN
30445 IF(AYST0.LT.1D-10) THEN
30446 COMFAC=0D0
30447 ELSE
30448 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
30449 AYST2=AYST1
30450 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
30451 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
30452 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
30453 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
30454 IF(MINT(45).EQ.3) THEN
30455 YST0=-0.5D0*LOG(TAUE)
30456 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
30457 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
30458 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
30459 & MAX(1D-10,1D0-EXP(YST-YST0))
30460 ENDIF
30461 IF(MINT(46).EQ.3) THEN
30462 YST0=-0.5D0*LOG(TAUE)
30463 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
30464 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
30465 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
30466 & MAX(1D-10,1D0-EXP(-YST-YST0))
30467 ENDIF
30468 COMFAC=COMFAC*AYST0/H2
30469 ENDIF
30470 ENDIF
30471
30472C...2 -> 1 processes: reduction in angular part of phase space integral
30473C...for case of decaying resonance
30474 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
30475 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
30476 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
30477 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
30478 & KFPR(ISUB,1).EQ.39) THEN
30479 COMFAC=COMFAC*0.5D0*ACTH0
30480 ELSE
30481 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
30482 & CTPMAX**3-CTPMIN**3)
30483 ENDIF
30484 ENDIF
30485
30486C...2 -> 2 processes: angular part of phase space integral
30487 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
30488 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
30489 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
30490 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
30491 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
30492 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
30493 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
30494 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
30495 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
30496 H3=COEF(ISUBSV,13)+
30497 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
30498 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
30499 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
30500 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
30501 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
30502
30503C...2 -> 2 processes: take into account final state Breit-Wigners
30504 COMFAC=COMFAC*VINT(80)
30505 ENDIF
30506
30507C...2 -> 3, 4 processes: phace space integral in tau'
30508 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
30509 ATAUP1=LOG(TAUPMX/TAUPMN)
30510 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
30511 H4=COEF(ISUBSV,18)+
30512 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
30513 IF(MINT(47).EQ.5) THEN
30514 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
30515 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
30516 ELSEIF(MINT(47).GE.6) THEN
30517 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
30518 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
30519 ENDIF
30520 COMFAC=COMFAC*ATAUP1/H4
30521 ENDIF
30522
30523C...2 -> 3, 4 processes: effective W/Z parton distributions
30524 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
30525 IF(1D0-TAU/TAUP.GT.1D-4) THEN
30526 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
30527 ELSE
30528 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
30529 ENDIF
30530 COMFAC=COMFAC*FZW
30531 ENDIF
30532
30533C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
30534 IF(ISTSB.EQ.5) THEN
30535 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
30536 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
30537 ENDIF
30538
30539C...Phase space integral for low-pT and multiple interactions
30540 IF(ISTSB.EQ.9) THEN
30541 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
30542 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
30543 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
30544 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
30545 COMFAC=COMFAC*ATAU1/H1
30546 AYST0=YSTMAX-YSTMIN
30547 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
30548 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
30549 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
30550 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
30551 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
30552 COMFAC=COMFAC*AYST0/H2
30553 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
30554C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
30555C...introduced to make cross-section finite for xT2 -> 0
30556 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
30557 & (1D0+VINT(149)))
30558 ENDIF
30559
30560C...Real gamma + gamma: include factor 2 when different nature
30561 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
30562 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
30563
30564C...Extra factors to include the effects of
30565C...longitudinal resolved photons (but not direct or DIS ones).
30566 DO 170 ISDE=1,2
30567 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
30568 & MINT(106+ISDE).LE.3) THEN
30569 VINT(314+ISDE)=1D0
30570 XY=PARP(166+ISDE)
30571 IF(MSTP(16).EQ.0) THEN
30572 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
30573 & XY=VINT(304+ISDE)
30574 ELSE
30575 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
30576 & XY=VINT(308+ISDE)
30577 ENDIF
30578 Q2GA=VINT(306+ISDE)
30579 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
30580 & Q2GA.GT.0D0) THEN
30581 REDUCE=0D0
30582 IF(MSTP(17).EQ.1) THEN
30583 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
30584 ELSEIF(MSTP(17).EQ.2) THEN
30585 REDUCE=4D0*Q2GA/(Q2+Q2GA)
30586 ELSEIF(MSTP(17).EQ.3) THEN
30587 PMVIRT=PMAS(PYCOMP(113),1)
30588 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
30589 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
30590 PMVIRT=PMAS(PYCOMP(113),1)
30591 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
30592 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
30593 PMVIRT=PMAS(PYCOMP(113),1)
30594 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
30595 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
30596 PMVSMN=4D0*PARP(15)**2
30597 PMVSMX=4D0*VINT(154)**2
30598 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
30599 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
30600 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
30601 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
30602 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
30603 PMVIRT=PMAS(PYCOMP(113),1)
30604 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
30605 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
30606 PMVIRT=PMAS(PYCOMP(113),1)
30607 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
30608 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
30609 PMVSMN=4D0*PARP(15)**2
30610 PMVSMX=4D0*VINT(154)**2
30611 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
30612 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
30613 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
30614 ENDIF
30615 BEAMAS=PYMASS(11)
30616 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
30617 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
30618 & (1D0-2D0*BEAMAS**2/Q2GA))
30619 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
30620 ENDIF
30621 ELSE
30622 VINT(314+ISDE)=1D0
30623 ENDIF
30624 COMFAC=COMFAC*VINT(314+ISDE)
30625 170 CONTINUE
30626
30627C...Evaluate cross sections - done in separate routines by kind
30628C...of physics, to keep PYSIGH of sensible size.
30629 IF(MAP.EQ.1) THEN
30630C...Standard QCD (including photons).
30631 CALL PYSGQC(NCHN,SIGS)
30632 ELSEIF(MAP.EQ.2) THEN
30633C...Heavy flavours.
30634 CALL PYSGHF(NCHN,SIGS)
30635 ELSEIF(MAP.EQ.3) THEN
30636C...W/Z.
30637 CALL PYSGWZ(NCHN,SIGS)
30638 ELSEIF(MAP.EQ.4) THEN
30639C...Higgs (2 doublets; including longitudinal W/Z scattering).
30640 CALL PYSGHG(NCHN,SIGS)
30641 ELSEIF(MAP.EQ.5) THEN
30642C...SUSY.
30643 CALL PYSGSU(NCHN,SIGS)
30644 ELSEIF(MAP.EQ.6) THEN
30645C...Technicolor.
30646 CALL PYSGTC(NCHN,SIGS)
30647 ELSEIF(MAP.EQ.7) THEN
30648C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
30649 CALL PYSGEX(NCHN,SIGS)
30650 ELSEIF(MAP.EQ.8) THEN
30651C... Universal Extra Dimensions
30652 CALL PYXUED(NCHN,SIGS)
30653 ENDIF
30654
30655C...Multiply with parton distributions
30656 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
30657 DO 180 ICHN=1,NCHN
30658 IF(MINT(45).GE.2) THEN
30659 KFL1=ISIG(ICHN,1)
30660 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
30661 ENDIF
30662 IF(MINT(46).GE.2) THEN
30663 KFL2=ISIG(ICHN,2)
30664 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
30665 ENDIF
30666 SIGS=SIGS+SIGH(ICHN)
30667 180 CONTINUE
30668 ENDIF
30669
30670 RETURN
30671 END
30672
30673C*********************************************************************
30674
30675C...PYSGQC
30676C...Subprocess cross sections for QCD processes,
30677C...including photons.
30678C...Auxiliary to PYSIGH.
30679
30680 SUBROUTINE PYSGQC(NCHN,SIGS)
30681
30682C...Double precision and integer declarations
30683 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30684 IMPLICIT INTEGER(I-N)
30685 INTEGER PYK,PYCHGE,PYCOMP
30686C...Parameter statement to help give large particle numbers.
30687 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30688 &KEXCIT=4000000,KDIMEN=5000000)
30689C...Commonblocks
30690 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30691 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30692 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
30693 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30694 COMMON/PYINT1/MINT(400),VINT(400)
30695 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30696 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30697 COMMON/PYINT4/MWID(500),WIDS(500,5)
30698 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
30699 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30700 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30701 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30702 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30703 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
30704 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
30705C...Local arrays
30706 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30707
30708C...Differential cross section expressions.
30709
30710 IF(ISUB.LE.20) THEN
30711 IF(ISUB.EQ.10) THEN
30712C...f + f' -> f + f' (gamma/Z/W exchange)
30713 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
30714 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
30715 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
30716 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
30717 DO 110 I=MMIN1,MMAX1
30718 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
30719 IA=IABS(I)
30720 DO 100 J=MMIN2,MMAX2
30721 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
30722 JA=IABS(J)
30723C...Electroweak couplings
30724 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
30725 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
30726 VI=AI-4D0*EI*XWV
30727 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
30728 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
30729 VJ=AJ-4D0*EJ*XWV
30730 EPSIJ=ISIGN(1,I*J)
30731C...gamma/Z exchange, only gamma exchange, or only Z exchange
30732 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
30733 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
30734 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
30735 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
30736 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
30737 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30738 ELSEIF(MSTP(21).EQ.2) THEN
30739 FACNCF=FACGGF*EI**2*EJ**2
30740 ELSE
30741 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
30742 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30743 ENDIF
30744C...Extrafactor 2 for only one incoming neutrino spin state.
30745 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
30746 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
30747 NCHN=NCHN+1
30748 ISIG(NCHN,1)=I
30749 ISIG(NCHN,2)=J
30750 ISIG(NCHN,3)=1
30751 SIGH(NCHN)=FACNCF
30752 ENDIF
30753C...W exchange
30754 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
30755 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
30756 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
30757 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
30758 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
30759 NCHN=NCHN+1
30760 ISIG(NCHN,1)=I
30761 ISIG(NCHN,2)=J
30762 ISIG(NCHN,3)=2
30763 SIGH(NCHN)=FACCCF
30764 ENDIF
30765 100 CONTINUE
30766 110 CONTINUE
30767
30768 ELSEIF(ISUB.EQ.11) THEN
30769C...f + f' -> f + f' (g exchange)
30770 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30771 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30772 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30773 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
30774 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
30775 DO 130 I=MMIN1,MMAX1
30776 IA=IABS(I)
30777 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
30778 DO 120 J=MMIN2,MMAX2
30779 JA=IABS(J)
30780 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
30781 NCHN=NCHN+1
30782 ISIG(NCHN,1)=I
30783 ISIG(NCHN,2)=J
30784 ISIG(NCHN,3)=1
30785 SIGH(NCHN)=FACQQ1
30786 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30787 IF(I.EQ.J) THEN
30788 SIGH(NCHN)=0.5D0*SIGH(NCHN)
30789 NCHN=NCHN+1
30790 ISIG(NCHN,1)=I
30791 ISIG(NCHN,2)=J
30792 ISIG(NCHN,3)=2
30793 SIGH(NCHN)=0.5D0*FACQQ2
30794 ENDIF
30795 120 CONTINUE
30796 130 CONTINUE
30797
30798 ELSEIF(ISUB.EQ.12) THEN
30799C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
30800 CALL PYWIDT(21,SH,WDTP,WDTE)
30801 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30802 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
30803 DO 140 I=MMINA,MMAXA
30804 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30805 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
30806 NCHN=NCHN+1
30807 ISIG(NCHN,1)=I
30808 ISIG(NCHN,2)=-I
30809 ISIG(NCHN,3)=1
30810 SIGH(NCHN)=FACQQB
30811 140 CONTINUE
30812
30813 ELSEIF(ISUB.EQ.13) THEN
30814C...f + fbar -> g + g (q + qbar -> g + g only)
30815 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30816 & UH2/SH2)
30817 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30818 & TH2/SH2)
30819 DO 150 I=MMINA,MMAXA
30820 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30821 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
30822 NCHN=NCHN+1
30823 ISIG(NCHN,1)=I
30824 ISIG(NCHN,2)=-I
30825 ISIG(NCHN,3)=1
30826 SIGH(NCHN)=0.5D0*FACGG1
30827 NCHN=NCHN+1
30828 ISIG(NCHN,1)=I
30829 ISIG(NCHN,2)=-I
30830 ISIG(NCHN,3)=2
30831 SIGH(NCHN)=0.5D0*FACGG2
30832 150 CONTINUE
30833
30834 ELSEIF(ISUB.EQ.14) THEN
30835C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
30836 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
30837 DO 160 I=MMINA,MMAXA
30838 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30839 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
30840 EI=KCHG(IABS(I),1)/3D0
30841 NCHN=NCHN+1
30842 ISIG(NCHN,1)=I
30843 ISIG(NCHN,2)=-I
30844 ISIG(NCHN,3)=1
30845 SIGH(NCHN)=FACGG*EI**2
30846 160 CONTINUE
30847
30848 ELSEIF(ISUB.EQ.18) THEN
30849C...f + fbar -> gamma + gamma
30850 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
30851 DO 170 I=MMINA,MMAXA
30852 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
30853 EI=KCHG(IABS(I),1)/3D0
30854 FCOI=1D0
30855 IF(IABS(I).LE.10) FCOI=FACA/3D0
30856 NCHN=NCHN+1
30857 ISIG(NCHN,1)=I
30858 ISIG(NCHN,2)=-I
30859 ISIG(NCHN,3)=1
30860 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
30861 170 CONTINUE
30862 ENDIF
30863
30864 ELSEIF(ISUB.LE.40) THEN
30865 IF(ISUB.EQ.28) THEN
30866C...f + g -> f + g (q + g -> q + g only)
30867 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30868 & UH/SH)*FACA
30869 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30870 & SH/UH)
30871 DO 190 I=MMINA,MMAXA
30872 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
30873 DO 180 ISDE=1,2
30874 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
30875 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
30876 NCHN=NCHN+1
30877 ISIG(NCHN,ISDE)=I
30878 ISIG(NCHN,3-ISDE)=21
30879 ISIG(NCHN,3)=1
30880 SIGH(NCHN)=FACQG1
30881 NCHN=NCHN+1
30882 ISIG(NCHN,ISDE)=I
30883 ISIG(NCHN,3-ISDE)=21
30884 ISIG(NCHN,3)=2
30885 SIGH(NCHN)=FACQG2
30886 180 CONTINUE
30887 190 CONTINUE
30888
30889 ELSEIF(ISUB.EQ.29) THEN
30890C...f + g -> f + gamma (q + g -> q + gamma only)
30891 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
30892 DO 210 I=MMINA,MMAXA
30893 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
30894 EI=KCHG(IABS(I),1)/3D0
30895 FACGQ=FGQ*EI**2
30896 DO 200 ISDE=1,2
30897 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
30898 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
30899 NCHN=NCHN+1
30900 ISIG(NCHN,ISDE)=I
30901 ISIG(NCHN,3-ISDE)=21
30902 ISIG(NCHN,3)=1
30903 SIGH(NCHN)=FACGQ
30904 200 CONTINUE
30905 210 CONTINUE
30906
30907 ELSEIF(ISUB.EQ.33) THEN
30908C...f + gamma -> f + g (q + gamma -> q + g only)
30909 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
30910 DO 230 I=MMINA,MMAXA
30911 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
30912 EI=KCHG(IABS(I),1)/3D0
30913 FACGQ=FGQ*EI**2
30914 DO 220 ISDE=1,2
30915 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
30916 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
30917 NCHN=NCHN+1
30918 ISIG(NCHN,ISDE)=I
30919 ISIG(NCHN,3-ISDE)=22
30920 ISIG(NCHN,3)=1
30921 SIGH(NCHN)=FACGQ
30922 220 CONTINUE
30923 230 CONTINUE
30924
30925 ELSEIF(ISUB.EQ.34) THEN
30926C...f + gamma -> f + gamma
30927 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
30928 DO 250 I=MMINA,MMAXA
30929 IF(I.EQ.0) GOTO 250
30930 EI=KCHG(IABS(I),1)/3D0
30931 FACGQ=FGQ*EI**4
30932 DO 240 ISDE=1,2
30933 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
30934 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
30935 NCHN=NCHN+1
30936 ISIG(NCHN,ISDE)=I
30937 ISIG(NCHN,3-ISDE)=22
30938 ISIG(NCHN,3)=1
30939 SIGH(NCHN)=FACGQ
30940 240 CONTINUE
30941 250 CONTINUE
30942 ENDIF
30943
30944 ELSEIF(ISUB.LE.80) THEN
30945 IF(ISUB.EQ.53) THEN
30946C...g + g -> f + fbar (g + g -> q + qbar only)
30947 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
30948 IDC0=MDCY(21,2)-1
30949C...Begin by d, u, s flavours.
30950 FLAVWT=0D0
30951 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30952 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30953 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30954 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30955 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30956 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30957 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30958 & UH2/SH2)*FLAVWT*FACA
30959 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30960 & TH2/SH2)*FLAVWT*FACA
30961 NCHN=NCHN+1
30962 ISIG(NCHN,1)=21
30963 ISIG(NCHN,2)=21
30964 ISIG(NCHN,3)=1
30965 SIGH(NCHN)=FACQQ1
30966 NCHN=NCHN+1
30967 ISIG(NCHN,1)=21
30968 ISIG(NCHN,2)=21
30969 ISIG(NCHN,3)=2
30970 SIGH(NCHN)=FACQQ2
30971C...Next c and b flavours: modified that and uhat for fixed
30972C...cos(theta-hat).
30973 DO 260 IFL=4,5
30974 SQMAVG=PMAS(IFL,1)**2
30975 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30976 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30977 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30978 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30979 THUHQ=THQ*UHQ-SQMAVG*SH
30980 IF(MSTP(34).EQ.0) THEN
30981 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30982 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30983 ELSE
30984 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30985 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30986 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30987 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30988 ENDIF
30989 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30990 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30991 NCHN=NCHN+1
30992 ISIG(NCHN,1)=21
30993 ISIG(NCHN,2)=21
30994 ISIG(NCHN,3)=1+2*(IFL-3)
30995 SIGH(NCHN)=FACQQ1
30996 NCHN=NCHN+1
30997 ISIG(NCHN,1)=21
30998 ISIG(NCHN,2)=21
30999 ISIG(NCHN,3)=2+2*(IFL-3)
31000 SIGH(NCHN)=FACQQ2
31001 ENDIF
31002 260 CONTINUE
31003 270 CONTINUE
31004
31005 ELSEIF(ISUB.EQ.54) THEN
31006C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
31007 CALL PYWIDT(21,SH,WDTP,WDTE)
31008 WDTESU=0D0
31009 DO 280 I=1,MIN(8,MDCY(21,3))
31010 EF=KCHG(I,1)/3D0
31011 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
31012 & WDTE(I,4))
31013 280 CONTINUE
31014 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
31015 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31016 NCHN=NCHN+1
31017 ISIG(NCHN,1)=21
31018 ISIG(NCHN,2)=22
31019 ISIG(NCHN,3)=1
31020 SIGH(NCHN)=FACQQ
31021 ENDIF
31022 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31023 NCHN=NCHN+1
31024 ISIG(NCHN,1)=22
31025 ISIG(NCHN,2)=21
31026 ISIG(NCHN,3)=1
31027 SIGH(NCHN)=FACQQ
31028 ENDIF
31029
31030 ELSEIF(ISUB.EQ.58) THEN
31031C...gamma + gamma -> f + fbar
31032 CALL PYWIDT(22,SH,WDTP,WDTE)
31033 WDTESU=0D0
31034 DO 290 I=1,MIN(12,MDCY(22,3))
31035 IF(I.LE.8) EF= KCHG(I,1)/3D0
31036 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
31037 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
31038 & WDTE(I,4))
31039 290 CONTINUE
31040 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
31041 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31042 NCHN=NCHN+1
31043 ISIG(NCHN,1)=22
31044 ISIG(NCHN,2)=22
31045 ISIG(NCHN,3)=1
31046 SIGH(NCHN)=FACFF
31047 ENDIF
31048
31049 ELSEIF(ISUB.EQ.68) THEN
31050C...g + g -> g + g
31051 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
31052 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
31053 & TH2/SH2)*FACA
31054 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
31055 & SH2/UH2)*FACA
31056 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
31057 & UH2/TH2)
31058 NCHN=NCHN+1
31059 ISIG(NCHN,1)=21
31060 ISIG(NCHN,2)=21
31061 ISIG(NCHN,3)=1
31062 SIGH(NCHN)=0.5D0*FACGG1
31063 NCHN=NCHN+1
31064 ISIG(NCHN,1)=21
31065 ISIG(NCHN,2)=21
31066 ISIG(NCHN,3)=2
31067 SIGH(NCHN)=0.5D0*FACGG2
31068 NCHN=NCHN+1
31069 ISIG(NCHN,1)=21
31070 ISIG(NCHN,2)=21
31071 ISIG(NCHN,3)=3
31072 SIGH(NCHN)=0.5D0*FACGG3
31073 300 CONTINUE
31074
31075 ELSEIF(ISUB.EQ.80) THEN
31076C...q + gamma -> q' + pi+/-
31077 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
31078 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
31079 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
31080 DELSH=UH*SQRT(ASSH*Q2FPSH)
31081 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
31082 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
31083 DELUH=SH*SQRT(ASUH*Q2FPUH)
31084 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
31085 IF(I.EQ.0) GOTO 320
31086 EI=KCHG(IABS(I),1)/3D0
31087 EJ=SIGN(1D0-ABS(EI),EI)
31088 DO 310 ISDE=1,2
31089 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
31090 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
31091 NCHN=NCHN+1
31092 ISIG(NCHN,ISDE)=I
31093 ISIG(NCHN,3-ISDE)=22
31094 ISIG(NCHN,3)=1
31095 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
31096 310 CONTINUE
31097 320 CONTINUE
31098 ENDIF
31099
31100 ELSEIF(ISUB.LE.100) THEN
31101 IF(ISUB.EQ.91) THEN
31102C...Elastic scattering
31103 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
31104
31105 ELSEIF(ISUB.EQ.92) THEN
31106C...Single diffractive scattering (first side, i.e. XB)
31107 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
31108
31109 ELSEIF(ISUB.EQ.93) THEN
31110C...Single diffractive scattering (second side, i.e. AX)
31111 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
31112
31113 ELSEIF(ISUB.EQ.94) THEN
31114C...Double diffractive scattering
31115 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
31116
31117 ELSEIF(ISUB.EQ.95) THEN
31118C...Low-pT scattering
31119 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
31120
31121 ELSEIF(ISUB.EQ.96) THEN
31122C...Multiple interactions: sum of QCD processes
31123 CALL PYWIDT(21,SH,WDTP,WDTE)
31124
31125C...q + q' -> q + q'
31126 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
31127 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
31128 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
31129 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
31130 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
31131 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
31132 DO 340 I=-5,5
31133 IF(I.EQ.0) GOTO 340
31134 DO 330 J=-5,5
31135 IF(J.EQ.0) GOTO 330
31136 NCHN=NCHN+1
31137 ISIG(NCHN,1)=I
31138 ISIG(NCHN,2)=J
31139 ISIG(NCHN,3)=111
31140 SIGH(NCHN)=FACQQ1
31141 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
31142 IF(I.EQ.J) THEN
31143 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
31144 NCHN=NCHN+1
31145 ISIG(NCHN,1)=I
31146 ISIG(NCHN,2)=J
31147 ISIG(NCHN,3)=112
31148 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
31149 ENDIF
31150 330 CONTINUE
31151 340 CONTINUE
31152
31153C...q + qbar -> q' + qbar' or g + g
31154 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
31155 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
31156 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
31157 & UH2/SH2)
31158 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
31159 & TH2/SH2)
31160 DO 350 I=-5,5
31161 IF(I.EQ.0) GOTO 350
31162 NCHN=NCHN+1
31163 ISIG(NCHN,1)=I
31164 ISIG(NCHN,2)=-I
31165 ISIG(NCHN,3)=121
31166 SIGH(NCHN)=FACQQB
31167 NCHN=NCHN+1
31168 ISIG(NCHN,1)=I
31169 ISIG(NCHN,2)=-I
31170 ISIG(NCHN,3)=131
31171 SIGH(NCHN)=0.5D0*FACGG1
31172 NCHN=NCHN+1
31173 ISIG(NCHN,1)=I
31174 ISIG(NCHN,2)=-I
31175 ISIG(NCHN,3)=132
31176 SIGH(NCHN)=0.5D0*FACGG2
31177 350 CONTINUE
31178
31179C...q + g -> q + g
31180 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
31181 & UH/SH)*FACA
31182 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
31183 & SH/UH)
31184 DO 370 I=-5,5
31185 IF(I.EQ.0) GOTO 370
31186 DO 360 ISDE=1,2
31187 NCHN=NCHN+1
31188 ISIG(NCHN,ISDE)=I
31189 ISIG(NCHN,3-ISDE)=21
31190 ISIG(NCHN,3)=281
31191 SIGH(NCHN)=FACQG1
31192 NCHN=NCHN+1
31193 ISIG(NCHN,ISDE)=I
31194 ISIG(NCHN,3-ISDE)=21
31195 ISIG(NCHN,3)=282
31196 SIGH(NCHN)=FACQG2
31197 360 CONTINUE
31198 370 CONTINUE
31199
31200C...g + g -> q + qbar (only d, u, s)
31201 IDC0=MDCY(21,2)-1
31202 FLAVWT=0D0
31203 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
31204 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
31205 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
31206 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
31207 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
31208 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
31209 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
31210 & UH2/SH2)*FLAVWT*FACA
31211 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
31212 & TH2/SH2)*FLAVWT*FACA
31213 NCHN=NCHN+1
31214 ISIG(NCHN,1)=21
31215 ISIG(NCHN,2)=21
31216 ISIG(NCHN,3)=531
31217 SIGH(NCHN)=FACQQ1
31218 NCHN=NCHN+1
31219 ISIG(NCHN,1)=21
31220 ISIG(NCHN,2)=21
31221 ISIG(NCHN,3)=532
31222 SIGH(NCHN)=FACQQ2
31223
31224C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
31225C...cos(theta-hat)
31226 DO 380 IFL=4,5
31227 SQMAVG=PMAS(IFL,1)**2
31228 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
31229 BE34=SQRT(1D0-4D0*SQMAVG/SH)
31230 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31231 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31232 THUHQ=THQ*UHQ-SQMAVG*SH
31233 IF(MSTP(34).EQ.0) THEN
31234 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
31235 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
31236 ELSE
31237 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31238 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
31239 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31240 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
31241 ENDIF
31242 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
31243 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
31244 NCHN=NCHN+1
31245 ISIG(NCHN,1)=21
31246 ISIG(NCHN,2)=21
31247 ISIG(NCHN,3)=531+2*(IFL-3)
31248 SIGH(NCHN)=FACQQ1
31249 NCHN=NCHN+1
31250 ISIG(NCHN,1)=21
31251 ISIG(NCHN,2)=21
31252 ISIG(NCHN,3)=532+2*(IFL-3)
31253 SIGH(NCHN)=FACQQ2
31254 ENDIF
31255 380 CONTINUE
31256
31257C...g + g -> g + g
31258 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
31259 & 2D0*TH/SH+TH2/SH2)*FACA
31260 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
31261 & 2D0*SH/UH+SH2/UH2)*FACA
31262 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
31263 & 2D0*UH/TH+UH2/TH2)
31264 NCHN=NCHN+1
31265 ISIG(NCHN,1)=21
31266 ISIG(NCHN,2)=21
31267 ISIG(NCHN,3)=681
31268 SIGH(NCHN)=0.5D0*FACGG1
31269 NCHN=NCHN+1
31270 ISIG(NCHN,1)=21
31271 ISIG(NCHN,2)=21
31272 ISIG(NCHN,3)=682
31273 SIGH(NCHN)=0.5D0*FACGG2
31274 NCHN=NCHN+1
31275 ISIG(NCHN,1)=21
31276 ISIG(NCHN,2)=21
31277 ISIG(NCHN,3)=683
31278 SIGH(NCHN)=0.5D0*FACGG3
31279
31280 ELSEIF(ISUB.EQ.99) THEN
31281C...f + gamma* -> f.
31282 IF(MINT(107).EQ.4) THEN
31283 Q2GA=VINT(307)
31284 P2GA=VINT(308)
31285 ISDE=2
31286 ELSE
31287 Q2GA=VINT(308)
31288 P2GA=VINT(307)
31289 ISDE=1
31290 ENDIF
31291 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
31292 PM2RHO=PMAS(PYCOMP(113),1)**2
31293 IF(MSTP(19).EQ.0) THEN
31294 COMFAC=COMFAC/Q2GA
31295 ELSEIF(MSTP(19).EQ.1) THEN
31296 COMFAC=COMFAC/(Q2GA+PM2RHO)
31297 ELSEIF(MSTP(19).EQ.2) THEN
31298 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
31299 ELSE
31300 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
31301 W2GA=VINT(2)
31302 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
31303 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
31304 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
31305 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
31306 ELSE
31307 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
31308 & Q2GA**0.57D0)
31309 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
31310 ENDIF
31311 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
31312 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
31313 ENDIF
31314 DO 390 I=MMINA,MMAXA
31315 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
31316 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
31317 EI=KCHG(IABS(I),1)/3D0
31318 NCHN=NCHN+1
31319 ISIG(NCHN,ISDE)=I
31320 ISIG(NCHN,3-ISDE)=22
31321 ISIG(NCHN,3)=1
31322 SIGH(NCHN)=COMFAC*EI**2
31323 390 CONTINUE
31324 ENDIF
31325
31326 ELSE
31327 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
31328C...g + g -> gamma + gamma or g + g -> g + gamma
31329 A0STUR=0D0
31330 A0STUI=0D0
31331 A0TSUR=0D0
31332 A0TSUI=0D0
31333 A0UTSR=0D0
31334 A0UTSI=0D0
31335 A1STUR=0D0
31336 A1STUI=0D0
31337 A2STUR=0D0
31338 A2STUI=0D0
31339 ALST=LOG(-SH/TH)
31340 ALSU=LOG(-SH/UH)
31341 ALTU=LOG(TH/UH)
31342 IMAX=2*MSTP(1)
31343 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
31344 DO 400 I=1,IMAX
31345 EI=KCHG(IABS(I),1)/3D0
31346 EIWT=EI**2
31347 IF(ISUB.EQ.115) EIWT=EI
31348 SQMQ=PMAS(I,1)**2
31349 EPSS=4D0*SQMQ/SH
31350 EPST=4D0*SQMQ/TH
31351 EPSU=4D0*SQMQ/UH
31352 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
31353 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
31354 & PARU(1)**2)
31355 B0STUI=0D0
31356 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
31357 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
31358 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
31359 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
31360 B1STUR=-1D0
31361 B1STUI=0D0
31362 B2STUR=-1D0
31363 B2STUI=0D0
31364 ELSE
31365 CALL PYWAUX(1,EPSS,W1SR,W1SI)
31366 CALL PYWAUX(1,EPST,W1TR,W1TI)
31367 CALL PYWAUX(1,EPSU,W1UR,W1UI)
31368 CALL PYWAUX(2,EPSS,W2SR,W2SI)
31369 CALL PYWAUX(2,EPST,W2TR,W2TI)
31370 CALL PYWAUX(2,EPSU,W2UR,W2UI)
31371 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
31372 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
31373 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
31374 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
31375 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
31376 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
31377 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
31378 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
31379 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
31380 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
31381 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
31382 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
31383 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
31384 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
31385 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
31386 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
31387 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
31388 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
31389 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
31390 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
31391 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
31392 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
31393 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
31394 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
31395 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
31396 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
31397 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
31398 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
31399 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
31400 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
31401 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
31402 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
31403 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
31404 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
31405 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
31406 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
31407 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
31408 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
31409 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
31410 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
31411 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
31412 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
31413 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
31414 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
31415 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
31416 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
31417 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
31418 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
31419 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
31420 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
31421 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
31422 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
31423 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
31424 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
31425 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
31426 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
31427 ENDIF
31428 A0STUR=A0STUR+EIWT*B0STUR
31429 A0STUI=A0STUI+EIWT*B0STUI
31430 A0TSUR=A0TSUR+EIWT*B0TSUR
31431 A0TSUI=A0TSUI+EIWT*B0TSUI
31432 A0UTSR=A0UTSR+EIWT*B0UTSR
31433 A0UTSI=A0UTSI+EIWT*B0UTSI
31434 A1STUR=A1STUR+EIWT*B1STUR
31435 A1STUI=A1STUI+EIWT*B1STUI
31436 A2STUR=A2STUR+EIWT*B2STUR
31437 A2STUI=A2STUI+EIWT*B2STUI
31438 400 CONTINUE
31439 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
31440 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
31441 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
31442 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
31443 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
31444 NCHN=NCHN+1
31445 ISIG(NCHN,1)=21
31446 ISIG(NCHN,2)=21
31447 ISIG(NCHN,3)=1
31448 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
31449 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
31450 410 CONTINUE
31451
31452 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
31453C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
31454 PH=0D0
31455 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
31456 & PH=VINT(3)**2
31457 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
31458 & PH=VINT(4)**2
31459 IF(ISUB.EQ.131) THEN
31460 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
31461 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
31462 ELSE
31463 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
31464 ENDIF
31465 DO 430 I=MMINA,MMAXA
31466 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
31467 EI=KCHG(IABS(I),1)/3D0
31468 FACGQ=FGQ*EI**2
31469 DO 420 ISDE=1,2
31470 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
31471 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
31472 NCHN=NCHN+1
31473 ISIG(NCHN,ISDE)=I
31474 ISIG(NCHN,3-ISDE)=22
31475 ISIG(NCHN,3)=1
31476 SIGH(NCHN)=FACGQ
31477 420 CONTINUE
31478 430 CONTINUE
31479
31480 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
31481C...f + gamma*_(T,L) -> f + gamma
31482 PH=0D0
31483 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
31484 & PH=VINT(3)**2
31485 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
31486 & PH=VINT(4)**2
31487 IF(ISUB.EQ.133) THEN
31488 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
31489 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
31490 ELSE
31491 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
31492 ENDIF
31493 DO 450 I=MMINA,MMAXA
31494 IF(I.EQ.0) GOTO 450
31495 EI=KCHG(IABS(I),1)/3D0
31496 FACGQ=FGQ*EI**4
31497 DO 440 ISDE=1,2
31498 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
31499 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
31500 NCHN=NCHN+1
31501 ISIG(NCHN,ISDE)=I
31502 ISIG(NCHN,3-ISDE)=22
31503 ISIG(NCHN,3)=1
31504 SIGH(NCHN)=FACGQ
31505 440 CONTINUE
31506 450 CONTINUE
31507
31508 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
31509C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
31510 PH=0D0
31511 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
31512 & PH=VINT(3)**2
31513 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
31514 & PH=VINT(4)**2
31515 CALL PYWIDT(21,SH,WDTP,WDTE)
31516 WDTESU=0D0
31517 DO 460 I=1,MIN(8,MDCY(21,3))
31518 EF=KCHG(I,1)/3D0
31519 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
31520 & WDTE(I,4))
31521 460 CONTINUE
31522 IF(ISUB.EQ.135) THEN
31523 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
31524 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
31525 ELSE
31526 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
31527 ENDIF
31528 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31529 NCHN=NCHN+1
31530 ISIG(NCHN,1)=21
31531 ISIG(NCHN,2)=22
31532 ISIG(NCHN,3)=1
31533 SIGH(NCHN)=FACQQ
31534 ENDIF
31535 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31536 NCHN=NCHN+1
31537 ISIG(NCHN,1)=22
31538 ISIG(NCHN,2)=21
31539 ISIG(NCHN,3)=1
31540 SIGH(NCHN)=FACQQ
31541 ENDIF
31542
31543 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
31544C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
31545 PH1=0D0
31546 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
31547 PH2=0D0
31548 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
31549 CALL PYWIDT(22,SH,WDTP,WDTE)
31550 WDTESU=0D0
31551 DO 470 I=1,MIN(12,MDCY(22,3))
31552 IF(I.LE.8) EF= KCHG(I,1)/3D0
31553 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
31554 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
31555 & WDTE(I,4))
31556 470 CONTINUE
31557 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
31558 IF(ISUB.EQ.137) THEN
31559 FPARAM=-SH*(TH+UH)/DLAMB2
31560 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
31561 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
31562 & 2D0*PH1*PH2*FPARAM**2)
31563 ELSEIF(ISUB.EQ.138) THEN
31564 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
31565 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
31566 & 2D0*PH1**2*(TH-UH)**2)
31567 ELSEIF(ISUB.EQ.139) THEN
31568 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
31569 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
31570 & 2D0*PH2**2*(TH-UH)**2)
31571 ELSE
31572 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
31573 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
31574 ENDIF
31575 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31576 NCHN=NCHN+1
31577 ISIG(NCHN,1)=22
31578 ISIG(NCHN,2)=22
31579 ISIG(NCHN,3)=1
31580 SIGH(NCHN)=FACFF
31581 ENDIF
31582
31583 ENDIF
31584 ENDIF
31585
31586 RETURN
31587 END
31588
31589C*********************************************************************
31590
31591C...PYSGHF
31592C...Subprocess cross sections for heavy flavour production,
31593C...open and closed.
31594C...Auxiliary to PYSIGH.
31595
31596 SUBROUTINE PYSGHF(NCHN,SIGS)
31597
31598C...Double precision and integer declarations
31599 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31600 IMPLICIT INTEGER(I-N)
31601 INTEGER PYK,PYCHGE,PYCOMP
31602C...Parameter statement to help give large particle numbers.
31603 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31604 &KEXCIT=4000000,KDIMEN=5000000)
31605C...Commonblocks
31606 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31607 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31608 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31609 COMMON/PYINT1/MINT(400),VINT(400)
31610 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31611 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31612 COMMON/PYINT4/MWID(500),WIDS(500,5)
31613 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
31614 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
31615 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
31616 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
31617 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
31618 &/PYINT4/,/PYSGCM/
31619C...Local arrays
31620 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
31621
31622C...Determine where are charmonium/bottomonium wave function parameters.
31623 IONIUM=140
31624 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
31625
31626C...Convert bottomonium process into equivalent charmonium ones.
31627 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
31628
31629C...Differential cross section expressions.
31630
31631 IF(ISUB.LE.100) THEN
31632 IF(ISUB.EQ.81) THEN
31633C...q + qbar -> Q + Qbar
31634 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31635 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31636 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31637 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
31638 & 2D0*SQMAVG/SH)
31639 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
31640 WID2=1D0
31641 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31642 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31643 FACQQB=FACQQB*WID2
31644 DO 100 I=MMINA,MMAXA
31645 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31646 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
31647 NCHN=NCHN+1
31648 ISIG(NCHN,1)=I
31649 ISIG(NCHN,2)=-I
31650 ISIG(NCHN,3)=1
31651 SIGH(NCHN)=FACQQB
31652 100 CONTINUE
31653
31654 ELSEIF(ISUB.EQ.82) THEN
31655C...g + g -> Q + Qbar
31656 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31657 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31658 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31659 THUHQ=THQ*UHQ-SQMAVG*SH
31660 IF(MSTP(34).EQ.0) THEN
31661 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
31662 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
31663 ELSE
31664 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31665 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
31666 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31667 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
31668 ENDIF
31669 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
31670 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
31671 IF(MSTP(35).GE.1) THEN
31672 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
31673 FACQQ1=FACQQ1*FATRE
31674 FACQQ2=FACQQ2*FATRE
31675 ENDIF
31676 WID2=1D0
31677 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31678 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31679 FACQQ1=FACQQ1*WID2
31680 FACQQ2=FACQQ2*WID2
31681 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
31682 NCHN=NCHN+1
31683 ISIG(NCHN,1)=21
31684 ISIG(NCHN,2)=21
31685 ISIG(NCHN,3)=1
31686 SIGH(NCHN)=FACQQ1
31687 NCHN=NCHN+1
31688 ISIG(NCHN,1)=21
31689 ISIG(NCHN,2)=21
31690 ISIG(NCHN,3)=2
31691 SIGH(NCHN)=FACQQ2
31692 110 CONTINUE
31693
31694 ELSEIF(ISUB.EQ.83) THEN
31695C...f + q -> f' + Q
31696 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
31697 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
31698 DO 130 I=MMIN1,MMAX1
31699 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
31700 DO 120 J=MMIN2,MMAX2
31701 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
31702 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
31703 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
31704 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
31705 & THEN
31706 NCHN=NCHN+1
31707 ISIG(NCHN,1)=I
31708 ISIG(NCHN,2)=J
31709 ISIG(NCHN,3)=1
31710 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31711 & (IABS(I)+1)/2)*VINT(180+J)
31712 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
31713 & (MINT(55)+1)/2)*VINT(180+J)
31714 WID2=1D0
31715 IF(I.GT.0) THEN
31716 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31717 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31718 & WIDS(MINT(55),2)
31719 ELSE
31720 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31721 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31722 & WIDS(MINT(55),3)
31723 ENDIF
31724 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31725 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31726 ENDIF
31727 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
31728 & THEN
31729 NCHN=NCHN+1
31730 ISIG(NCHN,1)=I
31731 ISIG(NCHN,2)=J
31732 ISIG(NCHN,3)=2
31733 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31734 & (IABS(J)+1)/2)*VINT(180+I)
31735 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
31736 & (MINT(55)+1)/2)*VINT(180+I)
31737 WID2=1D0
31738 IF(J.GT.0) THEN
31739 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31740 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31741 & WIDS(MINT(55),2)
31742 ELSE
31743 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31744 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31745 & WIDS(MINT(55),3)
31746 ENDIF
31747 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31748 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31749 ENDIF
31750 120 CONTINUE
31751 130 CONTINUE
31752
31753 ELSEIF(ISUB.EQ.84) THEN
31754C...g + gamma -> Q + Qbar
31755 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31756 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31757 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31758 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
31759 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
31760 & (THQ*UHQ)
31761 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
31762 WID2=1D0
31763 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31764 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31765 FACQQ=FACQQ*WID2
31766 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31767 NCHN=NCHN+1
31768 ISIG(NCHN,1)=21
31769 ISIG(NCHN,2)=22
31770 ISIG(NCHN,3)=1
31771 SIGH(NCHN)=FACQQ
31772 ENDIF
31773 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31774 NCHN=NCHN+1
31775 ISIG(NCHN,1)=22
31776 ISIG(NCHN,2)=21
31777 ISIG(NCHN,3)=1
31778 SIGH(NCHN)=FACQQ
31779 ENDIF
31780
31781 ELSEIF(ISUB.EQ.85) THEN
31782C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
31783 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31784 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31785 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31786 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
31787 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
31788 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
31789 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
31790 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
31791 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
31792 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
31793 WID2=1D0
31794 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
31795 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
31796 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
31797 FACFF=FACFF*WID2
31798 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31799 NCHN=NCHN+1
31800 ISIG(NCHN,1)=22
31801 ISIG(NCHN,2)=22
31802 ISIG(NCHN,3)=1
31803 SIGH(NCHN)=FACFF
31804 ENDIF
31805
31806 ELSEIF(ISUB.EQ.86) THEN
31807C...g + g -> J/Psi + g
31808 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
31809 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31810 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31811 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31812 NCHN=NCHN+1
31813 ISIG(NCHN,1)=21
31814 ISIG(NCHN,2)=21
31815 ISIG(NCHN,3)=1
31816 SIGH(NCHN)=FACQQG
31817 ENDIF
31818
31819 ELSEIF(ISUB.EQ.87) THEN
31820C...g + g -> chi_0c + g
31821 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31822 QGTW=(SH*TH*UH)/SH**3
31823 RGTW=SQM3/SH
31824 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31825 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31826 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
31827 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
31828 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
31829 & (QGTW*(QGTW-RGTW*PGTW)**4)
31830 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31831 NCHN=NCHN+1
31832 ISIG(NCHN,1)=21
31833 ISIG(NCHN,2)=21
31834 ISIG(NCHN,3)=1
31835 SIGH(NCHN)=FACQQG
31836 ENDIF
31837
31838 ELSEIF(ISUB.EQ.88) THEN
31839C...g + g -> chi_1c + g
31840 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31841 QGTW=(SH*TH*UH)/SH**3
31842 RGTW=SQM3/SH
31843 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31844 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
31845 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
31846 & (QGTW-RGTW*PGTW)**4
31847 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31848 NCHN=NCHN+1
31849 ISIG(NCHN,1)=21
31850 ISIG(NCHN,2)=21
31851 ISIG(NCHN,3)=1
31852 SIGH(NCHN)=FACQQG
31853 ENDIF
31854
31855 ELSEIF(ISUB.EQ.89) THEN
31856C...g + g -> chi_2c + g
31857 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31858 QGTW=(SH*TH*UH)/SH**3
31859 RGTW=SQM3/SH
31860 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31861 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31862 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
31863 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
31864 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
31865 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31866 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31867 NCHN=NCHN+1
31868 ISIG(NCHN,1)=21
31869 ISIG(NCHN,2)=21
31870 ISIG(NCHN,3)=1
31871 SIGH(NCHN)=FACQQG
31872 ENDIF
31873 ENDIF
31874
31875 ELSEIF(ISUB.LE.200) THEN
31876 IF(ISUB.EQ.104) THEN
31877C...g + g -> chi_c0.
31878 KC=PYCOMP(10441)
31879 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
31880 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31881 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31882 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31883 NCHN=NCHN+1
31884 ISIG(NCHN,1)=21
31885 ISIG(NCHN,2)=21
31886 ISIG(NCHN,3)=1
31887 SIGH(NCHN)=FACBW
31888 ENDIF
31889
31890 ELSEIF(ISUB.EQ.105) THEN
31891C...g + g -> chi_c2.
31892 KC=PYCOMP(445)
31893 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
31894 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31895 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31896 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31897 NCHN=NCHN+1
31898 ISIG(NCHN,1)=21
31899 ISIG(NCHN,2)=21
31900 ISIG(NCHN,3)=1
31901 SIGH(NCHN)=FACBW
31902 ENDIF
31903
31904 ELSEIF(ISUB.EQ.106) THEN
31905C...g + g -> J/Psi + gamma.
31906 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31907 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
31908 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31909 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31910 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31911 NCHN=NCHN+1
31912 ISIG(NCHN,1)=21
31913 ISIG(NCHN,2)=21
31914 ISIG(NCHN,3)=1
31915 SIGH(NCHN)=FACQQG
31916 ENDIF
31917
31918 ELSEIF(ISUB.EQ.107) THEN
31919C...g + gamma -> J/Psi + g.
31920 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31921 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
31922 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31923 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31924 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31925 NCHN=NCHN+1
31926 ISIG(NCHN,1)=21
31927 ISIG(NCHN,2)=22
31928 ISIG(NCHN,3)=1
31929 SIGH(NCHN)=FACQQG
31930 ENDIF
31931 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31932 NCHN=NCHN+1
31933 ISIG(NCHN,1)=22
31934 ISIG(NCHN,2)=21
31935 ISIG(NCHN,3)=1
31936 SIGH(NCHN)=FACQQG
31937 ENDIF
31938
31939 ELSEIF(ISUB.EQ.108) THEN
31940C...gamma + gamma -> J/Psi + gamma.
31941 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31942 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
31943 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31944 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31945 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31946 NCHN=NCHN+1
31947 ISIG(NCHN,1)=22
31948 ISIG(NCHN,2)=22
31949 ISIG(NCHN,3)=1
31950 SIGH(NCHN)=FACQQG
31951 ENDIF
31952 ENDIF
31953
31954C...QUARKONIA+++
31955C...Additional code by Stefan Wolf
31956 ELSE
31957
31958C...Common code for quarkonium production.
31959 SHTH=SH+TH
31960 THUH=TH+UH
31961 UHSH=UH+SH
31962 SHTH2=SHTH**2
31963 THUH2=THUH**2
31964 UHSH2=UHSH**2
31965 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
31966 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
31967 SQMQQ=SQM3
31968 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
31969 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
31970 SQMQQ=SQM4
31971 ENDIF
31972 SQMQQR=SQRT(SQMQQ)
31973 IF(MSTP(145).EQ.1) THEN
31974 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
31975 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
31976 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
31977 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
31978 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31979 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31980 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31981 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31982 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
31983 & ISUB.GE.437) THEN
31984 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
31985 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
31986 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31987 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31988 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31989 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31990 ENDIF
31991 AQ2=AQ**2
31992 BQ2=BQ**2
31993 SMQQ2=SQMQQ*VINT(2)
31994C...Polarisation frames
31995 IF(MSTP(146).EQ.1) THEN
31996C...Recoil frame
31997 POLH1=SQRT(AQ2-SMQQ2)
31998 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31999 AZ=-SQMQQR/POLH1
32000 BZ=0D0
32001 AX=AQ*BQ/(POLH1*POLH2)
32002 BX=-POLH1/POLH2
32003 ELSEIF(MSTP(146).EQ.2) THEN
32004C...Gottfried Jackson frame
32005 POLH1=AQ+BQ
32006 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
32007 AZ=SQMQQR/POLH1
32008 BZ=AZ
32009 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
32010 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
32011 ELSEIF(MSTP(146).EQ.3) THEN
32012C...Target frame
32013 POLH1=AQ-BQ
32014 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
32015 AZ=-SQMQQR/POLH1
32016 BZ=-AZ
32017 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
32018 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
32019 ELSEIF(MSTP(146).EQ.4) THEN
32020C...Collins Soper frame
32021 POLH1=AQ2-BQ2
32022 POLH2=SQRT(VINT(2)*POLH1)
32023 AZ=-BQ/POLH2
32024 BZ=AQ/POLH2
32025 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
32026 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
32027 ENDIF
32028C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
32029 EL1K10=AZ*ATILK1+BZ*BTILK1
32030 EL1K20=AZ*ATILK2+BZ*BTILK2
32031 EL2K10=EL1K10
32032 EL2K20=EL1K20
32033 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
32034 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
32035 EL2K11=EL1K11
32036 EL2K21=EL1K21
32037 ENDIF
32038
32039 IF(ISUB.EQ.421) THEN
32040C...g + g -> QQ~[3S11] + g
32041 IF(MSTP(145).EQ.0) THEN
32042* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
32043* & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
32044 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
32045 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
32046* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
32047* & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
32048 ELSE
32049 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
32050 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
32051 BB=2D0*(SH2+TH2)
32052 CC=2D0*(SH2+UH2)
32053 DD=2D0*SH2
32054 IF(MSTP(147).EQ.0) THEN
32055 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32056 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32057 ELSEIF(MSTP(147).EQ.1) THEN
32058 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32059 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32060 ELSEIF(MSTP(147).EQ.3) THEN
32061 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32062 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32063 ELSEIF(MSTP(147).EQ.4) THEN
32064 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32065 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32066 ELSEIF(MSTP(147).EQ.5) THEN
32067 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32068 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32069 ELSEIF(MSTP(147).EQ.6) THEN
32070 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32071 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32072 ENDIF
32073 FACQQG=COMFAC*FF*FACQQG
32074 ENDIF
32075 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32076 NCHN=NCHN+1
32077 ISIG(NCHN,1)=21
32078 ISIG(NCHN,2)=21
32079 ISIG(NCHN,3)=1
32080 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
32081 ENDIF
32082
32083 ELSEIF(ISUB.EQ.422) THEN
32084C...g + g -> QQ~[3S18] + g
32085 IF(MSTP(145).EQ.0) THEN
32086 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
32087 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
32088 & (SQMQQ*SQMQQR)*
32089 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
32090 ELSE
32091 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
32092 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
32093 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
32094 BB=2D0*(SH2+TH2)
32095 CC=2D0*(SH2+UH2)
32096 DD=2D0*SH2
32097 IF(MSTP(147).EQ.0) THEN
32098 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32099 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32100 ELSEIF(MSTP(147).EQ.1) THEN
32101 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32102 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32103 ELSEIF(MSTP(147).EQ.3) THEN
32104 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32105 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32106 ELSEIF(MSTP(147).EQ.4) THEN
32107 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32108 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32109 ELSEIF(MSTP(147).EQ.5) THEN
32110 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32111 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32112 ELSEIF(MSTP(147).EQ.6) THEN
32113 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32114 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32115 ENDIF
32116 FACQQG=COMFAC*FF*FACQQG
32117 ENDIF
32118C...Split total contribution into different colour flows just like
32119C...in g g -> g g (recalculate kinematics for massless partons).
32120 THP=-0.5D0*SH*(1D0-CTH)
32121 UHP=-0.5D0*SH*(1D0+CTH)
32122 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
32123 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
32124 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
32125 FACGGS=FACGG1+FACGG2+FACGG3
32126 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32127 NCHN=NCHN+1
32128 ISIG(NCHN,1)=21
32129 ISIG(NCHN,2)=21
32130 ISIG(NCHN,3)=1
32131 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
32132 NCHN=NCHN+1
32133 ISIG(NCHN,1)=21
32134 ISIG(NCHN,2)=21
32135 ISIG(NCHN,3)=2
32136 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
32137 NCHN=NCHN+1
32138 ISIG(NCHN,1)=21
32139 ISIG(NCHN,2)=21
32140 ISIG(NCHN,3)=3
32141 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
32142 ENDIF
32143
32144 ELSEIF(ISUB.EQ.423) THEN
32145C...g + g -> QQ~[1S08] + g
32146 IF(MSTP(145).EQ.0) THEN
32147* FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
32148* & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
32149* & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
32150* & (SHTH2*THUH2*UHSH2)
32151 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
32152 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
32153 & TH2/(SHTH2*THUH2))*
32154 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
32155 ELSE
32156 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
32157 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
32158 & TH2/(SHTH2*THUH2))*
32159 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
32160 IF(MSTP(147).EQ.0) THEN
32161 FACQQG=COMFAC*FA
32162 ELSEIF(MSTP(147).EQ.1) THEN
32163 FACQQG=COMFAC*2D0*FA
32164 ELSEIF(MSTP(147).EQ.3) THEN
32165 FACQQG=COMFAC*FA
32166 ELSEIF(MSTP(147).EQ.4) THEN
32167 FACQQG=COMFAC*FA
32168 ELSEIF(MSTP(147).EQ.5) THEN
32169 FACQQG=0D0
32170 ELSEIF(MSTP(147).EQ.6) THEN
32171 FACQQG=0D0
32172 ENDIF
32173 ENDIF
32174C...Split total contribution into different colour flows just like
32175C...in g g -> g g (recalculate kinematics for massless partons).
32176 THP=-0.5D0*SH*(1D0-CTH)
32177 UHP=-0.5D0*SH*(1D0+CTH)
32178 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
32179 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
32180 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
32181 FACGGS=FACGG1+FACGG2+FACGG3
32182 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32183 NCHN=NCHN+1
32184 ISIG(NCHN,1)=21
32185 ISIG(NCHN,2)=21
32186 ISIG(NCHN,3)=1
32187 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
32188 NCHN=NCHN+1
32189 ISIG(NCHN,1)=21
32190 ISIG(NCHN,2)=21
32191 ISIG(NCHN,3)=2
32192 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
32193 NCHN=NCHN+1
32194 ISIG(NCHN,1)=21
32195 ISIG(NCHN,2)=21
32196 ISIG(NCHN,3)=3
32197 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
32198 ENDIF
32199
32200 ELSEIF(ISUB.EQ.424) THEN
32201C...g + g -> QQ~[3PJ8] + g
32202 POLY=SH2+SH*TH+TH2
32203 IF(MSTP(145).EQ.0) THEN
32204 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
32205 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
32206 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
32207 & +7D0*TH**6)
32208 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
32209 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
32210 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
32211 & +35D0*TH**8)
32212 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
32213 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
32214 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
32215 & +84D0*TH**8)
32216 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
32217 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
32218 & +451D0*SH*TH**5+126D0*TH**6)
32219 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
32220 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
32221 & +171D0*SH*TH**5+42D0*TH**6)
32222 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
32223 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
32224 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
32225 & +99D0*SH*TH**3+35D0*TH**4)
32226 & +7D0*SQMQQ**8*SHTH*POLY)/
32227 & (SH*TH*UH*SQMQQR*SQMQQ*
32228 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
32229 ELSE
32230 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
32231 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
32232 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
32233 & -SQMQQ*SHTH2*POLY**2*
32234 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
32235 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
32236 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
32237 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
32238 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
32239 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
32240 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
32241 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
32242 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
32243 & +145D0*SH*TH**5+34D0*TH**6)
32244 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
32245 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
32246 & +44D0*TH**6)
32247 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
32248 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
32249 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
32250 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
32251 & +3D0*SQMQQ**8*SHTH*POLY)
32252 BB=4D0*SHTH2*POLY**3
32253 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
32254 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
32255 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
32256 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
32257 & +84D0*SH*TH**9+20D0*TH**10)
32258 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
32259 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
32260 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
32261 & +40D0*TH**8)
32262 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
32263 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
32264 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
32265 & +40D0*TH**8)
32266 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
32267 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
32268 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
32269 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
32270 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
32271 & +4D0*TH**6)
32272 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
32273 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
32274 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
32275 CC=4D0*TH2*POLY**3
32276 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
32277 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
32278 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
32279 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
32280 & +28D0*TH**9)
32281 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
32282 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
32283 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
32284 & +394D0*SH*TH**9+84D0*TH**10)
32285 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
32286 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
32287 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
32288 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
32289 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
32290 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
32291 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
32292 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
32293 & +266D0*SH*TH**6+84D0*TH**7)
32294 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
32295 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
32296 & +28D0*TH**6)
32297 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
32298 & +7D0*SH*TH**3+4*TH**4)
32299 & +SQMQQ**8*SH*(SH-TH)**2*TH
32300 DD=2D0*TH2*SHTH2*POLY**3
32301 & *(-SH2+2*SH*TH+2*TH2)
32302 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
32303 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
32304 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
32305 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
32306 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
32307 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
32308 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
32309 & -210D0*SH*TH**8-60D0*TH**9)
32310 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
32311 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
32312 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
32313 & -80D0*TH**8)
32314 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
32315 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
32316 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
32317 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
32318 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
32319 & -30D0*SH*TH**6-24D0*TH**7)
32320 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
32321 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
32322 & -4D0*TH**6)
32323 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
32324 IF(MSTP(147).EQ.0) THEN
32325 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32326 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32327 ELSEIF(MSTP(147).EQ.1) THEN
32328 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32329 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32330 ELSEIF(MSTP(147).EQ.3) THEN
32331 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32332 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32333 ELSEIF(MSTP(147).EQ.4) THEN
32334 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32335 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32336 ELSEIF(MSTP(147).EQ.5) THEN
32337 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32338 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32339 ELSEIF(MSTP(147).EQ.6) THEN
32340 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32341 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32342 ENDIF
32343 FACQQG=COMFAC*FF*FACQQG
32344 ENDIF
32345C...Split total contribution into different colour flows just like
32346C...in g g -> g g (recalculate kinematics for massless partons).
32347 THP=-0.5D0*SH*(1D0-CTH)
32348 UHP=-0.5D0*SH*(1D0+CTH)
32349 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
32350 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
32351 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
32352 FACGGS=FACGG1+FACGG2+FACGG3
32353 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32354 NCHN=NCHN+1
32355 ISIG(NCHN,1)=21
32356 ISIG(NCHN,2)=21
32357 ISIG(NCHN,3)=1
32358 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
32359 NCHN=NCHN+1
32360 ISIG(NCHN,1)=21
32361 ISIG(NCHN,2)=21
32362 ISIG(NCHN,3)=2
32363 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
32364 NCHN=NCHN+1
32365 ISIG(NCHN,1)=21
32366 ISIG(NCHN,2)=21
32367 ISIG(NCHN,3)=3
32368 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
32369 ENDIF
32370
32371 ELSEIF(ISUB.EQ.425) THEN
32372C...q + g -> q + QQ~[3S18]
32373 IF(MSTP(145).EQ.0) THEN
32374 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
32375 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
32376 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
32377 ELSE
32378 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
32379 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
32380 AA=SHTH2+THUH2
32381 BB=4D0
32382 CC=8D0
32383 DD=4D0
32384 IF(MSTP(147).EQ.0) THEN
32385 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32386 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32387 ELSEIF(MSTP(147).EQ.1) THEN
32388 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32389 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32390 ELSEIF(MSTP(147).EQ.3) THEN
32391 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32392 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32393 ELSEIF(MSTP(147).EQ.4) THEN
32394 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32395 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32396 ELSEIF(MSTP(147).EQ.5) THEN
32397 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32398 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32399 ELSEIF(MSTP(147).EQ.6) THEN
32400 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32401 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32402 ENDIF
32403 FACQQG=COMFAC*FF*FACQQG
32404 ENDIF
32405C...Split total contribution into different colour flows just like
32406C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
32407C...(recalculate kinematics for massless partons).
32408 THP=-0.5D0*SH*(1D0-CTH)
32409 UHP=-0.5D0*SH*(1D0+CTH)
32410 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
32411 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
32412 FACQGS=FACQG1+FACQG2
32413 DO 2442 I=MMINA,MMAXA
32414 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
32415 DO 2441 ISDE=1,2
32416 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
32417 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
32418 NCHN=NCHN+1
32419 ISIG(NCHN,ISDE)=I
32420 ISIG(NCHN,3-ISDE)=21
32421 ISIG(NCHN,3)=1
32422 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
32423 NCHN=NCHN+1
32424 ISIG(NCHN,ISDE)=I
32425 ISIG(NCHN,3-ISDE)=21
32426 ISIG(NCHN,3)=2
32427 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
32428 2441 CONTINUE
32429 2442 CONTINUE
32430
32431 ELSEIF(ISUB.EQ.426) THEN
32432C...q + g -> q + QQ~[1S08]
32433 IF(MSTP(145).EQ.0) THEN
32434 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
32435 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
32436 ELSE
32437 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
32438 IF(MSTP(147).EQ.0) THEN
32439 FACQQG=COMFAC*FA
32440 ELSEIF(MSTP(147).EQ.1) THEN
32441 FACQQG=COMFAC*2D0*FA
32442 ELSEIF(MSTP(147).EQ.3) THEN
32443 FACQQG=COMFAC*FA
32444 ELSEIF(MSTP(147).EQ.4) THEN
32445 FACQQG=COMFAC*FA
32446 ELSEIF(MSTP(147).EQ.5) THEN
32447 FACQQG=0D0
32448 ELSEIF(MSTP(147).EQ.6) THEN
32449 FACQQG=0D0
32450 ENDIF
32451 ENDIF
32452C...Split total contribution into different colour flows just like
32453C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
32454C...(recalculate kinematics for massless partons).
32455 THP=-0.5D0*SH*(1D0-CTH)
32456 UHP=-0.5D0*SH*(1D0+CTH)
32457 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
32458 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
32459 FACQGS=FACQG1+FACQG2
32460 DO 2444 I=MMINA,MMAXA
32461 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
32462 DO 2443 ISDE=1,2
32463 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
32464 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
32465 NCHN=NCHN+1
32466 ISIG(NCHN,ISDE)=I
32467 ISIG(NCHN,3-ISDE)=21
32468 ISIG(NCHN,3)=1
32469 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
32470 NCHN=NCHN+1
32471 ISIG(NCHN,ISDE)=I
32472 ISIG(NCHN,3-ISDE)=21
32473 ISIG(NCHN,3)=2
32474 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
32475 2443 CONTINUE
32476 2444 CONTINUE
32477
32478 ELSEIF(ISUB.EQ.427) THEN
32479C...q + g -> q + QQ~[3PJ8]
32480 IF(MSTP(145).EQ.0) THEN
32481 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
32482 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
32483 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
32484 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
32485 ELSE
32486 FF=10D0*PARU(1)*AS**3/
32487 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
32488 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
32489 BB=8D0*(SHTH2+TH*UH)
32490 CC=8D0*UHSH*(SHTH+THUH)
32491 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
32492 IF(MSTP(147).EQ.0) THEN
32493 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32494 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32495 ELSEIF(MSTP(147).EQ.1) THEN
32496 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32497 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32498 ELSEIF(MSTP(147).EQ.3) THEN
32499 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32500 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32501 ELSEIF(MSTP(147).EQ.4) THEN
32502 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32503 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32504 ELSEIF(MSTP(147).EQ.5) THEN
32505 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32506 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32507 ELSEIF(MSTP(147).EQ.6) THEN
32508 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32509 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32510 ENDIF
32511 FACQQG=COMFAC*FF*FACQQG
32512 ENDIF
32513C...Split total contribution into different colour flows just like
32514C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
32515C...(recalculate kinematics for massless partons).
32516 THP=-0.5D0*SH*(1D0-CTH)
32517 UHP=-0.5D0*SH*(1D0+CTH)
32518 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
32519 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
32520 FACQGS=FACQG1+FACQG2
32521 DO 2446 I=MMINA,MMAXA
32522 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
32523 DO 2445 ISDE=1,2
32524 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
32525 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
32526 NCHN=NCHN+1
32527 ISIG(NCHN,ISDE)=I
32528 ISIG(NCHN,3-ISDE)=21
32529 ISIG(NCHN,3)=1
32530 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
32531 NCHN=NCHN+1
32532 ISIG(NCHN,ISDE)=I
32533 ISIG(NCHN,3-ISDE)=21
32534 ISIG(NCHN,3)=2
32535 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
32536 2445 CONTINUE
32537 2446 CONTINUE
32538
32539 ELSEIF(ISUB.EQ.428) THEN
32540C...q + q~ -> g + QQ~[3S18]
32541 IF(MSTP(145).EQ.0) THEN
32542 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
32543 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
32544 & (SQMQQ*SQMQQR*TH*UH*THUH2)
32545 ELSE
32546 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
32547 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
32548 AA=SHTH2+UHSH2
32549 BB=4D0
32550 CC=4D0
32551 DD=0D0
32552 IF(MSTP(147).EQ.0) THEN
32553 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32554 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32555 ELSEIF(MSTP(147).EQ.1) THEN
32556 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32557 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32558 ELSEIF(MSTP(147).EQ.3) THEN
32559 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32560 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32561 ELSEIF(MSTP(147).EQ.4) THEN
32562 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32563 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32564 ELSEIF(MSTP(147).EQ.5) THEN
32565 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32566 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32567 ELSEIF(MSTP(147).EQ.6) THEN
32568 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32569 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32570 ENDIF
32571 FACQQG=COMFAC*FF*FACQQG
32572 ENDIF
32573C...Split total contribution into different colour flows just like
32574C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32575C...(recalculate kinematics for massless partons).
32576 THP=-0.5D0*SH*(1D0-CTH)
32577 UHP=-0.5D0*SH*(1D0+CTH)
32578 FACGG1=UH/TH-9D0/4D0*UH2/SH2
32579 FACGG2=TH/UH-9D0/4D0*TH2/SH2
32580 FACGGS=FACGG1+FACGG2
32581 DO 2447 I=MMINA,MMAXA
32582 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32583 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
32584 NCHN=NCHN+1
32585 ISIG(NCHN,1)=I
32586 ISIG(NCHN,2)=-I
32587 ISIG(NCHN,3)=1
32588 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
32589 NCHN=NCHN+1
32590 ISIG(NCHN,1)=I
32591 ISIG(NCHN,2)=-I
32592 ISIG(NCHN,3)=2
32593 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
32594 2447 CONTINUE
32595
32596 ELSEIF(ISUB.EQ.429) THEN
32597C...q + q~ -> g + QQ~[1S08]
32598 IF(MSTP(145).EQ.0) THEN
32599 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
32600 & (TH2+UH2)/(SQMQQR*SH*THUH2)
32601 ELSE
32602 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
32603 IF(MSTP(147).EQ.0) THEN
32604 FACQQG=COMFAC*FA
32605 ELSEIF(MSTP(147).EQ.1) THEN
32606 FACQQG=COMFAC*2D0*FA
32607 ELSEIF(MSTP(147).EQ.3) THEN
32608 FACQQG=COMFAC*FA
32609 ELSEIF(MSTP(147).EQ.4) THEN
32610 FACQQG=COMFAC*FA
32611 ELSEIF(MSTP(147).EQ.5) THEN
32612 FACQQG=0D0
32613 ELSEIF(MSTP(147).EQ.6) THEN
32614 FACQQG=0D0
32615 ENDIF
32616 ENDIF
32617C...Split total contribution into different colour flows just like
32618C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32619C...(recalculate kinematics for massless partons).
32620 THP=-0.5D0*SH*(1D0-CTH)
32621 UHP=-0.5D0*SH*(1D0+CTH)
32622 FACGG1=UH/TH-9D0/4D0*UH2/SH2
32623 FACGG2=TH/UH-9D0/4D0*TH2/SH2
32624 FACGGS=FACGG1+FACGG2
32625 DO 2448 I=MMINA,MMAXA
32626 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32627 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
32628 NCHN=NCHN+1
32629 ISIG(NCHN,1)=I
32630 ISIG(NCHN,2)=-I
32631 ISIG(NCHN,3)=1
32632 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
32633 NCHN=NCHN+1
32634 ISIG(NCHN,1)=I
32635 ISIG(NCHN,2)=-I
32636 ISIG(NCHN,3)=2
32637 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
32638 2448 CONTINUE
32639
32640 ELSEIF(ISUB.EQ.430) THEN
32641C...q + q~ -> g + QQ~[3PJ8]
32642 IF(MSTP(145).EQ.0) THEN
32643 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
32644 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
32645 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
32646 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
32647 ELSE
32648 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
32649 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
32650 BB=8D0*(UHSH2+SH*TH)
32651 CC=8D0*(SHTH2+SH*UH)
32652 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
32653 IF(MSTP(147).EQ.0) THEN
32654 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32655 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32656 ELSEIF(MSTP(147).EQ.1) THEN
32657 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32658 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32659 ELSEIF(MSTP(147).EQ.3) THEN
32660 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32661 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32662 ELSEIF(MSTP(147).EQ.4) THEN
32663 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32664 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32665 ELSEIF(MSTP(147).EQ.5) THEN
32666 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32667 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32668 ELSEIF(MSTP(147).EQ.6) THEN
32669 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32670 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32671 ENDIF
32672 FACQQG=COMFAC*FF*FACQQG
32673 ENDIF
32674C...Split total contribution into different colour flows just like
32675C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32676C...(recalculate kinematics for massless partons).
32677 THP=-0.5D0*SH*(1D0-CTH)
32678 UHP=-0.5D0*SH*(1D0+CTH)
32679 FACGG1=UH/TH-9D0/4D0*UH2/SH2
32680 FACGG2=TH/UH-9D0/4D0*TH2/SH2
32681 FACGGS=FACGG1+FACGG2
32682 DO 2449 I=MMINA,MMAXA
32683 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32684 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
32685 NCHN=NCHN+1
32686 ISIG(NCHN,1)=I
32687 ISIG(NCHN,2)=-I
32688 ISIG(NCHN,3)=1
32689 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
32690 NCHN=NCHN+1
32691 ISIG(NCHN,1)=I
32692 ISIG(NCHN,2)=-I
32693 ISIG(NCHN,3)=2
32694 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
32695 2449 CONTINUE
32696
32697 ELSEIF(ISUB.EQ.431) THEN
32698C...g + g -> QQ~[3P01] + g
32699 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32700 QGTW=(SH*TH*UH)/SH**3
32701 RGTW=SQMQQ/SH
32702 IF(MSTP(145).EQ.0) THEN
32703 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32704 & (9D0*RGTW**2*PGTW**4*
32705 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32706 & -6D0*RGTW*PGTW**3*QGTW*
32707 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32708 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32709 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32710 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32711 ELSE
32712 FC1=PARU(1)*AS**3*8D0/(27D0*SQMQQR*SH)*
32713 & (9D0*RGTW**2*PGTW**4*
32714 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32715 & -6D0*RGTW*PGTW**3*QGTW*
32716 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32717 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32718 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32719 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32720 IF(MSTP(147).EQ.0) THEN
32721 FACQQG=COMFAC*FC1
32722 ELSEIF(MSTP(147).EQ.1) THEN
32723 FACQQG=COMFAC*2D0*FC1
32724 ELSEIF(MSTP(147).EQ.3) THEN
32725 FACQQG=COMFAC*FC1
32726 ELSEIF(MSTP(147).EQ.4) THEN
32727 FACQQG=COMFAC*FC1
32728 ELSEIF(MSTP(147).EQ.5) THEN
32729 FACQQG=0D0
32730 ELSEIF(MSTP(147).EQ.6) THEN
32731 FACQQG=0D0
32732 ENDIF
32733 ENDIF
32734 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32735 NCHN=NCHN+1
32736 ISIG(NCHN,1)=21
32737 ISIG(NCHN,2)=21
32738 ISIG(NCHN,3)=1
32739 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32740 ENDIF
32741
32742 ELSEIF(ISUB.EQ.432) THEN
32743C...g + g -> QQ~[3P11] + g
32744 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32745 QGTW=(SH*TH*UH)/SH**3
32746 RGTW=SQMQQ/SH
32747 IF(MSTP(145).EQ.0) THEN
32748 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
32749 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
32750 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
32751 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
32752 ELSE
32753 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
32754 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
32755 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
32756 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
32757 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
32758 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32759 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32760 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
32761 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32762 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32763 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
32764 C4=-4D0*THUH*(TH-UH)**2*
32765 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
32766 & -SH2*TH*UH*(TH2+UH2))
32767 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
32768 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
32769 & +SH2*(5D0*THUH2-17D0*TH*UH)))
32770 IF(MSTP(147).EQ.0) THEN
32771 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32772 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32773 ELSEIF(MSTP(147).EQ.1) THEN
32774 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32775 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32776 ELSEIF(MSTP(147).EQ.3) THEN
32777 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32778 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32779 ELSEIF(MSTP(147).EQ.4) THEN
32780 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32781 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32782 ELSEIF(MSTP(147).EQ.5) THEN
32783 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32784 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32785 ELSEIF(MSTP(147).EQ.6) THEN
32786 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32787 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32788 ENDIF
32789 FACQQG=COMFAC*FF*FACQQG
32790 ENDIF
32791 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32792 NCHN=NCHN+1
32793 ISIG(NCHN,1)=21
32794 ISIG(NCHN,2)=21
32795 ISIG(NCHN,3)=1
32796 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32797 ENDIF
32798
32799 ELSEIF(ISUB.EQ.433) THEN
32800C...g + g -> QQ~[3P21] + g
32801 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32802 QGTW=(SH*TH*UH)/SH**3
32803 RGTW=SQMQQ/SH
32804 IF(MSTP(145).EQ.0) THEN
32805 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32806 & (12D0*RGTW**2*PGTW**4*
32807 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32808 & -3D0*RGTW*PGTW**3*QGTW*
32809 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
32810 & +2D0*PGTW**2*QGTW**2*
32811 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
32812 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
32813 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32814 ELSE
32815 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
32816 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
32817 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
32818 & *SH*SH2**7
32819 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
32820 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
32821 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
32822 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
32823 & +10D0*(SH2**2+TH2**2))
32824 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
32825 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
32826 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
32827 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
32828 & +4D0*SH*TH*UH2**4*SHTH2)
32829 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
32830 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
32831 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
32832 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
32833 & +10D0*(SH2**2+UH2**2))
32834 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
32835 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
32836 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
32837 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
32838 & +4D0*SH*UH*TH2**4*UHSH2)
32839 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
32840 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
32841 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
32842 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
32843 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
32844 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
32845 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
32846 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
32847 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
32848 & +3D0*(TH2**3+UH2**3)))
32849 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
32850 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
32851 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
32852 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
32853 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
32854 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
32855 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
32856 & 82D0*TH**3)
32857 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
32858 & +45D0*TH**3)
32859 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
32860 & 8D0*TH**3)
32861 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
32862 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
32863 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
32864 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
32865 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
32866 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
32867 & 82D0*UH**3)
32868 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
32869 & +45D0*UH**3)
32870 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
32871 & 8D0*UH**3)
32872 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
32873 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
32874 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
32875 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
32876 & +4D0*SH*TH2**2*UH2**2*THUH2
32877 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
32878 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
32879 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
32880 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
32881 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32882 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
32883 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
32884 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
32885 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
32886 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
32887 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
32888 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
32889 & +2D0*(TH2**3+UH2**3))
32890 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
32891 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
32892 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
32893 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32894 IF(MSTP(147).EQ.0) THEN
32895 FACQQG=1D0/3D0*(C1*3D0
32896 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32897 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32898 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32899 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32900 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32901 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32902 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32903 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32904 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32905 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32906 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32907 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32908 ELSEIF(MSTP(147).EQ.1) THEN
32909 FACQQG=C1*2D0
32910 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32911 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32912 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32913 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32914 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32915 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32916 & +EL1K10*EL2K20*EL1K11*EL2K11)
32917 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32918 & +EL1K10*EL2K20*EL1K21*EL2K21)
32919 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32920 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32921 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32922 & +EL1K20*EL2K20*EL1K11*EL2K11)
32923 ELSEIF(MSTP(147).EQ.2) THEN
32924 FACQQG=2D0*(C1
32925 & -C2*EL1K11*EL2K11
32926 & -C3*EL1K21*EL2K21
32927 & -C4*EL1K11*EL2K21
32928 & +C5*(EL1K11*EL2K11)**2
32929 & +C6*(EL1K21*EL2K21)**2
32930 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32931 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32932 & +(C9+C0)*(EL1K11*EL2K21)**2)
32933 ENDIF
32934 FACQQG=COMFAC*FF*FACQQG
32935 ENDIF
32936 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32937 NCHN=NCHN+1
32938 ISIG(NCHN,1)=21
32939 ISIG(NCHN,2)=21
32940 ISIG(NCHN,3)=1
32941 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32942 ENDIF
32943
32944 ELSEIF(ISUB.EQ.434) THEN
32945C...q + g -> q + QQ~[3P01]
32946 IF(MSTP(145).EQ.0) THEN
32947 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
32948 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32949 ELSE
32950 FA=-PARU(1)*AS**3*(16D0/243D0)*
32951 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32952 IF(MSTP(147).EQ.0) THEN
32953 FACQQG=COMFAC*FA
32954 ELSEIF(MSTP(147).EQ.1) THEN
32955 FACQQG=COMFAC*2D0*FA
32956 ELSEIF(MSTP(147).EQ.3) THEN
32957 FACQQG=COMFAC*FA
32958 ELSEIF(MSTP(147).EQ.4) THEN
32959 FACQQG=COMFAC*FA
32960 ELSEIF(MSTP(147).EQ.5) THEN
32961 FACQQG=0D0
32962 ELSEIF(MSTP(147).EQ.6) THEN
32963 FACQQG=0D0
32964 ENDIF
32965 ENDIF
32966 DO 2452 I=MMINA,MMAXA
32967 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
32968 DO 2451 ISDE=1,2
32969 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
32970 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
32971 NCHN=NCHN+1
32972 ISIG(NCHN,ISDE)=I
32973 ISIG(NCHN,3-ISDE)=21
32974 ISIG(NCHN,3)=1
32975 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32976 2451 CONTINUE
32977 2452 CONTINUE
32978
32979 ELSEIF(ISUB.EQ.435) THEN
32980C...q + g -> q + QQ~[3P11]
32981 IF(MSTP(145).EQ.0) THEN
32982 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
32983 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
32984 ELSE
32985 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
32986 C1=SH*UH
32987 C2=2D0*SH
32988 C3=0D0
32989 C4=2D0*(SH-UH)
32990 IF(MSTP(147).EQ.0) THEN
32991 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32992 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32993 ELSEIF(MSTP(147).EQ.1) THEN
32994 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32995 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32996 ELSEIF(MSTP(147).EQ.3) THEN
32997 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32998 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32999 ELSEIF(MSTP(147).EQ.4) THEN
33000 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
33001 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
33002 ELSEIF(MSTP(147).EQ.5) THEN
33003 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
33004 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
33005 ELSEIF(MSTP(147).EQ.6) THEN
33006 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
33007 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
33008 ENDIF
33009 FACQQG=COMFAC*FF*FACQQG
33010 ENDIF
33011 DO 2454 I=MMINA,MMAXA
33012 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
33013 DO 2453 ISDE=1,2
33014 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
33015 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
33016 NCHN=NCHN+1
33017 ISIG(NCHN,ISDE)=I
33018 ISIG(NCHN,3-ISDE)=21
33019 ISIG(NCHN,3)=1
33020 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33021 2453 CONTINUE
33022 2454 CONTINUE
33023
33024 ELSEIF(ISUB.EQ.436) THEN
33025C...q + g -> q + QQ~[3P21]
33026 IF(MSTP(145).EQ.0) THEN
33027 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
33028 & ((6D0*SQMQQ**2+TH2)*UHSH2
33029 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
33030 & (SQMQQR*TH*UHSH2**2)
33031 ELSE
33032 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
33033 C1=TH*UHSH2
33034 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
33035 C3=4D0*UHSH2
33036 C4=8D0*SH*UHSH
33037 C5=8D0*TH
33038 C6=0D0
33039 C7=16D0*TH
33040 C8=0D0
33041 C9=-16D0*UHSH
33042 C0=16D0*SQMQQ
33043 IF(MSTP(147).EQ.0) THEN
33044 FACQQG=1D0/3D0*(C1*3D0
33045 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
33046 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
33047 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
33048 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
33049 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
33050 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33051 & *(EL1K10*EL2K20-EL1K11*EL2K21)
33052 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
33053 & *(EL1K10*EL2K20-EL1K11*EL2K21)
33054 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33055 & *(EL1K20*EL2K20-EL1K21*EL2K21)
33056 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
33057 ELSEIF(MSTP(147).EQ.1) THEN
33058 FACQQG=C1*2D0
33059 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
33060 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
33061 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
33062 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
33063 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
33064 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
33065 & +EL1K10*EL2K20*EL1K11*EL2K11)
33066 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
33067 & +EL1K10*EL2K20*EL1K21*EL2K21)
33068 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
33069 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
33070 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
33071 & +EL1K20*EL2K20*EL1K11*EL2K11)
33072 ELSEIF(MSTP(147).EQ.2) THEN
33073 FACQQG=2D0*(C1
33074 & -C2*EL1K11*EL2K11
33075 & -C3*EL1K21*EL2K21
33076 & -C4*EL1K11*EL2K21
33077 & +C5*(EL1K11*EL2K11)**2
33078 & +C6*(EL1K21*EL2K21)**2
33079 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
33080 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
33081 & +(C9+C0)*(EL1K11*EL2K21)**2)
33082 ENDIF
33083 FACQQG=COMFAC*FF*FACQQG
33084 ENDIF
33085 DO 2456 I=MMINA,MMAXA
33086 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
33087 DO 2455 ISDE=1,2
33088 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
33089 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
33090 NCHN=NCHN+1
33091 ISIG(NCHN,ISDE)=I
33092 ISIG(NCHN,3-ISDE)=21
33093 ISIG(NCHN,3)=1
33094 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33095 2455 CONTINUE
33096 2456 CONTINUE
33097
33098 ELSEIF(ISUB.EQ.437) THEN
33099C...q + q~ -> g + QQ~[3P01]
33100 IF(MSTP(145).EQ.0) THEN
33101 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
33102 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
33103 ELSE
33104 FA=PARU(1)*AS**3*(128D0/729D0)*
33105 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
33106 IF(MSTP(147).EQ.0) THEN
33107 FACQQG=COMFAC*FA
33108 ELSEIF(MSTP(147).EQ.1) THEN
33109 FACQQG=COMFAC*2D0*FA
33110 ELSEIF(MSTP(147).EQ.3) THEN
33111 FACQQG=COMFAC*FA
33112 ELSEIF(MSTP(147).EQ.4) THEN
33113 FACQQG=COMFAC*FA
33114 ELSEIF(MSTP(147).EQ.5) THEN
33115 FACQQG=0D0
33116 ELSEIF(MSTP(147).EQ.6) THEN
33117 FACQQG=0D0
33118 ENDIF
33119 ENDIF
33120 DO 2457 I=MMINA,MMAXA
33121 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33122 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
33123 NCHN=NCHN+1
33124 ISIG(NCHN,1)=I
33125 ISIG(NCHN,2)=-I
33126 ISIG(NCHN,3)=1
33127 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33128 2457 CONTINUE
33129
33130 ELSEIF(ISUB.EQ.438) THEN
33131C...q + q~ -> g + QQ~[3P11]
33132 IF(MSTP(145).EQ.0) THEN
33133 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
33134 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
33135 ELSE
33136 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
33137 C1=TH*UH
33138 C2=2D0*UH
33139 C3=2D0*TH
33140 C4=2D0*THUH
33141 IF(MSTP(147).EQ.0) THEN
33142 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
33143 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
33144 ELSEIF(MSTP(147).EQ.1) THEN
33145 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
33146 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
33147 ELSEIF(MSTP(147).EQ.3) THEN
33148 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
33149 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
33150 ELSEIF(MSTP(147).EQ.4) THEN
33151 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
33152 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
33153 ELSEIF(MSTP(147).EQ.5) THEN
33154 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
33155 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
33156 ELSEIF(MSTP(147).EQ.6) THEN
33157 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
33158 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
33159 ENDIF
33160 FACQQG=COMFAC*FF*FACQQG
33161 ENDIF
33162 DO 2458 I=MMINA,MMAXA
33163 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33164 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
33165 NCHN=NCHN+1
33166 ISIG(NCHN,1)=I
33167 ISIG(NCHN,2)=-I
33168 ISIG(NCHN,3)=1
33169 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33170 2458 CONTINUE
33171
33172 ELSEIF(ISUB.EQ.439) THEN
33173C...q + q~ -> g + QQ~[3P21]
33174 IF(MSTP(145).EQ.0) THEN
33175 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
33176 & ((6D0*SQMQQ**2+SH2)*THUH2
33177 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
33178 & (SQMQQR*SH*THUH2**2)
33179 ELSE
33180 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
33181 C1=SH*THUH2
33182 C2=4D0*(SH2+UH2+2D0*SH*THUH)
33183 C3=4D0*(SH2+TH2+2D0*SH*THUH)
33184 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
33185 C5=8D0*SH
33186 C6=C5
33187 C7=16D0*SH
33188 C8=C7
33189 C9=-16D0*THUH
33190 C0=16D0*SQMQQ
33191 IF(MSTP(147).EQ.0) THEN
33192 FACQQG=1D0/3D0*(C1*3D0
33193 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
33194 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
33195 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
33196 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
33197 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
33198 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33199 & *(EL1K10*EL2K20-EL1K11*EL2K21)
33200 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
33201 & *(EL1K10*EL2K20-EL1K11*EL2K21)
33202 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33203 & *(EL1K20*EL2K20-EL1K21*EL2K21)
33204 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
33205 ELSEIF(MSTP(147).EQ.1) THEN
33206 FACQQG=C1*2D0
33207 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
33208 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
33209 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
33210 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
33211 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
33212 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
33213 & +EL1K10*EL2K20*EL1K11*EL2K11)
33214 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
33215 & +EL1K10*EL2K20*EL1K21*EL2K21)
33216 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
33217 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
33218 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
33219 & +EL1K20*EL2K20*EL1K11*EL2K11)
33220 ELSEIF(MSTP(147).EQ.2) THEN
33221 FACQQG=2D0*(C1
33222 & -C2*EL1K11*EL2K11
33223 & -C3*EL1K21*EL2K21
33224 & -C4*EL1K11*EL2K21
33225 & +C5*(EL1K11*EL2K11)**2
33226 & +C6*(EL1K21*EL2K21)**2
33227 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
33228 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
33229 & +(C9+C0)*(EL1K11*EL2K21)**2)
33230 ENDIF
33231 FACQQG=COMFAC*FF*FACQQG
33232 ENDIF
33233 DO 2459 I=MMINA,MMAXA
33234 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33235 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
33236 NCHN=NCHN+1
33237 ISIG(NCHN,1)=I
33238 ISIG(NCHN,2)=-I
33239 ISIG(NCHN,3)=1
33240 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33241 2459 CONTINUE
33242 ENDIF
33243C...QUARKONIA---
33244
33245 ENDIF
33246
33247 RETURN
33248 END
33249
33250C*********************************************************************
33251
33252C...PYSGWZ
33253C...Subprocess cross sections for W/Z processes,
33254C...except that longitudinal WW scattering is in Higgs sector.
33255C...Auxiliary to PYSIGH.
33256
33257 SUBROUTINE PYSGWZ(NCHN,SIGS)
33258
33259C...Double precision and integer declarations
33260 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33261 IMPLICIT INTEGER(I-N)
33262 INTEGER PYK,PYCHGE,PYCOMP
33263C...Parameter statement to help give large particle numbers.
33264 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33265 &KEXCIT=4000000,KDIMEN=5000000)
33266C...Commonblocks
33267 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33268 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33269 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
33270 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
33271 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33272 COMMON/PYINT1/MINT(400),VINT(400)
33273 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33274 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33275 COMMON/PYINT4/MWID(500),WIDS(500,5)
33276 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
33277 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33278 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33279 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33280 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33281 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
33282 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
33283C...Local arrays and complex numbers
33284 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
33285 &HL4(3),HR4(3)
33286 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
33287
33288C...Differential cross section expressions.
33289
33290 IF(ISUB.LE.20) THEN
33291 IF(ISUB.EQ.1) THEN
33292C...f + fbar -> gamma*/Z0
33293 MINT(61)=2
33294 CALL PYWIDT(23,SH,WDTP,WDTE)
33295 HS=SHR*WDTP(0)
33296 FACZ=4D0*COMFAC*3D0
33297 HP0=AEM/3D0*SH
33298 HP1=AEM/3D0*XWC*SH
33299 DO 100 I=MMINA,MMAXA
33300 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
33301 EI=KCHG(IABS(I),1)/3D0
33302 AI=SIGN(1D0,EI)
33303 VI=AI-4D0*EI*XWV
33304 HI0=HP0
33305 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
33306 HI1=HP1
33307 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
33308 NCHN=NCHN+1
33309 ISIG(NCHN,1)=I
33310 ISIG(NCHN,2)=-I
33311 ISIG(NCHN,3)=1
33312 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
33313 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
33314 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
33315 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
33316 100 CONTINUE
33317
33318 ELSEIF(ISUB.EQ.2) THEN
33319C...f + fbar' -> W+/-
33320 CALL PYWIDT(24,SH,WDTP,WDTE)
33321 HS=SHR*WDTP(0)
33322 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
33323 HP=AEM/(24D0*XW)*SH
33324 DO 120 I=MMIN1,MMAX1
33325 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
33326 IA=IABS(I)
33327 DO 110 J=MMIN2,MMAX2
33328 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
33329 JA=IABS(J)
33330 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
33331 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33332 & GOTO 110
33333 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33334 HI=HP*2D0
33335 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
33336 NCHN=NCHN+1
33337 ISIG(NCHN,1)=I
33338 ISIG(NCHN,2)=J
33339 ISIG(NCHN,3)=1
33340 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
33341 SIGH(NCHN)=HI*FACBW*HF
33342 110 CONTINUE
33343 120 CONTINUE
33344
33345 ELSEIF(ISUB.EQ.15) THEN
33346C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
33347 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33348C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33349 HFGG=0D0
33350 HFGZ=0D0
33351 HFZZ=0D0
33352 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33353 DO 130 I=1,MIN(16,MDCY(23,3))
33354 IDC=I+MDCY(23,2)-1
33355 IF(MDME(IDC,1).LT.0) GOTO 130
33356 IMDM=0
33357 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33358 & IMDM=1
33359 IF(I.LE.8) THEN
33360 EF=KCHG(I,1)/3D0
33361 AF=SIGN(1D0,EF+0.1D0)
33362 VF=AF-4D0*EF*XWV
33363 ELSEIF(I.LE.16) THEN
33364 EF=KCHG(I+2,1)/3D0
33365 AF=SIGN(1D0,EF+0.1D0)
33366 VF=AF-4D0*EF*XWV
33367 ENDIF
33368 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33369 IF(4D0*RM1.LT.1D0) THEN
33370 FCOF=1D0
33371 IF(I.LE.8) FCOF=3D0*RADC4
33372 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33373 IF(IMDM.EQ.1) THEN
33374 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33375 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33376 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33377 & AF**2*(1D0-4D0*RM1))*BE34
33378 ENDIF
33379 ENDIF
33380 130 CONTINUE
33381C...Propagators: as simulated in PYOFSH and as desired
33382 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33383 MINT15=MINT(15)
33384 MINT(15)=1
33385 MINT(61)=1
33386 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33387 MINT(15)=MINT15
33388 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33389 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33390 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33391 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33392C...Loop over flavours; consider full gamma/Z structure
33393 DO 140 I=MMINA,MMAXA
33394 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33395 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
33396 EI=KCHG(IABS(I),1)/3D0
33397 AI=SIGN(1D0,EI)
33398 VI=AI-4D0*EI*XWV
33399 NCHN=NCHN+1
33400 ISIG(NCHN,1)=I
33401 ISIG(NCHN,2)=-I
33402 ISIG(NCHN,3)=1
33403 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
33404 & (VI**2+AI**2)*HFZZ)/HBW4
33405 140 CONTINUE
33406
33407 ELSEIF(ISUB.EQ.16) THEN
33408C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
33409 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33410C...Propagators: as simulated in PYOFSH and as desired
33411 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33412 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33413 GMMWC=SQRT(SQM4)*WDTP(0)
33414 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33415 FACWG=FACWG*HBW4C/HBW4
33416 DO 160 I=MMIN1,MMAX1
33417 IA=IABS(I)
33418 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
33419 DO 150 J=MMIN2,MMAX2
33420 JA=IABS(J)
33421 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
33422 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
33423 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33424 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33425 FCKM=VCKM((IA+1)/2,(JA+1)/2)
33426 NCHN=NCHN+1
33427 ISIG(NCHN,1)=I
33428 ISIG(NCHN,2)=J
33429 ISIG(NCHN,3)=1
33430 SIGH(NCHN)=FACWG*FCKM*WIDSC
33431 150 CONTINUE
33432 160 CONTINUE
33433
33434 ELSEIF(ISUB.EQ.19) THEN
33435C...f + fbar -> gamma + (gamma*/Z0)
33436 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33437C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33438 HFGG=0D0
33439 HFGZ=0D0
33440 HFZZ=0D0
33441 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33442 DO 170 I=1,MIN(16,MDCY(23,3))
33443 IDC=I+MDCY(23,2)-1
33444 IF(MDME(IDC,1).LT.0) GOTO 170
33445 IMDM=0
33446 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33447 & IMDM=1
33448 IF(I.LE.8) THEN
33449 EF=KCHG(I,1)/3D0
33450 AF=SIGN(1D0,EF+0.1D0)
33451 VF=AF-4D0*EF*XWV
33452 ELSEIF(I.LE.16) THEN
33453 EF=KCHG(I+2,1)/3D0
33454 AF=SIGN(1D0,EF+0.1D0)
33455 VF=AF-4D0*EF*XWV
33456 ENDIF
33457 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33458 IF(4D0*RM1.LT.1D0) THEN
33459 FCOF=1D0
33460 IF(I.LE.8) FCOF=3D0*RADC4
33461 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33462 IF(IMDM.EQ.1) THEN
33463 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33464 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33465 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33466 & AF**2*(1D0-4D0*RM1))*BE34
33467 ENDIF
33468 ENDIF
33469 170 CONTINUE
33470C...Propagators: as simulated in PYOFSH and as desired
33471 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33472 MINT15=MINT(15)
33473 MINT(15)=1
33474 MINT(61)=1
33475 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33476 MINT(15)=MINT15
33477 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33478 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33479 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33480 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33481C...Loop over flavours; consider full gamma/Z structure
33482 DO 180 I=MMINA,MMAXA
33483 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
33484 EI=KCHG(IABS(I),1)/3D0
33485 AI=SIGN(1D0,EI)
33486 VI=AI-4D0*EI*XWV
33487 FCOI=1D0
33488 IF(IABS(I).LE.10) FCOI=FACA/3D0
33489 NCHN=NCHN+1
33490 ISIG(NCHN,1)=I
33491 ISIG(NCHN,2)=-I
33492 ISIG(NCHN,3)=1
33493 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
33494 & (VI**2+AI**2)*HFZZ)/HBW4
33495 180 CONTINUE
33496
33497 ELSEIF(ISUB.EQ.20) THEN
33498C...f + fbar' -> gamma + W+/-
33499 FACGW=COMFAC*0.5D0*AEM**2/XW
33500C...Propagators: as simulated in PYOFSH and as desired
33501 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33502 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33503 GMMWC=SQRT(SQM4)*WDTP(0)
33504 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33505 FACGW=FACGW*HBW4C/HBW4
33506C...Anomalous couplings
33507 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33508 TERM2=0D0
33509 TERM3=0D0
33510 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
33511 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
33512 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
33513 & (4D0*SQMW))/(TH+UH)**2
33514 ENDIF
33515 DO 200 I=MMIN1,MMAX1
33516 IA=IABS(I)
33517 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
33518 DO 190 J=MMIN2,MMAX2
33519 JA=IABS(J)
33520 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
33521 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
33522 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33523 & GOTO 190
33524 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33525 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33526 IF(IA.LE.10) THEN
33527 FACWR=UH/(TH+UH)-1D0/3D0
33528 FCKM=VCKM((IA+1)/2,(JA+1)/2)
33529 FCOI=FACA/3D0
33530 ELSE
33531 FACWR=-TH/(TH+UH)
33532 FCKM=1D0
33533 FCOI=1D0
33534 ENDIF
33535 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
33536 NCHN=NCHN+1
33537 ISIG(NCHN,1)=I
33538 ISIG(NCHN,2)=J
33539 ISIG(NCHN,3)=1
33540 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
33541 190 CONTINUE
33542 200 CONTINUE
33543 ENDIF
33544
33545 ELSEIF(ISUB.LE.40) THEN
33546 IF(ISUB.EQ.22) THEN
33547C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
33548C...Kinematics dependence
33549 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
33550 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
33551C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33552 DO 220 I=1,6
33553 DO 210 J=1,3
33554 HGZ(I,J)=0D0
33555 210 CONTINUE
33556 220 CONTINUE
33557 RADC3=1D0+PYALPS(SQM3)/PARU(1)
33558 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33559 DO 230 I=1,MIN(16,MDCY(23,3))
33560 IDC=I+MDCY(23,2)-1
33561 IF(MDME(IDC,1).LT.0) GOTO 230
33562 IMDM=0
33563 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
33564 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
33565 IF(I.LE.8) THEN
33566 EF=KCHG(I,1)/3D0
33567 AF=SIGN(1D0,EF+0.1D0)
33568 VF=AF-4D0*EF*XWV
33569 ELSEIF(I.LE.16) THEN
33570 EF=KCHG(I+2,1)/3D0
33571 AF=SIGN(1D0,EF+0.1D0)
33572 VF=AF-4D0*EF*XWV
33573 ENDIF
33574 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
33575 IF(4D0*RM1.LT.1D0) THEN
33576 FCOF=1D0
33577 IF(I.LE.8) FCOF=3D0*RADC3
33578 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33579 IF(IMDM.GE.1) THEN
33580 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33581 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33582 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
33583 & AF**2*(1D0-4D0*RM1))*BE34
33584 ENDIF
33585 ENDIF
33586 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33587 IF(4D0*RM1.LT.1D0) THEN
33588 FCOF=1D0
33589 IF(I.LE.8) FCOF=3D0*RADC4
33590 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33591 IF(IMDM.GE.1) THEN
33592 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33593 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33594 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
33595 & AF**2*(1D0-4D0*RM1))*BE34
33596 ENDIF
33597 ENDIF
33598 230 CONTINUE
33599C...Propagators: as simulated in PYOFSH and as desired
33600 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
33601 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33602 MINT15=MINT(15)
33603 MINT(15)=1
33604 MINT(61)=1
33605 CALL PYWIDT(23,SQM3,WDTP,WDTE)
33606 MINT(15)=MINT15
33607 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33608 DO 240 J=1,3
33609 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
33610 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
33611 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
33612 240 CONTINUE
33613 MINT15=MINT(15)
33614 MINT(15)=1
33615 MINT(61)=1
33616 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33617 MINT(15)=MINT15
33618 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33619 DO 250 J=1,3
33620 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
33621 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
33622 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
33623 250 CONTINUE
33624C...Loop over flavours; separate left- and right-handed couplings
33625 DO 270 I=MMINA,MMAXA
33626 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
33627 EI=KCHG(IABS(I),1)/3D0
33628 AI=SIGN(1D0,EI)
33629 VI=AI-4D0*EI*XWV
33630 VALI=VI-AI
33631 VARI=VI+AI
33632 FCOI=1D0
33633 IF(IABS(I).LE.10) FCOI=FACA/3D0
33634 DO 260 J=1,3
33635 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
33636 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
33637 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
33638 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
33639 260 CONTINUE
33640 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
33641 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
33642 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
33643 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
33644 NCHN=NCHN+1
33645 ISIG(NCHN,1)=I
33646 ISIG(NCHN,2)=-I
33647 ISIG(NCHN,3)=1
33648 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
33649 270 CONTINUE
33650
33651 ELSEIF(ISUB.EQ.23) THEN
33652C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
33653 FACZW=COMFAC*0.5D0*(AEM/XW)**2
33654 FACZW=FACZW*WIDS(23,2)
33655 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33656 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
33657 DO 290 I=MMIN1,MMAX1
33658 IA=IABS(I)
33659 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
33660 DO 280 J=MMIN2,MMAX2
33661 JA=IABS(J)
33662 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
33663 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
33664 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33665 & GOTO 280
33666 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33667 EI=KCHG(IA,1)/3D0
33668 AI=SIGN(1D0,EI+0.1D0)
33669 VI=AI-4D0*EI*XWV
33670 EJ=KCHG(JA,1)/3D0
33671 AJ=SIGN(1D0,EJ+0.1D0)
33672 VJ=AJ-4D0*EJ*XWV
33673 IF(VI+AI.GT.0) THEN
33674 VISAV=VI
33675 AISAV=AI
33676 VI=VJ
33677 AI=AJ
33678 VJ=VISAV
33679 AJ=AISAV
33680 ENDIF
33681 FCKM=1D0
33682 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33683 FCOI=1D0
33684 IF(IA.LE.10) FCOI=FACA/3D0
33685 NCHN=NCHN+1
33686 ISIG(NCHN,1)=I
33687 ISIG(NCHN,2)=J
33688 ISIG(NCHN,3)=1
33689 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
33690 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
33691 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
33692 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
33693 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
33694 & WIDS(24,(5-KCHW)/2)
33695C***Protect against slightly negative cross sections. (Reason yet to be
33696C***sorted out. One possibility: addition of width to the W propagator.)
33697 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
33698 280 CONTINUE
33699 290 CONTINUE
33700
33701 ELSEIF(ISUB.EQ.25) THEN
33702C...f + fbar -> W+ + W-
33703C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
33704 GMMZC=GMMZ
33705 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
33706 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33707 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33708 GMMW3=SQRT(SQM3)*WDTP(0)
33709 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33710 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33711 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33712 GMMW4=SQRT(SQM4)*WDTP(0)
33713 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
33714C...Kinematical functions
33715 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33716 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
33717 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
33718 GT=THUH34+4D0*THUH/TH2
33719 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
33720 GU=THUH34+4D0*THUH/UH2
33721 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
33722C...Common factors and couplings
33723 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
33724 FACWW=FACWW*WIDS(24,1)
33725 CGG=AEM**2/2D0
33726 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
33727 CZZ=AEM**2/(32D0*XW**2)*HBWZC
33728 CNG=AEM**2/(4D0*XW)
33729 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
33730 CNN=AEM**2/(16D0*XW**2)
33731C...Coulomb factor for W+W- pair
33732 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
33733 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
33734 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
33735 IF(COULE.LT.100D0*PMAS(24,2)) THEN
33736 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33737 & PMAS(24,2)**2)-COULE))
33738 ELSE
33739 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
33740 ENDIF
33741 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
33742 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33743 & PMAS(24,2)**2)+COULE))
33744 ELSE
33745 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
33746 & ABS(COULE)))
33747 ENDIF
33748 IF(MSTP(40).EQ.1) THEN
33749 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
33750 & MAX(1D-10,2D0*COULP*COULP1))
33751 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33752 ELSEIF(MSTP(40).EQ.2) THEN
33753 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
33754 COULCP=DCMPLX(0D0,DBLE(COULP))
33755 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
33756 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
33757 & (4D0*COULCP)*LOG(COULCD)
33758 COULCS=DCMPLX(0D0,0D0)
33759 NSTP=100
33760 DO 300 ISTP=1,NSTP
33761 COULXX=(ISTP-0.5)/NSTP
33762 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
33763 & (1D0+COULXX/COULCD))
33764 300 CONTINUE
33765 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
33766 & (COULCS/NSTP)
33767 FACCOU=ABS(COULCR)**2
33768 ELSEIF(MSTP(40).EQ.3) THEN
33769 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
33770 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
33771 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33772 ENDIF
33773 ELSEIF(MSTP(40).EQ.4) THEN
33774 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
33775 ELSE
33776 FACCOU=1D0
33777 ENDIF
33778 VINT(95)=FACCOU
33779 FACWW=FACWW*FACCOU
33780C...Loop over allowed flavours
33781 DO 310 I=MMINA,MMAXA
33782 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
33783 EI=KCHG(IABS(I),1)/3D0
33784 AI=SIGN(1D0,EI+0.1D0)
33785 VI=AI-4D0*EI*XWV
33786 FCOI=1D0
33787 IF(IABS(I).LE.10) FCOI=FACA/3D0
33788 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
33789 IF(AI.LT.0D0) THEN
33790 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
33791 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
33792 ELSE
33793 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
33794 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
33795 ENDIF
33796 ELSE
33797 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
33798 BET=SQRT(1D0-4D0*XMW02/SH)
33799 GAT=1D0/SQRT(1D0-BET**2)
33800 STHE2=1D0-CTH**2
33801 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
33802 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
33803 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
33804 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
33805 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
33806 & (1D0-2D0*BET*CTH+BET**2))
33807 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
33808 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
33809 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
33810 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
33811 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
33812 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
33813 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
33814 DSIGWW=ATOT
33815 ENDIF
33816 NCHN=NCHN+1
33817 ISIG(NCHN,1)=I
33818 ISIG(NCHN,2)=-I
33819 ISIG(NCHN,3)=1
33820 SIGH(NCHN)=FACWW*FCOI*DSIGWW
33821 310 CONTINUE
33822
33823 ELSEIF(ISUB.EQ.30) THEN
33824C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
33825 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
33826 & (-SH*UH)
33827C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33828 HFGG=0D0
33829 HFGZ=0D0
33830 HFZZ=0D0
33831 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33832 DO 320 I=1,MIN(16,MDCY(23,3))
33833 IDC=I+MDCY(23,2)-1
33834 IF(MDME(IDC,1).LT.0) GOTO 320
33835 IMDM=0
33836 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33837 & IMDM=1
33838 IF(I.LE.8) THEN
33839 EF=KCHG(I,1)/3D0
33840 AF=SIGN(1D0,EF+0.1D0)
33841 VF=AF-4D0*EF*XWV
33842 ELSEIF(I.LE.16) THEN
33843 EF=KCHG(I+2,1)/3D0
33844 AF=SIGN(1D0,EF+0.1D0)
33845 VF=AF-4D0*EF*XWV
33846 ENDIF
33847 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33848 IF(4D0*RM1.LT.1D0) THEN
33849 FCOF=1D0
33850 IF(I.LE.8) FCOF=3D0*RADC4
33851 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33852 IF(IMDM.EQ.1) THEN
33853 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33854 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33855 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33856 & AF**2*(1D0-4D0*RM1))*BE34
33857 ENDIF
33858 ENDIF
33859 320 CONTINUE
33860C...Propagators: as simulated in PYOFSH and as desired
33861 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33862 MINT15=MINT(15)
33863 MINT(15)=1
33864 MINT(61)=1
33865 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33866 MINT(15)=MINT15
33867 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33868 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33869 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33870 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33871C...Loop over flavours; consider full gamma/Z structure
33872 DO 340 I=MMINA,MMAXA
33873 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
33874 EI=KCHG(IABS(I),1)/3D0
33875 AI=SIGN(1D0,EI)
33876 VI=AI-4D0*EI*XWV
33877 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
33878 & (VI**2+AI**2)*HFZZ)/HBW4
33879 DO 330 ISDE=1,2
33880 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
33881 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
33882 NCHN=NCHN+1
33883 ISIG(NCHN,ISDE)=I
33884 ISIG(NCHN,3-ISDE)=21
33885 ISIG(NCHN,3)=1
33886 SIGH(NCHN)=FACZQ
33887 330 CONTINUE
33888 340 CONTINUE
33889
33890 ELSEIF(ISUB.EQ.31) THEN
33891C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
33892 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
33893 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
33894C...Propagators: as simulated in PYOFSH and as desired
33895 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33896 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33897 GMMWC=SQRT(SQM4)*WDTP(0)
33898 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33899 FACWQ=FACWQ*HBW4C/HBW4
33900 DO 360 I=MMINA,MMAXA
33901 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
33902 IA=IABS(I)
33903 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33904 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33905 DO 350 ISDE=1,2
33906 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
33907 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
33908 NCHN=NCHN+1
33909 ISIG(NCHN,ISDE)=I
33910 ISIG(NCHN,3-ISDE)=21
33911 ISIG(NCHN,3)=1
33912 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33913 350 CONTINUE
33914 360 CONTINUE
33915
33916 ELSEIF(ISUB.EQ.35) THEN
33917C...f + gamma -> f + (gamma*/Z0)
33918 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
33919 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
33920 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
33921 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
33922 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
33923 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
33924 ELSE
33925 FZQN=SH2+UH2+2D0*SQM4*TH
33926 FZQDTM=-SH*UH
33927 ENDIF
33928 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
33929C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33930 HFGG=0D0
33931 HFGZ=0D0
33932 HFZZ=0D0
33933 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33934 DO 370 I=1,MIN(16,MDCY(23,3))
33935 IDC=I+MDCY(23,2)-1
33936 IF(MDME(IDC,1).LT.0) GOTO 370
33937 IMDM=0
33938 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33939 & IMDM=1
33940 IF(I.LE.8) THEN
33941 EF=KCHG(I,1)/3D0
33942 AF=SIGN(1D0,EF+0.1D0)
33943 VF=AF-4D0*EF*XWV
33944 ELSEIF(I.LE.16) THEN
33945 EF=KCHG(I+2,1)/3D0
33946 AF=SIGN(1D0,EF+0.1D0)
33947 VF=AF-4D0*EF*XWV
33948 ENDIF
33949 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33950 IF(4D0*RM1.LT.1D0) THEN
33951 FCOF=1D0
33952 IF(I.LE.8) FCOF=3D0*RADC4
33953 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33954 IF(IMDM.EQ.1) THEN
33955 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33956 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33957 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33958 & AF**2*(1D0-4D0*RM1))*BE34
33959 ENDIF
33960 ENDIF
33961 370 CONTINUE
33962C...Propagators: as simulated in PYOFSH and as desired
33963 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33964 MINT15=MINT(15)
33965 MINT(15)=1
33966 MINT(61)=1
33967 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33968 MINT(15)=MINT15
33969 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33970 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33971 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33972 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33973C...Loop over flavours; consider full gamma/Z structure
33974 DO 390 I=MMINA,MMAXA
33975 IF(I.EQ.0) GOTO 390
33976 EI=KCHG(IABS(I),1)/3D0
33977 AI=SIGN(1D0,EI)
33978 VI=AI-4D0*EI*XWV
33979 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
33980 & (VI**2+AI**2)*HFZZ)/HBW4
33981 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
33982 DO 380 ISDE=1,2
33983 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
33984 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
33985 NCHN=NCHN+1
33986 ISIG(NCHN,ISDE)=I
33987 ISIG(NCHN,3-ISDE)=22
33988 ISIG(NCHN,3)=1
33989 SIGH(NCHN)=FACZQ*FZQN/FZQD
33990 380 CONTINUE
33991 390 CONTINUE
33992
33993 ELSEIF(ISUB.EQ.36) THEN
33994C...f + gamma -> f' + W+/-
33995 FWQ=COMFAC*AEM**2/(2D0*XW)*
33996 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
33997C...Propagators: as simulated in PYOFSH and as desired
33998 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33999 CALL PYWIDT(24,SQM4,WDTP,WDTE)
34000 GMMWC=SQRT(SQM4)*WDTP(0)
34001 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
34002 FWQ=FWQ*HBW4C/HBW4
34003 DO 410 I=MMINA,MMAXA
34004 IF(I.EQ.0) GOTO 410
34005 IA=IABS(I)
34006 EIA=ABS(KCHG(IABS(I),1)/3D0)
34007 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
34008 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
34009 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
34010 DO 400 ISDE=1,2
34011 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
34012 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
34013 NCHN=NCHN+1
34014 ISIG(NCHN,ISDE)=I
34015 ISIG(NCHN,3-ISDE)=22
34016 ISIG(NCHN,3)=1
34017 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
34018 400 CONTINUE
34019 410 CONTINUE
34020 ENDIF
34021
34022 ELSEIF(ISUB.LE.100) THEN
34023 IF(ISUB.EQ.69) THEN
34024C...gamma + gamma -> W+ + W-
34025 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
34026 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
34027 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
34028 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
34029 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
34030 NCHN=NCHN+1
34031 ISIG(NCHN,1)=22
34032 ISIG(NCHN,2)=22
34033 ISIG(NCHN,3)=1
34034 SIGH(NCHN)=FACWW
34035 420 CONTINUE
34036
34037 ELSEIF(ISUB.EQ.70) THEN
34038C...gamma + W+/- -> Z0 + W+/-
34039 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
34040 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
34041 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
34042 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
34043 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
34044 DO 440 KCHW=1,-1,-2
34045 DO 430 ISDE=1,2
34046 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
34047 NCHN=NCHN+1
34048 ISIG(NCHN,ISDE)=22
34049 ISIG(NCHN,3-ISDE)=24*KCHW
34050 ISIG(NCHN,3)=1
34051 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
34052 430 CONTINUE
34053 440 CONTINUE
34054 ENDIF
34055 ENDIF
34056
34057 RETURN
34058 END
34059
34060C*********************************************************************
34061
34062C...PYSGHG
34063C...Subprocess cross sections for Higgs processes,
34064C...except Higgs pairs in PYSGSU, but including WW scattering.
34065C...Auxiliary to PYSIGH.
34066
34067 SUBROUTINE PYSGHG(NCHN,SIGS)
34068
34069C...Double precision and integer declarations
34070 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34071 IMPLICIT INTEGER(I-N)
34072 INTEGER PYK,PYCHGE,PYCOMP
34073C...Parameter statement to help give large particle numbers.
34074 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34075 &KEXCIT=4000000,KDIMEN=5000000)
34076C...Commonblocks
34077 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34078 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34079 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
34080 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34081 COMMON/PYINT1/MINT(400),VINT(400)
34082 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
34083 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
34084 COMMON/PYINT4/MWID(500),WIDS(500,5)
34085 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
34086 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34087 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
34088 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
34089 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
34090 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
34091 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
34092 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
34093C...Local arrays and complex variables
34094 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
34095 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
34096 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
34097
34098C...Convert H or A process into equivalent h one
34099 IHIGG=1
34100 KFHIGG=25
34101 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
34102 KFHIGG=KFPR(ISUB,1)
34103 END IF
34104 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
34105 &ISUB.LE.190)) THEN
34106 IHIGG=2
34107 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
34108 KFHIGG=33+IHIGG
34109 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
34110 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
34111 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
34112 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
34113 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
34114 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
34115 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
34116 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
34117 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
34118 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
34119 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
34120 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
34121 ENDIF
34122 SQMH=PMAS(KFHIGG,1)**2
34123 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
34124
34125C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34126 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
34127 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
34128C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
34129 IF(MSTP(46).LE.4) THEN
34130 HDTLH=LOG(PMAS(25,1)/PARP(44))
34131 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
34132 HDTNR=-1D0/18D0+HDTLH/6D0
34133 ELSE
34134 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
34135 HDTLQ=LOG(PARP(45)/PARP(44))
34136 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
34137 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
34138 ENDIF
34139
34140C...Calculate lowest and next-to-lowest order partial wave amplitudes
34141 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
34142 A00L=DBLE(HDTV*SH)
34143 A20L=-0.5D0*A00L
34144 A11L=A00L/6D0
34145 HDTLS=LOG(SH/PARP(44)**2)
34146 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
34147 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
34148 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
34149 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
34150 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
34151 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
34152 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
34153 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
34154
34155C...Unitarize partial wave amplitudes with Pade or K-matrix method
34156 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
34157 A00U=A00L/(1D0-A004/A00L)
34158 A20U=A20L/(1D0-A204/A20L)
34159 A11U=A11L/(1D0-A114/A11L)
34160 ELSE
34161 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
34162 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
34163 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
34164 ENDIF
34165 ENDIF
34166
34167C...Differential cross section expressions.
34168
34169 IF(ISUB.LE.60) THEN
34170 IF(ISUB.EQ.3) THEN
34171C...f + fbar -> h0 (or H0, or A0)
34172 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34173 HS=SHR*WDTP(0)
34174 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34175 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34176 & FACBW=0D0
34177 HP=AEM/(8D0*XW)*SH/SQMW*SH
34178 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34179 DO 100 I=MMINA,MMAXA
34180 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
34181 IA=IABS(I)
34182 RMQ=PYMRUN(IA,SH)**2/SH
34183 HI=HP*RMQ
34184 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
34185 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34186 IKFI=1
34187 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34188 IF(IA.GT.10) IKFI=3
34189 HI=HI*PARU(150+10*IHIGG+IKFI)**2
34190 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34191 HI=HI/(1D0+RMSS(41))**2
34192 IF(IHIGG.NE.3) THEN
34193 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34194 & PARU(151+10*IHIGG))**2
34195 ENDIF
34196 ENDIF
34197 ENDIF
34198 NCHN=NCHN+1
34199 ISIG(NCHN,1)=I
34200 ISIG(NCHN,2)=-I
34201 ISIG(NCHN,3)=1
34202 SIGH(NCHN)=HI*FACBW*HF
34203 100 CONTINUE
34204
34205 ELSEIF(ISUB.EQ.5) THEN
34206C...Z0 + Z0 -> h0
34207 CALL PYWIDT(25,SH,WDTP,WDTE)
34208 HS=SHR*WDTP(0)
34209 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34210 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
34211 HP=AEM/(8D0*XW)*SH/SQMW*SH
34212 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34213 HI=HP/4D0
34214 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
34215 DO 120 I=MMIN1,MMAX1
34216 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
34217 DO 110 J=MMIN2,MMAX2
34218 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
34219 EI=KCHG(IABS(I),1)/3D0
34220 AI=SIGN(1D0,EI)
34221 VI=AI-4D0*EI*XWV
34222 EJ=KCHG(IABS(J),1)/3D0
34223 AJ=SIGN(1D0,EJ)
34224 VJ=AJ-4D0*EJ*XWV
34225 NCHN=NCHN+1
34226 ISIG(NCHN,1)=I
34227 ISIG(NCHN,2)=J
34228 ISIG(NCHN,3)=1
34229 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
34230 110 CONTINUE
34231 120 CONTINUE
34232
34233 ELSEIF(ISUB.EQ.8) THEN
34234C...W+ + W- -> h0
34235 CALL PYWIDT(25,SH,WDTP,WDTE)
34236 HS=SHR*WDTP(0)
34237 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34238 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
34239 HP=AEM/(8D0*XW)*SH/SQMW*SH
34240 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34241 HI=HP/2D0
34242 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
34243 DO 140 I=MMIN1,MMAX1
34244 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
34245 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34246 DO 130 J=MMIN2,MMAX2
34247 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
34248 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34249 IF(EI*EJ.GT.0D0) GOTO 130
34250 NCHN=NCHN+1
34251 ISIG(NCHN,1)=I
34252 ISIG(NCHN,2)=J
34253 ISIG(NCHN,3)=1
34254 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
34255 130 CONTINUE
34256 140 CONTINUE
34257
34258 ELSEIF(ISUB.EQ.24) THEN
34259C...f + fbar -> Z0 + h0 (or H0, or A0)
34260C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
34261 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
34262 CALL PYWIDT(23,SQM3,WDTP,WDTE)
34263 GMMZ3=SQRT(SQM3)*WDTP(0)
34264 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
34265 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34266 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34267 GMMH4=SQRT(SQM4)*WDTP(0)
34268 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
34269 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
34270 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
34271 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
34272 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
34273 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
34274 & PARU(154+10*IHIGG)**2
34275 DO 150 I=MMINA,MMAXA
34276 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
34277 EI=KCHG(IABS(I),1)/3D0
34278 AI=SIGN(1D0,EI)
34279 VI=AI-4D0*EI*XWV
34280 FCOI=1D0
34281 IF(IABS(I).LE.10) FCOI=FACA/3D0
34282 NCHN=NCHN+1
34283 ISIG(NCHN,1)=I
34284 ISIG(NCHN,2)=-I
34285 ISIG(NCHN,3)=1
34286 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
34287 150 CONTINUE
34288
34289 ELSEIF(ISUB.EQ.26) THEN
34290C...f + fbar' -> W+/- + h0 (or H0, or A0)
34291C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
34292 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
34293 CALL PYWIDT(24,SQM3,WDTP,WDTE)
34294 GMMW3=SQRT(SQM3)*WDTP(0)
34295 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
34296 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34297 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34298 GMMH4=SQRT(SQM4)*WDTP(0)
34299 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
34300 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
34301 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
34302 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
34303 FACHW=FACHW*WIDS(KFHIGG,2)
34304 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
34305 & PARU(155+10*IHIGG)**2
34306 DO 170 I=MMIN1,MMAX1
34307 IA=IABS(I)
34308 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
34309 DO 160 J=MMIN2,MMAX2
34310 JA=IABS(J)
34311 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
34312 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
34313 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34314 & GOTO 160
34315 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
34316 FCKM=1D0
34317 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34318 FCOI=1D0
34319 IF(IA.LE.10) FCOI=FACA/3D0
34320 NCHN=NCHN+1
34321 ISIG(NCHN,1)=I
34322 ISIG(NCHN,2)=J
34323 ISIG(NCHN,3)=1
34324 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
34325 160 CONTINUE
34326 170 CONTINUE
34327
34328 ELSEIF(ISUB.EQ.32) THEN
34329C...f + g -> f + h0 (q + g -> q + h0 only)
34330 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
34331C...H propagator: as simulated in PYOFSH and as desired
34332 SQMHC=PMAS(25,1)**2
34333 GMMHC=PMAS(25,1)*PMAS(25,2)
34334 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
34335 CALL PYWIDT(25,SQM4,WDTP,WDTE)
34336 GMMHCC=SQRT(SQM4)*WDTP(0)
34337 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
34338 FHCQ=FHCQ*HBW4C/HBW4
34339 DO 190 I=MMINA,MMAXA
34340 IA=IABS(I)
34341 IF(IA.NE.5) GOTO 190
34342 SQML=PYMRUN(IA,SH)**2
34343 SQMQ=PMAS(IA,1)**2
34344 FACHCQ=FHCQ*SQML/SQMW*
34345 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
34346 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
34347 & (SQM4-SQMQ-SH)/SH)
34348 DO 180 ISDE=1,2
34349 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
34350 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
34351 NCHN=NCHN+1
34352 ISIG(NCHN,ISDE)=I
34353 ISIG(NCHN,3-ISDE)=21
34354 ISIG(NCHN,3)=1
34355 SIGH(NCHN)=FACHCQ*WIDS(25,2)
34356 180 CONTINUE
34357 190 CONTINUE
34358 ENDIF
34359
34360 ELSEIF(ISUB.LE.80) THEN
34361 IF(ISUB.EQ.71) THEN
34362C...Z0 + Z0 -> Z0 + Z0
34363 IF(SH.LE.4.01D0*SQMZ) GOTO 220
34364
34365 IF(MSTP(46).LE.2) THEN
34366C...Exact scattering ME:s for on-mass-shell gauge bosons
34367 BE2=1D0-4D0*SQMZ/SH
34368 TH=-0.5D0*SH*BE2*(1D0-CTH)
34369 UH=-0.5D0*SH*BE2*(1D0+CTH)
34370 IF(MAX(TH,UH).GT.-1D0) GOTO 220
34371 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
34372 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34373 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34374 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
34375 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
34376 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
34377 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
34378 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
34379 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
34380 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
34381 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
34382 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
34383 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
34384 & (ASHIM+ATHIM+AUHIM)**2)
34385 IF(MSTP(46).EQ.2) FACZZ=0D0
34386
34387 ELSE
34388C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34389 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
34390 & ABS(A00U+2D0*A20U)**2
34391 ENDIF
34392 FACZZ=FACZZ*WIDS(23,1)
34393
34394 DO 210 I=MMIN1,MMAX1
34395 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
34396 EI=KCHG(IABS(I),1)/3D0
34397 AI=SIGN(1D0,EI)
34398 VI=AI-4D0*EI*XWV
34399 AVI=AI**2+VI**2
34400 DO 200 J=MMIN2,MMAX2
34401 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
34402 EJ=KCHG(IABS(J),1)/3D0
34403 AJ=SIGN(1D0,EJ)
34404 VJ=AJ-4D0*EJ*XWV
34405 AVJ=AJ**2+VJ**2
34406 NCHN=NCHN+1
34407 ISIG(NCHN,1)=I
34408 ISIG(NCHN,2)=J
34409 ISIG(NCHN,3)=1
34410 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
34411 200 CONTINUE
34412 210 CONTINUE
34413 220 CONTINUE
34414
34415 ELSEIF(ISUB.EQ.72) THEN
34416C...Z0 + Z0 -> W+ + W-
34417 IF(SH.LE.4.01D0*SQMZ) GOTO 250
34418
34419 IF(MSTP(46).LE.2) THEN
34420C...Exact scattering ME:s for on-mass-shell gauge bosons
34421 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
34422 CTH2=CTH**2
34423 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
34424 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
34425 IF(MAX(TH,UH).GT.-1D0) GOTO 250
34426 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
34427 & (1D0-2D0*SQMZ/SH)
34428 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34429 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34430 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
34431 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34432 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34433 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
34434 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34435 ATWIM=0D0
34436 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
34437 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34438 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34439 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
34440 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34441 AUWIM=0D0
34442 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
34443 A4IM=0D0
34444 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
34445 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
34446 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
34447 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
34448 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
34449 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
34450 & (ATWIM+AUWIM+A4IM)**2)
34451
34452 ELSE
34453C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34454 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
34455 & ABS(A00U-A20U)**2
34456 ENDIF
34457 FACWW=FACWW*WIDS(24,1)
34458
34459 DO 240 I=MMIN1,MMAX1
34460 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
34461 EI=KCHG(IABS(I),1)/3D0
34462 AI=SIGN(1D0,EI)
34463 VI=AI-4D0*EI*XWV
34464 AVI=AI**2+VI**2
34465 DO 230 J=MMIN2,MMAX2
34466 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
34467 EJ=KCHG(IABS(J),1)/3D0
34468 AJ=SIGN(1D0,EJ)
34469 VJ=AJ-4D0*EJ*XWV
34470 AVJ=AJ**2+VJ**2
34471 NCHN=NCHN+1
34472 ISIG(NCHN,1)=I
34473 ISIG(NCHN,2)=J
34474 ISIG(NCHN,3)=1
34475 SIGH(NCHN)=FACWW*AVI*AVJ
34476 230 CONTINUE
34477 240 CONTINUE
34478 250 CONTINUE
34479
34480 ELSEIF(ISUB.EQ.73) THEN
34481C...Z0 + W+/- -> Z0 + W+/-
34482 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
34483
34484 IF(MSTP(46).LE.2) THEN
34485C...Exact scattering ME:s for on-mass-shell gauge bosons
34486 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
34487 EP1=1D0-(SQMZ-SQMW)/SH
34488 EP2=1D0+(SQMZ-SQMW)/SH
34489 TH=-0.5D0*SH*BE2*(1D0-CTH)
34490 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
34491 IF(MAX(TH,UH).GT.-1D0) GOTO 280
34492 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
34493 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
34494 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
34495 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
34496 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
34497 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
34498 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
34499 ASWIM=0D0
34500 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
34501 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
34502 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
34503 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
34504 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
34505 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
34506 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
34507 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
34508 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
34509 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
34510 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
34511 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
34512 AUWIM=0D0
34513 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
34514 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
34515 A4IM=0D0
34516 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
34517 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
34518 IF(MSTP(46).LE.0) FACZW=0D0
34519 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
34520 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
34521 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
34522 & (ASWIM+AUWIM+A4IM)**2)
34523
34524 ELSE
34525C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34526 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
34527 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
34528 ENDIF
34529 FACZW=FACZW*WIDS(23,2)
34530
34531 DO 270 I=MMIN1,MMAX1
34532 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
34533 EI=KCHG(IABS(I),1)/3D0
34534 AI=SIGN(1D0,EI)
34535 VI=AI-4D0*EI*XWV
34536 AVI=AI**2+VI**2
34537 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
34538 DO 260 J=MMIN2,MMAX2
34539 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
34540 EJ=KCHG(IABS(J),1)/3D0
34541 AJ=SIGN(1D0,EJ)
34542 VJ=AI-4D0*EJ*XWV
34543 AVJ=AJ**2+VJ**2
34544 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
34545 NCHN=NCHN+1
34546 ISIG(NCHN,1)=I
34547 ISIG(NCHN,2)=J
34548 ISIG(NCHN,3)=1
34549 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
34550 NCHN=NCHN+1
34551 ISIG(NCHN,1)=I
34552 ISIG(NCHN,2)=J
34553 ISIG(NCHN,3)=2
34554 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
34555 260 CONTINUE
34556 270 CONTINUE
34557 280 CONTINUE
34558
34559 ELSEIF(ISUB.EQ.75) THEN
34560C...W+ + W- -> gamma + gamma
34561
34562 ELSEIF(ISUB.EQ.76) THEN
34563C...W+ + W- -> Z0 + Z0
34564 IF(SH.LE.4.01D0*SQMZ) GOTO 310
34565
34566 IF(MSTP(46).LE.2) THEN
34567C...Exact scattering ME:s for on-mass-shell gauge bosons
34568 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
34569 CTH2=CTH**2
34570 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
34571 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
34572 IF(MAX(TH,UH).GT.-1D0) GOTO 310
34573 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
34574 & (1D0-2D0*SQMZ/SH)
34575 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34576 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34577 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
34578 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34579 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34580 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
34581 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34582 ATWIM=0D0
34583 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
34584 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34585 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34586 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
34587 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34588 AUWIM=0D0
34589 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
34590 A4IM=0D0
34591 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
34592 & (SH/SQMW)**2*SH2
34593 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
34594 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
34595 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
34596 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
34597 & (ATWIM+AUWIM+A4IM)**2)
34598
34599 ELSE
34600C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34601 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
34602 & ABS(A00U-A20U)**2
34603 ENDIF
34604 FACZZ=FACZZ*WIDS(23,1)
34605
34606 DO 300 I=MMIN1,MMAX1
34607 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
34608 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34609 DO 290 J=MMIN2,MMAX2
34610 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
34611 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34612 IF(EI*EJ.GT.0D0) GOTO 290
34613 NCHN=NCHN+1
34614 ISIG(NCHN,1)=I
34615 ISIG(NCHN,2)=J
34616 ISIG(NCHN,3)=1
34617 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
34618 290 CONTINUE
34619 300 CONTINUE
34620 310 CONTINUE
34621
34622 ELSEIF(ISUB.EQ.77) THEN
34623C...W+/- + W+/- -> W+/- + W+/-
34624 IF(SH.LE.4.01D0*SQMW) GOTO 340
34625
34626 IF(MSTP(46).LE.2) THEN
34627C...Exact scattering ME:s for on-mass-shell gauge bosons
34628 BE2=1D0-4D0*SQMW/SH
34629 BE4=BE2**2
34630 CTH2=CTH**2
34631 CTH3=CTH**3
34632 TH=-0.5D0*SH*BE2*(1D0-CTH)
34633 UH=-0.5D0*SH*BE2*(1D0+CTH)
34634 IF(MAX(TH,UH).GT.-1D0) GOTO 340
34635 SHANG=(1D0+BE2)**2
34636 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34637 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34638 THANG=(BE2-CTH)**2
34639 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
34640 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
34641 UHANG=(BE2+CTH)**2
34642 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
34643 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
34644 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
34645 ASGRE=XW*SGZANG
34646 ASGIM=0D0
34647 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
34648 ASZIM=0D0
34649 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
34650 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
34651 ATGRE=0.5D0*XW*SH/TH*TGZANG
34652 ATGIM=0D0
34653 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
34654 ATZIM=0D0
34655 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
34656 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
34657 AUGRE=0.5D0*XW*SH/UH*UGZANG
34658 AUGIM=0D0
34659 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
34660 AUZIM=0D0
34661 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
34662 A4AIM=0D0
34663 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
34664 A4SIM=0D0
34665 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
34666 & (SH/SQMW)**2*SH2
34667 IF(MSTP(46).LE.0) THEN
34668 AWWARE=ASHRE
34669 AWWAIM=ASHIM
34670 AWWSRE=0D0
34671 AWWSIM=0D0
34672 ELSEIF(MSTP(46).EQ.1) THEN
34673 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
34674 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
34675 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
34676 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
34677 ELSE
34678 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
34679 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
34680 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
34681 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
34682 ENDIF
34683 AWWA2=AWWARE**2+AWWAIM**2
34684 AWWS2=AWWSRE**2+AWWSIM**2
34685
34686 ELSE
34687C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34688 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
34689 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
34690 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
34691 ENDIF
34692
34693 DO 330 I=MMIN1,MMAX1
34694 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
34695 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34696 DO 320 J=MMIN2,MMAX2
34697 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
34698 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34699 IF(EI*EJ.LT.0D0) THEN
34700C...W+W-
34701 IF(MSTP(45).EQ.1) GOTO 320
34702 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
34703 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
34704 ELSE
34705C...W+W+/W-W-
34706 IF(MSTP(45).EQ.2) GOTO 320
34707 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
34708 IF(MSTP(46).GE.3) FACWW=FWWS
34709 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
34710 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
34711 ENDIF
34712 NCHN=NCHN+1
34713 ISIG(NCHN,1)=I
34714 ISIG(NCHN,2)=J
34715 ISIG(NCHN,3)=1
34716 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
34717 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
34718 320 CONTINUE
34719 330 CONTINUE
34720 340 CONTINUE
34721 ENDIF
34722
34723 ELSEIF(ISUB.LE.120) THEN
34724 IF(ISUB.EQ.102) THEN
34725C...g + g -> h0 (or H0, or A0)
34726 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34727 HS=SHR*WDTP(0)
34728 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34729 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34730 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34731 & FACBW=0D0
34732C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34733 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34734 WDTP13=0D0
34735 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34736 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34737 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34738 345 CONTINUE
34739 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34740 & '(PYSGHG:) did not find Higgs -> g g channel')
34741 HI=SHR*WDTP13/32D0
34742 ELSE
34743 HI=SHR*WDTP(13)/32D0
34744 ENDIF
34745 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
34746 NCHN=NCHN+1
34747 ISIG(NCHN,1)=21
34748 ISIG(NCHN,2)=21
34749 ISIG(NCHN,3)=1
34750 SIGH(NCHN)=HI*FACBW*HF
34751 350 CONTINUE
34752
34753 ELSEIF(ISUB.EQ.103) THEN
34754C...gamma + gamma -> h0 (or H0, or A0)
34755 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34756 HS=SHR*WDTP(0)
34757 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34758 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34759 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34760 & FACBW=0D0
34761C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34762 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34763 WDTP14=0D0
34764 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34765 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
34766 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
34767 355 CONTINUE
34768 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
34769 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
34770 HI=SHR*WDTP14*2D0
34771 ELSE
34772 HI=SHR*WDTP(14)*2D0
34773 ENDIF
34774 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
34775 NCHN=NCHN+1
34776 ISIG(NCHN,1)=22
34777 ISIG(NCHN,2)=22
34778 ISIG(NCHN,3)=1
34779 SIGH(NCHN)=HI*FACBW*HF
34780 360 CONTINUE
34781
34782 ELSEIF(ISUB.EQ.110) THEN
34783C...f + fbar -> gamma + h0
34784 THUH=MAX(TH*UH,SH*CKIN(3)**2)
34785 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
34786 FACHG=FACHG*WIDS(KFHIGG,2)
34787C...Calculate loop contributions for intermediate gamma* and Z0
34788 CIGTOT=DCMPLX(0D0,0D0)
34789 CIZTOT=DCMPLX(0D0,0D0)
34790 JMAX=3*MSTP(1)+1
34791 DO 370 J=1,JMAX
34792 IF(J.LE.2*MSTP(1)) THEN
34793 FNC=1D0
34794 EJ=KCHG(J,1)/3D0
34795 AJ=SIGN(1D0,EJ+0.1D0)
34796 VJ=AJ-4D0*EJ*XWV
34797 BALP=SQM4/(2D0*PMAS(J,1))**2
34798 BBET=SH/(2D0*PMAS(J,1))**2
34799 ELSEIF(J.LE.3*MSTP(1)) THEN
34800 FNC=3D0
34801 JL=2*(J-2*MSTP(1))-1
34802 EJ=KCHG(10+JL,1)/3D0
34803 AJ=SIGN(1D0,EJ+0.1D0)
34804 VJ=AJ-4D0*EJ*XWV
34805 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
34806 BBET=SH/(2D0*PMAS(10+JL,1))**2
34807 ELSE
34808 BALP=SQM4/(2D0*PMAS(24,1))**2
34809 BBET=SH/(2D0*PMAS(24,1))**2
34810 ENDIF
34811 BABI=1D0/(BALP-BBET)
34812 IF(BALP.LT.1D0) THEN
34813 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
34814 F1ALP=F0ALP**2
34815 ELSE
34816 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
34817 & -DBLE(0.5D0*PARU(1)))
34818 F1ALP=-F0ALP**2
34819 ENDIF
34820 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
34821 IF(BBET.LT.1D0) THEN
34822 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
34823 F1BET=F0BET**2
34824 ELSE
34825 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
34826 & -DBLE(0.5D0*PARU(1)))
34827 F1BET=-F0BET**2
34828 ENDIF
34829 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
34830 IF(J.LE.3*MSTP(1)) THEN
34831 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
34832 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
34833 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
34834 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
34835 ELSE
34836 TXW=XW/XW1
34837 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
34838 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
34839 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
34840 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
34841 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
34842 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
34843 & (F1BET-F1ALP))
34844 ENDIF
34845 370 CONTINUE
34846 CIGTOT=CIGTOT/DBLE(SH)
34847 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
34848C...Loop over initial flavours
34849 DO 380 I=MMINA,MMAXA
34850 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
34851 EI=KCHG(IABS(I),1)/3D0
34852 AI=SIGN(1D0,EI)
34853 VI=AI-4D0*EI*XWV
34854 FCOI=1D0
34855 IF(IABS(I).LE.10) FCOI=FACA/3D0
34856 NCHN=NCHN+1
34857 ISIG(NCHN,1)=I
34858 ISIG(NCHN,2)=-I
34859 ISIG(NCHN,3)=1
34860 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
34861 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
34862 380 CONTINUE
34863
34864 ELSEIF(ISUB.EQ.111) THEN
34865C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
34866 IF(MSTP(38).NE.0) THEN
34867C...Simple case: only do gg <-> h exactly.
34868 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34869C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34870 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34871 WDTP13=0D0
34872 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34873 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34874 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34875 385 CONTINUE
34876 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34877 & '(PYSGHG:) did not find Higgs -> g g channel')
34878 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
34879 & (TH**2+UH**2)/(SH*SQM4)
34880 ELSE
34881 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
34882 & (TH**2+UH**2)/(SH*SQM4)
34883 ENDIF
34884C...Propagators: as simulated in PYOFSH and as desired
34885 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34886 GMMHC=SQRT(SQM4)*WDTP(0)
34887 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34888 & ((SQM4-SQMH)**2+GMMHC**2)
34889 FACGH=FACGH*HBW4C/HBW4
34890 ELSE
34891C...Messy case: do full loop integrals
34892 A5STUR=0D0
34893 A5STUI=0D0
34894 DO 390 I=1,2*MSTP(1)
34895 SQMQ=PMAS(I,1)**2
34896 EPSS=4D0*SQMQ/SH
34897 EPSH=4D0*SQMQ/SQMH
34898 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34899 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34900 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34901 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34902 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
34903 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
34904 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
34905 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
34906 390 CONTINUE
34907 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34908 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
34909 FACGH=FACGH*WIDS(25,2)
34910 ENDIF
34911 DO 400 I=MMINA,MMAXA
34912 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34913 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34914 NCHN=NCHN+1
34915 ISIG(NCHN,1)=I
34916 ISIG(NCHN,2)=-I
34917 ISIG(NCHN,3)=1
34918 SIGH(NCHN)=FACGH
34919 400 CONTINUE
34920
34921 ELSEIF(ISUB.EQ.112) THEN
34922C...f + g -> f + h0 (q + g -> q + h0 only)
34923 IF(MSTP(38).NE.0) THEN
34924C...Simple case: only do gg <-> h exactly.
34925 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34926C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34927 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34928 WDTP13=0D0
34929 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34930 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34931 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34932 405 CONTINUE
34933 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34934 & '(PYSGHG:) did not find Higgs -> g g channel')
34935 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
34936 & (SH**2+UH**2)/(-TH*SQM4)
34937 ELSE
34938 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
34939 & (SH**2+UH**2)/(-TH*SQM4)
34940 ENDIF
34941C...Propagators: as simulated in PYOFSH and as desired
34942 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34943 GMMHC=SQRT(SQM4)*WDTP(0)
34944 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34945 & ((SQM4-SQMH)**2+GMMHC**2)
34946 FACQH=FACQH*HBW4C/HBW4
34947 ELSE
34948C...Messy case: do full loop integrals
34949 A5TSUR=0D0
34950 A5TSUI=0D0
34951 DO 410 I=1,2*MSTP(1)
34952 SQMQ=PMAS(I,1)**2
34953 EPST=4D0*SQMQ/TH
34954 EPSH=4D0*SQMQ/SQMH
34955 CALL PYWAUX(1,EPST,W1TR,W1TI)
34956 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34957 CALL PYWAUX(2,EPST,W2TR,W2TI)
34958 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34959 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
34960 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
34961 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
34962 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
34963 410 CONTINUE
34964 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34965 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
34966 FACQH=FACQH*WIDS(25,2)
34967 ENDIF
34968 DO 430 I=MMINA,MMAXA
34969 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
34970 DO 420 ISDE=1,2
34971 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
34972 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
34973 NCHN=NCHN+1
34974 ISIG(NCHN,ISDE)=I
34975 ISIG(NCHN,3-ISDE)=21
34976 ISIG(NCHN,3)=1
34977 SIGH(NCHN)=FACQH
34978 420 CONTINUE
34979 430 CONTINUE
34980
34981 ELSEIF(ISUB.EQ.113) THEN
34982C...g + g -> g + h0
34983 IF(MSTP(38).NE.0) THEN
34984C...Simple case: only do gg <-> h exactly.
34985 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34986C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34987 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34988 WDTP13=0D0
34989 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34990 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34991 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34992 435 CONTINUE
34993 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34994 & '(PYSGHG:) did not find Higgs -> g g channel')
34995 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
34996 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34997 ELSE
34998 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
34999 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
35000 ENDIF
35001C...Propagators: as simulated in PYOFSH and as desired
35002 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
35003 GMMHC=SQRT(SQM4)*WDTP(0)
35004 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
35005 & ((SQM4-SQMH)**2+GMMHC**2)
35006 FACGH=FACGH*HBW4C/HBW4
35007 ELSE
35008C...Messy case: do full loop integrals
35009 A2STUR=0D0
35010 A2STUI=0D0
35011 A2USTR=0D0
35012 A2USTI=0D0
35013 A2TUSR=0D0
35014 A2TUSI=0D0
35015 A4STUR=0D0
35016 A4STUI=0D0
35017 DO 440 I=1,2*MSTP(1)
35018 SQMQ=PMAS(I,1)**2
35019 EPSS=4D0*SQMQ/SH
35020 EPST=4D0*SQMQ/TH
35021 EPSU=4D0*SQMQ/UH
35022 EPSH=4D0*SQMQ/SQMH
35023 IF(EPSH.LT.1D-6) GOTO 440
35024 CALL PYWAUX(1,EPSS,W1SR,W1SI)
35025 CALL PYWAUX(1,EPST,W1TR,W1TI)
35026 CALL PYWAUX(1,EPSU,W1UR,W1UI)
35027 CALL PYWAUX(1,EPSH,W1HR,W1HI)
35028 CALL PYWAUX(2,EPSS,W2SR,W2SI)
35029 CALL PYWAUX(2,EPST,W2TR,W2TI)
35030 CALL PYWAUX(2,EPSU,W2UR,W2UI)
35031 CALL PYWAUX(2,EPSH,W2HR,W2HI)
35032 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
35033 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
35034 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
35035 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
35036 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
35037 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
35038 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
35039 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
35040 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
35041 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
35042 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
35043 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
35044 W3STUR=YHSTUR-Y3STUR-Y3UTSR
35045 W3STUI=YHSTUI-Y3STUI-Y3UTSI
35046 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
35047 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
35048 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
35049 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
35050 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
35051 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
35052 W3USTR=YHUSTR-Y3USTR-Y3TSUR
35053 W3USTI=YHUSTI-Y3USTI-Y3TSUI
35054 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
35055 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
35056 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
35057 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
35058 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
35059 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
35060 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
35061 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
35062 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
35063 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
35064 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
35065 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
35066 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
35067 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
35068 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
35069 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
35070 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
35071 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
35072 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
35073 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
35074 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
35075 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
35076 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
35077 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
35078 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
35079 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
35080 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
35081 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
35082 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
35083 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
35084 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
35085 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
35086 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
35087 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
35088 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
35089 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
35090 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
35091 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
35092 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
35093 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
35094 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
35095 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
35096 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
35097 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
35098 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
35099 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
35100 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
35101 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
35102 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
35103 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
35104 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
35105 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
35106 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
35107 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
35108 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
35109 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
35110 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
35111 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
35112 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
35113 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
35114 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
35115 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
35116 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
35117 & (W2SR-W2HR+W3STUR))
35118 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
35119 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
35120 & (W2TR-W2HR+W3TUSR))
35121 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
35122 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
35123 & (W2UR-W2HR+W3USTR))
35124 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
35125 A2STUR=A2STUR+B2STUR+B2SUTR
35126 A2STUI=A2STUI+B2STUI+B2SUTI
35127 A2USTR=A2USTR+B2USTR+B2UTSR
35128 A2USTI=A2USTI+B2USTI+B2UTSI
35129 A2TUSR=A2TUSR+B2TUSR+B2TSUR
35130 A2TUSI=A2TUSI+B2TUSI+B2TSUI
35131 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
35132 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
35133 440 CONTINUE
35134 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
35135 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
35136 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
35137 FACGH=FACGH*WIDS(25,2)
35138 ENDIF
35139 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
35140 NCHN=NCHN+1
35141 ISIG(NCHN,1)=21
35142 ISIG(NCHN,2)=21
35143 ISIG(NCHN,3)=1
35144 SIGH(NCHN)=FACGH
35145 450 CONTINUE
35146 ENDIF
35147
35148 ELSEIF(ISUB.LE.170) THEN
35149 IF(ISUB.EQ.121) THEN
35150C...g + g -> Q + Qbar + h0
35151 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
35152 IA=KFPR(ISUBSV,2)
35153 PMF=PYMRUN(IA,SH)
35154 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
35155 & (0.5D0*PMF/PMAS(24,1))**2
35156 WID2=1D0
35157 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
35158 FACQQH=FACQQH*WID2
35159 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
35160 IKFI=1
35161 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
35162 IF(IA.GT.10) IKFI=3
35163 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
35164 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
35165 FACQQH=FACQQH/(1D0+RMSS(41))**2
35166 IF(IHIGG.NE.3) THEN
35167 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
35168 & PARU(151+10*IHIGG))**2
35169 ENDIF
35170 ENDIF
35171 ENDIF
35172 CALL PYQQBH(WTQQBH)
35173 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35174 HS=SHR*WDTP(0)
35175 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35176 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35177 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35178 & FACBW=0D0
35179 NCHN=NCHN+1
35180 ISIG(NCHN,1)=21
35181 ISIG(NCHN,2)=21
35182 ISIG(NCHN,3)=1
35183 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
35184 460 CONTINUE
35185
35186 ELSEIF(ISUB.EQ.122) THEN
35187C...q + qbar -> Q + Qbar + h0
35188 IA=KFPR(ISUBSV,2)
35189 PMF=PYMRUN(IA,SH)
35190 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
35191 & (0.5D0*PMF/PMAS(24,1))**2
35192 WID2=1D0
35193 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
35194 FACQQH=FACQQH*WID2
35195 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
35196 IKFI=1
35197 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
35198 IF(IA.GT.10) IKFI=3
35199 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
35200 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
35201 FACQQH=FACQQH/(1D0+RMSS(41))**2
35202 IF(IHIGG.NE.3) THEN
35203 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
35204 & PARU(151+10*IHIGG))**2
35205 ENDIF
35206 ENDIF
35207 ENDIF
35208 CALL PYQQBH(WTQQBH)
35209 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35210 HS=SHR*WDTP(0)
35211 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35212 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35213 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35214 & FACBW=0D0
35215 DO 470 I=MMINA,MMAXA
35216 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35217 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
35218 NCHN=NCHN+1
35219 ISIG(NCHN,1)=I
35220 ISIG(NCHN,2)=-I
35221 ISIG(NCHN,3)=1
35222 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
35223 470 CONTINUE
35224
35225 ELSEIF(ISUB.EQ.123) THEN
35226C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
35227C...inner process)
35228 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
35229 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
35230 & PARU(154+10*IHIGG)**2
35231 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
35232 & (VINT(216)-VINT(209)**2))**2
35233 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
35234 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
35235 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35236 HS=SHR*WDTP(0)
35237 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35238 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35239 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35240 & FACBW=0D0
35241 DO 490 I=MMIN1,MMAX1
35242 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
35243 IA=IABS(I)
35244 DO 480 J=MMIN2,MMAX2
35245 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
35246 JA=IABS(J)
35247 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
35248 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
35249 VI=AI-4D0*EI*XWV
35250 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
35251 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
35252 VJ=AJ-4D0*EJ*XWV
35253 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
35254 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
35255 NCHN=NCHN+1
35256 ISIG(NCHN,1)=I
35257 ISIG(NCHN,2)=J
35258 ISIG(NCHN,3)=1
35259 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
35260 480 CONTINUE
35261 490 CONTINUE
35262
35263 ELSEIF(ISUB.EQ.124) THEN
35264C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
35265C...inner process)
35266 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
35267 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
35268 & PARU(155+10*IHIGG)**2
35269 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
35270 & (VINT(216)-VINT(209)**2))**2
35271 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
35272 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35273 HS=SHR*WDTP(0)
35274 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35275 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35276 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35277 & FACBW=0D0
35278 DO 510 I=MMIN1,MMAX1
35279 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
35280 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
35281 DO 500 J=MMIN2,MMAX2
35282 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
35283 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
35284 IF(EI*EJ.GT.0D0) GOTO 500
35285 FACLR=VINT(180+I)*VINT(180+J)
35286 NCHN=NCHN+1
35287 ISIG(NCHN,1)=I
35288 ISIG(NCHN,2)=J
35289 ISIG(NCHN,3)=1
35290 SIGH(NCHN)=FACLR*FACWW*FACBW
35291 500 CONTINUE
35292 510 CONTINUE
35293
35294 ELSEIF(ISUB.EQ.143) THEN
35295C...f + fbar' -> H+/-
35296 SQMHC=PMAS(37,1)**2
35297 CALL PYWIDT(37,SH,WDTP,WDTE)
35298 HS=SHR*WDTP(0)
35299 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
35300 HP=AEM/(8D0*XW)*SH/SQMW*SH
35301 DO 530 I=MMIN1,MMAX1
35302 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
35303 IA=IABS(I)
35304 IM=(MOD(IA,10)+1)/2
35305 DO 520 J=MMIN2,MMAX2
35306 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
35307 JA=IABS(J)
35308 JM=(MOD(JA,10)+1)/2
35309 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
35310 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35311 & GOTO 520
35312 IF(MOD(IA,2).EQ.0) THEN
35313 IU=IA
35314 IL=JA
35315 ELSE
35316 IU=JA
35317 IL=IA
35318 ENDIF
35319 RML=PYMRUN(IL,SH)**2/SH
35320 RMU=PYMRUN(IU,SH)**2/SH
35321 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
35322 IF(IA.LE.10) HI=HI*FACA/3D0
35323 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35324 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
35325 NCHN=NCHN+1
35326 ISIG(NCHN,1)=I
35327 ISIG(NCHN,2)=J
35328 ISIG(NCHN,3)=1
35329 SIGH(NCHN)=HI*FACBW*HF
35330 520 CONTINUE
35331 530 CONTINUE
35332
35333 ELSEIF(ISUB.EQ.161) THEN
35334C...f + g -> f' + H+/- (b + g -> t + H+/- only)
35335C...(choice of only b and t to avoid kinematics problems)
35336 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
35337C...H propagator: as simulated in PYOFSH and as desired
35338 SQMHC=PMAS(37,1)**2
35339 GMMHC=PMAS(37,1)*PMAS(37,2)
35340 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
35341 CALL PYWIDT(37,SQM4,WDTP,WDTE)
35342 GMMHCC=SQRT(SQM4)*WDTP(0)
35343 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
35344 FHCQ=FHCQ*HBW4C/HBW4
35345 Q2RM=SH
35346 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
35347 DO 550 I=MMINA,MMAXA
35348 IA=IABS(I)
35349 IF(IA.NE.5) GOTO 550
35350 SQML=PYMRUN(IA,Q2RM)**2
35351 IUA=IA+MOD(IA,2)
35352 SQMQ=PYMRUN(IUA,Q2RM)**2
35353 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
35354 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
35355 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
35356 & (SQMHC-SQMQ-SH)/SH)
35357 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
35358 DO 540 ISDE=1,2
35359 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
35360 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
35361 NCHN=NCHN+1
35362 ISIG(NCHN,ISDE)=I
35363 ISIG(NCHN,3-ISDE)=21
35364 ISIG(NCHN,3)=1
35365 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
35366 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
35367 540 CONTINUE
35368 550 CONTINUE
35369 ENDIF
35370
35371 ELSEIF(ISUB.LE.402) THEN
35372 IF(ISUB.EQ.401) THEN
35373C... g + g -> t + bbar + H-
35374 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
35375 IA=KFPR(ISUBSV,2)
35376 CALL PYSTBH(WTTBH)
35377 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35378 HS=SHR*WDTP(0)
35379 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
35380 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35381 & FACBW=0D0
35382 NCHN=NCHN+1
35383 ISIG(NCHN,1)=21
35384 ISIG(NCHN,2)=21
35385 ISIG(NCHN,3)=1
35386 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
35387c Since we don't know yet if H+ or H-, assume H+
35388c when calculating suppression due to closed channels.
35389 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
35390 IF(ABS(WIDS(37,2)-WIDS(37,3))
35391 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
35392 & ABS(WIDS(6,2)-WIDS(6,3))
35393 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
35394 WRITE(*,*)'Error: Process 401 cannot handle different'
35395 WRITE(*,*)'decays for H+ and H- or t and tbar.'
35396 WRITE(*,*)'Execution stopped.'
35397 CALL PYSTOP(108)
35398 END IF
35399 560 CONTINUE
35400
35401 ELSEIF(ISUB.EQ.402) THEN
35402C... q + qbar -> t + bbar + H-
35403 IA=KFPR(ISUBSV,2)
35404 CALL PYSTBH(WTTBH)
35405 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35406 HS=SHR*WDTP(0)
35407 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
35408 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35409 & FACBW=0D0
35410 DO 570 I=MMINA,MMAXA
35411 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35412 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
35413 NCHN=NCHN+1
35414 ISIG(NCHN,1)=I
35415 ISIG(NCHN,2)=-I
35416 ISIG(NCHN,3)=1
35417 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
35418c Since we don't know yet if H+ or H-, assume H+
35419c when calculating suppression due to closed channels.
35420 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
35421 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
35422 & .GE.1D-6.OR.
35423 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
35424 & .GE.1D-6) THEN
35425 WRITE(*,*)'Error: Process 402 cannot handle different'
35426 WRITE(*,*)'decays for H+ and H- or t and tbar.'
35427 WRITE(*,*)'Execution stopped.'
35428 CALL PYSTOP(108)
35429 END IF
35430 570 CONTINUE
35431 ENDIF
35432 ENDIF
35433
35434 RETURN
35435 END
35436
35437C*********************************************************************
35438
35439C...PYSGSU
35440C...Subprocess cross sections for SUSY processes,
35441C...including Higgs pair production.
35442C...Auxiliary to PYSIGH.
35443
35444 SUBROUTINE PYSGSU(NCHN,SIGS)
35445
35446C...Double precision and integer declarations
35447 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35448 IMPLICIT INTEGER(I-N)
35449 INTEGER PYK,PYCHGE,PYCOMP
35450C...Parameter statement to help give large particle numbers.
35451 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35452 &KEXCIT=4000000,KDIMEN=5000000)
35453C...Commonblocks
35454 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35455 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35456 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
35457 COMMON/PYINT1/MINT(400),VINT(400)
35458 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
35459 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
35460 COMMON/PYINT4/MWID(500),WIDS(500,5)
35461 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35462 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35463 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35464 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
35465 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
35466 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
35467 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
35468 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
35469 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
35470C...Local arrays and complex variables
35471 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
35472 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
35473 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
35474 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
35475
35476CMRENNA++
35477C...Z and W width, combinations of weak mixing angle
35478 ZWID=PMAS(23,2)
35479 WWID=PMAS(24,2)
35480 TANW=SQRT(XW/XW1)
35481 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
35482
35483C...Convert almost equivalent SUSY processes into each other
35484C...Extract differences in flavours and couplings
35485
35486C...Sleptons and sneutrinos
35487 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
35488 KFID=MOD(KFPR(ISUB,1),KSUSY1)
35489 ISUB=201
35490 ILR=0
35491 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
35492 KFID=MOD(KFPR(ISUB,1),KSUSY1)
35493 ISUB=201
35494 ILR=1
35495 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
35496 KFID=MOD(KFPR(ISUB,1),KSUSY1)
35497 ISUB=203
35498 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
35499 IF(ISUB.EQ.210) THEN
35500 RKF=2.0D0
35501 ELSEIF(ISUB.EQ.211) THEN
35502 RKF=SFMIX(15,1)**2
35503 ELSEIF(ISUB.EQ.212) THEN
35504 RKF=SFMIX(15,2)**2
35505 ENDIF
35506 ISUB=210
35507 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
35508 IF(ISUB.EQ.213) THEN
35509 KFID=MOD(KFPR(ISUB,1),KSUSY1)
35510 RKF=2.0D0
35511 ELSEIF(ISUB.EQ.214) THEN
35512 KFID=16
35513 RKF=1.0D0
35514 ENDIF
35515 ISUB=213
35516
35517C...Neutralinos
35518 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
35519 IF(ISUB.EQ.216) THEN
35520 IZID1=1
35521 IZID2=1
35522 ELSEIF(ISUB.EQ.217) THEN
35523 IZID1=2
35524 IZID2=2
35525 ELSEIF(ISUB.EQ.218) THEN
35526 IZID1=3
35527 IZID2=3
35528 ELSEIF(ISUB.EQ.219) THEN
35529 IZID1=4
35530 IZID2=4
35531 ELSEIF(ISUB.EQ.220) THEN
35532 IZID1=1
35533 IZID2=2
35534 ELSEIF(ISUB.EQ.221) THEN
35535 IZID1=1
35536 IZID2=3
35537 ELSEIF(ISUB.EQ.222) THEN
35538 IZID1=1
35539 IZID2=4
35540 ELSEIF(ISUB.EQ.223) THEN
35541 IZID1=2
35542 IZID2=3
35543 ELSEIF(ISUB.EQ.224) THEN
35544 IZID1=2
35545 IZID2=4
35546 ELSEIF(ISUB.EQ.225) THEN
35547 IZID1=3
35548 IZID2=4
35549 ENDIF
35550 ISUB=216
35551
35552C...Charginos
35553 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
35554 IF(ISUB.EQ.226) THEN
35555 IZID1=1
35556 IZID2=1
35557 ELSEIF(ISUB.EQ.227) THEN
35558 IZID1=2
35559 IZID2=2
35560 ELSEIF(ISUB.EQ.228) THEN
35561 IZID1=1
35562 IZID2=2
35563 ENDIF
35564 ISUB=226
35565
35566C...Neutralino + chargino
35567 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
35568 IF(ISUB.EQ.229) THEN
35569 IZID1=1
35570 IZID2=1
35571 ELSEIF(ISUB.EQ.230) THEN
35572 IZID1=1
35573 IZID2=2
35574 ELSEIF(ISUB.EQ.231) THEN
35575 IZID1=1
35576 IZID2=3
35577 ELSEIF(ISUB.EQ.232) THEN
35578 IZID1=1
35579 IZID2=4
35580 ELSEIF(ISUB.EQ.233) THEN
35581 IZID1=2
35582 IZID2=1
35583 ELSEIF(ISUB.EQ.234) THEN
35584 IZID1=2
35585 IZID2=2
35586 ELSEIF(ISUB.EQ.235) THEN
35587 IZID1=2
35588 IZID2=3
35589 ELSEIF(ISUB.EQ.236) THEN
35590 IZID1=2
35591 IZID2=4
35592 ENDIF
35593 ISUB=229
35594
35595C...Gluino + neutralino
35596 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
35597 IF(ISUB.EQ.237) THEN
35598 IZID=1
35599 ELSEIF(ISUB.EQ.238) THEN
35600 IZID=2
35601 ELSEIF(ISUB.EQ.239) THEN
35602 IZID=3
35603 ELSEIF(ISUB.EQ.240) THEN
35604 IZID=4
35605 ENDIF
35606 ISUB=237
35607
35608C...Gluino + chargino
35609 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
35610 IF(ISUB.EQ.241) THEN
35611 IZID=1
35612 ELSEIF(ISUB.EQ.242) THEN
35613 IZID=2
35614 ENDIF
35615 ISUB=241
35616
35617C...Squark + neutralino
35618 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
35619 ILR=0
35620 IF(MOD(ISUB,2).NE.0) ILR=1
35621 IF(ISUB.LE.247) THEN
35622 IZID=1
35623 ELSEIF(ISUB.LE.249) THEN
35624 IZID=2
35625 ELSEIF(ISUB.LE.251) THEN
35626 IZID=3
35627 ELSEIF(ISUB.LE.253) THEN
35628 IZID=4
35629 ENDIF
35630 ISUB=246
35631 RKF=5D0
35632
35633C...Squark + chargino
35634 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
35635 IF(ISUB.LE.255) THEN
35636 IZID=1
35637 ELSEIF(ISUB.LE.257) THEN
35638 IZID=2
35639 ENDIF
35640 IF(MOD(ISUB,2).EQ.0) THEN
35641 ILR=0
35642 ELSE
35643 ILR=1
35644 ENDIF
35645 ISUB=254
35646 RKF=5D0
35647
35648C...Squark + gluino
35649 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
35650 ISUB=258
35651 RKF=4D0
35652
35653C...Stops
35654 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
35655 ILR=0
35656 IF(ISUB.EQ.262) ILR=1
35657 ISUB=261
35658 ELSEIF(ISUB.EQ.265) THEN
35659 ISUB=264
35660
35661C...Squarks
35662 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
35663 ILR=0
35664 IF(ISUB.LE.273) THEN
35665 IF(ISUB.EQ.273) ILR=1
35666 ISUB=271
35667 RKF=16D0
35668 ELSEIF(ISUB.LE.276) THEN
35669 IF(ISUB.EQ.276) ILR=1
35670 ISUB=274
35671 RKF=16D0
35672 ELSEIF(ISUB.LE.278) THEN
35673 IF(ISUB.EQ.278) ILR=1
35674 ISUB=277
35675 RKF=4D0
35676 ELSE
35677 IF(ISUB.EQ.280) ILR=1
35678 ISUB=279
35679 RKF=4D0
35680 ENDIF
35681C...Sbottoms
35682 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
35683 ILR=0
35684 IF(ISUB.LE.283) THEN
35685 IF(ISUB.EQ.283) ILR=1
35686 ISUB=271
35687 RKF=4D0
35688 ELSEIF(ISUB.LE.286) THEN
35689 IF(ISUB.EQ.286) ILR=1
35690 ISUB=274
35691 RKF=4D0
35692 ELSEIF(ISUB.LE.288) THEN
35693 IF(ISUB.EQ.288) ILR=1
35694 ISUB=277
35695 RKF=1D0
35696 ELSEIF(ISUB.LE.290) THEN
35697 IF(ISUB.EQ.290) ILR=1
35698 ISUB=279
35699 RKF=1D0
35700 ELSEIF(ISUB.LE.293) THEN
35701 IF(ISUB.EQ.293) ILR=1
35702 ISUB=271
35703 RKF=1D0
35704 ELSEIF(ISUB.EQ.296) THEN
35705 ILR=1
35706 ISUB=274
35707 RKF=1D0
35708C...Squark + gluino
35709 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
35710 ISUB=258
35711 RKF=1D0
35712 ENDIF
35713C...H+/- + H0
35714 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
35715 IF(ISUB.EQ.297) THEN
35716 RKF=.5D0*PARU(195)**2
35717 ELSEIF(ISUB.EQ.298) THEN
35718 RKF=.5D0*(1D0-PARU(195)**2)
35719 ENDIF
35720 ISUB=210
35721C...A0 + H0
35722 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
35723 IF(ISUB.EQ.299) THEN
35724 RKF=PARU(186)**2
35725 KFID=25
35726 ELSEIF(ISUB.EQ.300) THEN
35727 RKF=PARU(187)**2
35728 KFID=35
35729 ENDIF
35730 ISUB=213
35731C...H+ + H-
35732 ELSEIF(ISUB.EQ.301) THEN
35733 KFID=37
35734 RKF=1D0
35735 ISUB=201
35736 ENDIF
35737
35738C...Supersymmetric processes - all of type 2 -> 2 :
35739C...correct final-state Breit-Wigners from fixed to running width.
35740 IF(MSTP(42).GT.0) THEN
35741 DO 100 I=1,2
35742 KFLW=KFPR(ISUBSV,I)
35743 KCW=PYCOMP(KFLW)
35744 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
35745 IF(I.EQ.1) SQMI=SQM3
35746 IF(I.EQ.2) SQMI=SQM4
35747 SQMS=PMAS(KCW,1)**2
35748 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
35749 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
35750 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
35751 GMMI=SQRT(SQMI)*WDTP(0)
35752 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
35753 COMFAC=COMFAC*(HBWI/HBWS)
35754 100 CONTINUE
35755 ENDIF
35756
35757C...Differential cross section expressions.
35758
35759 IF(ISUB.LE.210) THEN
35760 IF(ISUB.EQ.201) THEN
35761C...f + fbar -> e_L + e_Lbar
35762 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35763 DO 130 I=MMIN1,MMAX1
35764 IA=IABS(I)
35765 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
35766 EI=KCHG(IA,1)/3D0
35767 TT3I=SIGN(1D0,EI+1D-6)/2D0
35768 EJ=-1D0
35769 TT3J=-1D0/2D0
35770 FCOL=1D0
35771C...Color factor for e+ e-
35772 IF(IA.GE.11) FCOL=3D0
35773 IF(ISUBSV.EQ.301) THEN
35774 A1=1D0
35775 A2=0D0
35776 ELSEIF(ILR.EQ.1) THEN
35777 A1=SFMIX(KFID,3)**2
35778 A2=SFMIX(KFID,4)**2
35779 ELSEIF(ILR.EQ.0) THEN
35780 A1=SFMIX(KFID,1)**2
35781 A2=SFMIX(KFID,2)**2
35782 ENDIF
35783 XLQ=(TT3J-EJ*XW)*A1
35784 XRQ=(-EJ*XW)*A2
35785 XLF=(TT3I-EI*XW)
35786 XRF=(-EI*XW)
35787 TAA=(EI*EJ)**2*(POLL+POLR)
35788 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
35789 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
35790 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
35791 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35792 TNN=0.0D0
35793 TAN=0.0D0
35794 TZN=0.0D0
35795 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35796 FAC2=SQRT(2D0)
35797 TNN1=0D0
35798 TNN2=0D0
35799 TNN3=0D0
35800 DO 120 II=1,4
35801 DK=1D0/(TH-SMZ(II)**2)
35802 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35803 & ZMIX(II,1))
35804 FREK=FAC2*TANW*EI*ZMIX(II,1)
35805 TNN1=TNN1+FLEK**2*DK
35806 TNN2=TNN2+FREK**2*DK
35807 DO 110 JJ=1,4
35808 DL=1D0/(TH-SMZ(JJ)**2)
35809 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35810 & ZMIX(JJ,1))
35811 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35812 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35813 110 CONTINUE
35814 120 CONTINUE
35815 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
35816 & A2**2*TNN2**2*POLR)
35817 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
35818 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
35819 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
35820 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
35821 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35822 & (1D0-SQMZ/SH)/SH
35823 TZN=TZN/XW**2/XW1
35824 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
35825 & A2*TNN2*POLR)/XW
35826 ENDIF
35827 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
35828 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
35829 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
35830 NCHN=NCHN+1
35831 ISIG(NCHN,1)=I
35832 ISIG(NCHN,2)=-I
35833 ISIG(NCHN,3)=1
35834 SIGH(NCHN)=FACQQ1+FACQQ2
35835 130 CONTINUE
35836
35837 ELSEIF(ISUB.EQ.203) THEN
35838C...f + fbar -> e_L + e_Rbar
35839 DO 160 I=MMIN1,MMAX1
35840 IA=IABS(I)
35841 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
35842 EI=KCHG(IABS(I),1)/3D0
35843 TT3I=SIGN(1D0,EI)/2D0
35844 EJ=-1
35845 TT3J=-1D0/2D0
35846 FCOL=1D0
35847C...Color factor for e+ e-
35848 IF(IA.GE.11) FCOL=3D0
35849 A1=SFMIX(KFID,1)**2
35850 A2=SFMIX(KFID,2)**2
35851 XLQ=(TT3J-EJ*XW)
35852 XRQ=(-EJ*XW)
35853 XLF=(TT3I-EI*XW)
35854 XRF=(-EI*XW)
35855 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
35856 & /XW**2/XW1**2*A1*A2
35857 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35858 TNN=0.0D0
35859 TZN=0.0D0
35860 TNNA=0D0
35861 TNNB=0D0
35862 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35863 FAC2=SQRT(2D0)
35864 TNN1=0D0
35865 TNN2=0D0
35866 TNN3=0D0
35867 DO 150 II=1,4
35868 DK=1D0/(TH-SMZ(II)**2)
35869 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35870 & ZMIX(II,1))
35871 FREK=FAC2*TANW*EI*ZMIX(II,1)
35872 TNN1=TNN1+FLEK**2*DK
35873 TNN2=TNN2+FREK**2*DK
35874 DO 140 JJ=1,4
35875 DL=1D0/(TH-SMZ(JJ)**2)
35876 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35877 & ZMIX(JJ,1))
35878 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35879 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35880 140 CONTINUE
35881 150 CONTINUE
35882 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
35883 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
35884 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
35885 TZN=(UH*TH-SQM3*SQM4)*A1*A2
35886 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
35887 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35888 & (1D0-SQMZ/SH)/SH
35889 ENDIF
35890 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
35891 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
35892 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
35893C%%%%%%%%%%%
35894 NCHN=NCHN+1
35895 ISIG(NCHN,1)=I
35896 ISIG(NCHN,2)=-I
35897 ISIG(NCHN,3)=1
35898 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35899 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35900 NCHN=NCHN+1
35901 ISIG(NCHN,1)=I
35902 ISIG(NCHN,2)=-I
35903 ISIG(NCHN,3)=2
35904 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35905 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35906 160 CONTINUE
35907
35908 ELSEIF(ISUB.EQ.210) THEN
35909C...q + qbar' -> W*- > ~l_L + ~nu_L
35910 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
35911 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
35912 DO 180 I=MMIN1,MMAX1
35913 IA=IABS(I)
35914 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
35915 DO 170 J=MMIN2,MMAX2
35916 JA=IABS(J)
35917 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
35918 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
35919 FCKM=3D0
35920 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35921 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35922 KCHW=2
35923 IF(KCHSUM.LT.0) KCHW=3
35924 NCHN=NCHN+1
35925 ISIG(NCHN,1)=I
35926 ISIG(NCHN,2)=J
35927 ISIG(NCHN,3)=1
35928 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
35929 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35930 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35931 ELSE
35932 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35933 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35934 ENDIF
35935 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
35936 170 CONTINUE
35937 180 CONTINUE
35938 ENDIF
35939
35940 ELSEIF(ISUB.LE.220) THEN
35941 IF(ISUB.EQ.213) THEN
35942C...f + fbar -> ~nu_L + ~nu_Lbar
35943 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
35944 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35945 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35946 ELSE
35947 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35948 ENDIF
35949 COMFAC=COMFAC*FACR
35950 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
35951 XLL=0.5D0
35952 XLR=0.0D0
35953 DO 190 I=MMIN1,MMAX1
35954 IA=IABS(I)
35955 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
35956 EI=KCHG(IA,1)/3D0
35957 FCOL=1D0
35958C...Color factor for e+ e-
35959 IF(IA.GE.11) FCOL=3D0
35960 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
35961 XRQ=-EI*XW
35962 TZC=0.0D0
35963 TCC=0.0D0
35964 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
35965 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
35966 & (TH-SMW(2)**2)
35967 TCC=TZC**2
35968 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
35969 ENDIF
35970 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
35971 FACQQ2=TZC+TCC/4D0
35972 NCHN=NCHN+1
35973 ISIG(NCHN,1)=I
35974 ISIG(NCHN,2)=-I
35975 ISIG(NCHN,3)=1
35976 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
35977 & *AEM**2*FCOL/3D0/XW**2
35978 190 CONTINUE
35979
35980 ELSEIF(ISUB.EQ.216) THEN
35981C...q + qbar -> ~chi0_1 + ~chi0_1
35982 IF(IZID1.EQ.IZID2) THEN
35983 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35984 ELSE
35985 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35986 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35987 ENDIF
35988 FACXX=COMFAC*AEM**2/3D0/XW**2
35989 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
35990 ZM12=SQM3
35991 ZM22=SQM4
35992 WU2 = (UH-ZM12)*(UH-ZM22)
35993 WT2 = (TH-ZM12)*(TH-ZM22)
35994 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
35995 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35996 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35997 DO 200 I=1,4
35998 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
35999 IF(IZID2.NE.IZID1) THEN
36000 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
36001 ENDIF
36002 200 CONTINUE
36003 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
36004 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
36005 ORPP=DCONJG(OLPP)
36006 DO 210 I=MMINA,MMAXA
36007 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
36008 EI=KCHG(IABS(I),1)/3D0
36009 T3I=SIGN(1D0,EI+1D-6)/2D0
36010 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
36011 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
36012 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
36013 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
36014 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
36015 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
36016 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
36017 & /DCMPLX(TH-XML2)
36018 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
36019 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
36020 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
36021 FCOL=1D0
36022 IF(IABS(I).GE.11) FCOL=3D0
36023 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
36024 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
36025 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
36026 & QRL*DCONJG(QRR)*POLR)*WS2
36027 NCHN=NCHN+1
36028 ISIG(NCHN,1)=I
36029 ISIG(NCHN,2)=-I
36030 ISIG(NCHN,3)=1
36031 SIGH(NCHN)=FACXX*FACGG1*FCOL
36032 210 CONTINUE
36033 ENDIF
36034
36035 ELSEIF(ISUB.LE.230) THEN
36036 IF(ISUB.EQ.226) THEN
36037C...f + fbar -> ~chi+_1 + ~chi-_1
36038 FACXX=COMFAC*AEM**2/3D0
36039 ZM12=SQM3
36040 ZM22=SQM4
36041 WU2 = (UH-ZM12)*(UH-ZM22)
36042 WT2 = (TH-ZM12)*(TH-ZM22)
36043 WS2 = SMW(IZID1)*SMW(IZID2)*SH
36044 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
36045 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
36046 DIFF=0D0
36047 IF(IZID1.EQ.IZID2) DIFF=1D0
36048 DO 220 I=1,2
36049 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
36050 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
36051 IF(IZID2.NE.IZID1) THEN
36052 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
36053 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
36054 ENDIF
36055 220 CONTINUE
36056 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
36057 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
36058 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
36059 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
36060 DO 230 I=MMINA,MMAXA
36061 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
36062 EI=KCHG(IABS(I),1)/3D0
36063 T3I=SIGN(1D0,EI+1D-6)/2D0
36064 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
36065 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
36066 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
36067 IF(MOD(I,2).EQ.0) THEN
36068 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
36069 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
36070 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
36071 & DCMPLX(T3I/XW/(TH-XML2))
36072 ELSE
36073 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
36074 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
36075 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
36076 & DCMPLX(T3I/XW/(TH-XML2))
36077 ENDIF
36078 FCOL=1D0
36079 IF(IABS(I).GE.11) FCOL=3D0
36080 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
36081 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
36082 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
36083 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
36084 NCHN=NCHN+1
36085 ISIG(NCHN,1)=I
36086 ISIG(NCHN,2)=-I
36087 ISIG(NCHN,3)=1
36088 IF(IZID1.EQ.IZID2) THEN
36089 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36090 ELSE
36091 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
36092 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36093 NCHN=NCHN+1
36094 ISIG(NCHN,1)=I
36095 ISIG(NCHN,2)=-I
36096 ISIG(NCHN,3)=2
36097 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36098 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
36099 ENDIF
36100 230 CONTINUE
36101
36102 ELSEIF(ISUB.EQ.229) THEN
36103C...q + qbar' -> ~chi0_1 + ~chi+-_1
36104 FACXX=COMFAC*AEM**2/6D0/XW**2
36105 ZM12=SQM3
36106 ZM22=SQM4
36107 WU2 = (UH-ZM12)*(UH-ZM22)
36108 WT2 = (TH-ZM12)*(TH-ZM22)
36109 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
36110 RT2I = 1D0/SQRT(2D0)
36111 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
36112 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
36113 DO 240 I=1,2
36114 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
36115 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
36116 240 CONTINUE
36117 DO 250 I=1,4
36118 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
36119 250 CONTINUE
36120 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
36121 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
36122 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
36123 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
36124
36125 DO 270 I=MMIN1,MMAX1
36126 IA=IABS(I)
36127 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
36128 EI=KCHG(IA,1)/3D0
36129 T3I=SIGN(1D0,EI+1D-6)/2D0
36130 DO 260 J=MMIN2,MMAX2
36131 JA=IABS(J)
36132 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
36133 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
36134 EJ=KCHG(JA,1)/3D0
36135 T3J=SIGN(1D0,EJ+1D-6)/2D0
36136 FCKM=3D0
36137 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
36138 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
36139 KCHW=2
36140 IF(KCHSUM.LT.0) KCHW=3
36141 IF(MOD(IA,2).EQ.0) THEN
36142 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
36143 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
36144 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
36145 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
36146 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
36147 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
36148 & /DCMPLX(TH-ZMJ2)
36149 ELSE
36150 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
36151 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
36152 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
36153 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
36154 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
36155 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
36156 & /DCMPLX(TH-ZMI2)
36157 ENDIF
36158 ZINTR=DBLE(QLR*DCONJG(QLL))
36159 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
36160 & 2D0*ZINTR*WS2)
36161 NCHN=NCHN+1
36162 ISIG(NCHN,1)=I
36163 ISIG(NCHN,2)=J
36164 ISIG(NCHN,3)=1
36165 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36166 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
36167 260 CONTINUE
36168 270 CONTINUE
36169 ENDIF
36170
36171 ELSEIF(ISUB.LE.240) THEN
36172 IF(ISUB.EQ.237) THEN
36173C...q + qbar -> gluino + ~chi0_1
36174 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36175 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36176 ASYUK=RMSS(42)*AS
36177 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
36178 GM2=SQM3
36179 ZM2=SQM4
36180 DO 280 I=MMINA,MMAXA
36181 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36182 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 280
36183 EI=KCHG(IABS(I),1)/3D0
36184 IA=IABS(I)
36185 XLQC = -TANW*EI*ZMIX(IZID,1)
36186 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
36187 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
36188 XLQ2=XLQC**2
36189 XRQ2=XRQC**2
36190 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
36191 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
36192 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
36193 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
36194 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
36195 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
36196 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
36197 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
36198 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
36199 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
36200 NCHN=NCHN+1
36201 ISIG(NCHN,1)=I
36202 ISIG(NCHN,2)=-I
36203 ISIG(NCHN,3)=1
36204 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
36205 280 CONTINUE
36206 ENDIF
36207
36208 ELSEIF(ISUB.LE.250) THEN
36209 IF(ISUB.EQ.241) THEN
36210C...q + qbar' -> ~chi+-_1 + gluino
36211 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
36212 GM2=SQM3
36213 ZM2=SQM4
36214 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
36215 FAC0=UMIX(IZID,1)**2
36216 FAC1=VMIX(IZID,1)**2
36217 DO 300 I=MMIN1,MMAX1
36218 IA=IABS(I)
36219 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
36220 DO 290 J=MMIN2,MMAX2
36221 JA=IABS(J)
36222 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
36223 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
36224 FCKM=1D0
36225 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
36226 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
36227 KCHW=2
36228 IF(KCHSUM.LT.0) KCHW=3
36229 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
36230 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
36231 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
36232 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
36233 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
36234 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
36235 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
36236 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
36237 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
36238 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
36239 & SH/(TH-XMU2)/(UH-XMD2))/2D0
36240 NCHN=NCHN+1
36241 ISIG(NCHN,1)=I
36242 ISIG(NCHN,2)=J
36243 ISIG(NCHN,3)=1
36244 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
36245 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36246 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
36247 290 CONTINUE
36248 300 CONTINUE
36249
36250 ELSEIF(ISUB.EQ.243) THEN
36251C...q + qbar -> gluino + gluino
36252 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36253 XMT=SQM3-TH
36254 XMU=SQM3-UH
36255 DO 310 I=MMINA,MMAXA
36256 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36257 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
36258 NCHN=NCHN+1
36259 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
36260 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
36261 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
36262 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
36263 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
36264 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
36265 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
36266 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
36267 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
36268 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
36269 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
36270 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
36271 ISIG(NCHN,1)=I
36272 ISIG(NCHN,2)=-I
36273 ISIG(NCHN,3)=1
36274C...1/2 for identical particles
36275 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
36276 310 CONTINUE
36277
36278 ELSEIF(ISUB.EQ.244) THEN
36279C...g + g -> gluino + gluino
36280 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36281 XMT=SQM3-TH
36282 XMU=SQM3-UH
36283 FACQQ1=COMFAC*AS**2*9D0/4D0*(
36284 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
36285 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
36286 FACQQ2=COMFAC*AS**2*9D0/4D0*(
36287 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
36288 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
36289 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
36290 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
36291 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
36292 NCHN=NCHN+1
36293 ISIG(NCHN,1)=21
36294 ISIG(NCHN,2)=21
36295 ISIG(NCHN,3)=1
36296 SIGH(NCHN)=FACQQ1/2D0
36297 NCHN=NCHN+1
36298 ISIG(NCHN,1)=21
36299 ISIG(NCHN,2)=21
36300 ISIG(NCHN,3)=2
36301 SIGH(NCHN)=FACQQ2/2D0
36302 NCHN=NCHN+1
36303 ISIG(NCHN,1)=21
36304 ISIG(NCHN,2)=21
36305 ISIG(NCHN,3)=3
36306 SIGH(NCHN)=FACQQ3/2D0
36307 320 CONTINUE
36308
36309 ELSEIF(ISUB.EQ.246) THEN
36310C...g + q_j -> ~chi0_1 + ~q_j
36311 FAC0=COMFAC*AS*AEM/6D0/XW
36312 ZM2=SQM4
36313 QM2=SQM3
36314 FACZQ0=FAC0*( (ZM2-TH)/SH +
36315 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
36316 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
36317 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36318 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
36319 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
36320 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
36321 EI=KCHG(IABS(I),1)/3D0
36322 IA=IABS(I)
36323 XRQZ = -TANW*EI*ZMIX(IZID,1)
36324 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
36325 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
36326 IF(ILR.EQ.0) THEN
36327 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
36328 ELSE
36329 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
36330 ENDIF
36331 FACZQ=FACZQ0*BS
36332 KCHQ=2
36333 IF(I.LT.0) KCHQ=3
36334 DO 330 ISDE=1,2
36335 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
36336 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
36337 NCHN=NCHN+1
36338 ISIG(NCHN,ISDE)=I
36339 ISIG(NCHN,3-ISDE)=21
36340 ISIG(NCHN,3)=1
36341 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36342 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36343 330 CONTINUE
36344 340 CONTINUE
36345 ENDIF
36346
36347 ELSEIF(ISUB.LE.260) THEN
36348 IF(ISUB.EQ.254) THEN
36349C...g + q_j -> ~chi1_1 + ~q_i
36350 FAC0=COMFAC*AS*AEM/12D0/XW
36351 ZM2=SQM4
36352 QM2=SQM3
36353 AU=UMIX(IZID,1)**2
36354 AD=VMIX(IZID,1)**2
36355 FACZQ0=FAC0*( (ZM2-TH)/SH +
36356 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
36357 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
36358 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
36359 IF(MOD(KFNSQ1,2).EQ.0) THEN
36360 KFNSQ=KFNSQ1-1
36361 KCHW=2
36362 ELSE
36363 KFNSQ=KFNSQ1+1
36364 KCHW=3
36365 ENDIF
36366 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
36367 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
36368 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
36369 IA=IABS(I)
36370 IF(MOD(IA,2).EQ.0) THEN
36371 FACZQ=FACZQ0*AU
36372 ELSE
36373 FACZQ=FACZQ0*AD
36374 ENDIF
36375 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
36376 KCHQ=2
36377 IF(I.LT.0) KCHQ=3
36378 KCHWQ=KCHW
36379 IF(I.LT.0) KCHWQ=5-KCHW
36380 DO 350 ISDE=1,2
36381 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
36382 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
36383 NCHN=NCHN+1
36384 ISIG(NCHN,ISDE)=I
36385 ISIG(NCHN,3-ISDE)=21
36386 ISIG(NCHN,3)=1
36387 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36388 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
36389 350 CONTINUE
36390 360 CONTINUE
36391
36392 ELSEIF(ISUB.EQ.258) THEN
36393C...g + q_j -> gluino + ~q_i
36394 XG2=SQM4
36395 XQ2=SQM3
36396 XMT=XG2-TH
36397 XMU=XG2-UH
36398 XST=XQ2-TH
36399 XSU=XQ2-UH
36400 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
36401 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
36402 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
36403 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
36404 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
36405 & (SH*(UH+XG2)
36406 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
36407 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
36408 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
36409 ASYUK=RMSS(42)*AS
36410 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
36411 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
36412 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36413 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
36414 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
36415 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
36416 KCHQ=2
36417 IF(I.LT.0) KCHQ=3
36418 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36419 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36420 DO 370 ISDE=1,2
36421 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
36422 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
36423 NCHN=NCHN+1
36424 ISIG(NCHN,ISDE)=I
36425 ISIG(NCHN,3-ISDE)=21
36426 ISIG(NCHN,3)=1
36427 SIGH(NCHN)=FACQG1*FACSEL
36428 NCHN=NCHN+1
36429 ISIG(NCHN,ISDE)=I
36430 ISIG(NCHN,3-ISDE)=21
36431 ISIG(NCHN,3)=2
36432 SIGH(NCHN)=FACQG2*FACSEL
36433 370 CONTINUE
36434 380 CONTINUE
36435 ENDIF
36436
36437 ELSEIF(ISUB.LE.270) THEN
36438 IF(ISUB.EQ.261) THEN
36439C...q_i + q_ibar -> ~t_1 + ~t_1bar
36440 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
36441 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36442 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36443 FAC0=AS**2*4D0/9D0
36444 DO 390 I=MMIN1,MMAX1
36445 IA=IABS(I)
36446 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
36447 IF(IA.GE.11.AND.IA.LE.18) THEN
36448 EI=KCHG(IA,1)/3D0
36449 EJ=KCHG(KFNSQ,1)/3D0
36450 T3I=SIGN(1D0,EI)/2D0
36451 T3J=SIGN(1D0,EJ)/2D0
36452 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
36453 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
36454 XLF=2D0*(T3I-EI*XW)
36455 XRF=2D0*(-EI*XW)
36456 TAA=0.5D0*(EI*EJ)**2
36457 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
36458 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
36459 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
36460 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
36461 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
36462 ENDIF
36463 NCHN=NCHN+1
36464 ISIG(NCHN,1)=I
36465 ISIG(NCHN,2)=-I
36466 ISIG(NCHN,3)=1
36467 SIGH(NCHN)=FACQQ1*FAC0
36468 390 CONTINUE
36469
36470 ELSEIF(ISUB.EQ.263) THEN
36471C...f + fbar -> ~t1 + ~t2bar
36472 DO 400 I=MMIN1,MMAX1
36473 IA=IABS(I)
36474 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
36475 EI=KCHG(IABS(I),1)/3D0
36476 TT3I=SIGN(1D0,EI)/2D0
36477 EJ=2D0/3D0
36478 TT3J=1D0/2D0
36479 FCOL=1D0
36480C...Color factor for e+ e-
36481 IF(IA.GE.11) FCOL=3D0
36482 XLQ=2D0*(TT3J-EJ*XW)
36483 XRQ=2D0*(-EJ*XW)
36484 XLF=2D0*(TT3I-EI*XW)
36485 XRF=2D0*(-EI*XW)
36486 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
36487 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
36488 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
36489C...Factor of 2 for t1 t2bar + t2 t1bar
36490C...PS: bug fix 24 Aug 2010. Factor 2 accounted for by the 2 channels.
36491 FACQQ1=COMFAC*AEM**2*TZZ*FCOL*4D0
36492 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
36493 NCHN=NCHN+1
36494 ISIG(NCHN,1)=I
36495 ISIG(NCHN,2)=-I
36496 ISIG(NCHN,3)=1
36497 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36498 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
36499 NCHN=NCHN+1
36500 ISIG(NCHN,1)=I
36501 ISIG(NCHN,2)=-I
36502 ISIG(NCHN,3)=2
36503 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
36504 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36505 400 CONTINUE
36506
36507 ELSEIF(ISUB.EQ.264) THEN
36508C...g + g -> ~t_1 + ~t_1bar
36509 XSU=SQM3-UH
36510 XST=SQM3-TH
36511 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
36512 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36513 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
36514 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
36515 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
36516 NCHN=NCHN+1
36517 ISIG(NCHN,1)=21
36518 ISIG(NCHN,2)=21
36519 ISIG(NCHN,3)=1
36520 SIGH(NCHN)=FACQQ1
36521 NCHN=NCHN+1
36522 ISIG(NCHN,1)=21
36523 ISIG(NCHN,2)=21
36524 ISIG(NCHN,3)=2
36525 SIGH(NCHN)=FACQQ2
36526 410 CONTINUE
36527 ENDIF
36528
36529 ELSEIF(ISUB.LE.280) THEN
36530 IF(ISUB.EQ.271) THEN
36531C...q + q' -> ~q + ~q' (~g exchange)
36532 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
36533 XMT=XMG2-TH
36534 XMU=XMG2-UH
36535 XSU1=SQM3-UH
36536 XSU2=SQM4-UH
36537 XST1=SQM3-TH
36538 XST2=SQM4-TH
36539 ASYUK=RMSS(42)*AS
36540 IF(ILR.EQ.1) THEN
36541 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
36542 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
36543 FACQQB=0.0D0
36544 ELSE
36545 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
36546 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
36547 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
36548 & XMT/XMU )
36549 ENDIF
36550 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
36551 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
36552 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
36553 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
36554 IA=IABS(I)
36555 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36556 KCHQ=2
36557 IF(I.LT.0) KCHQ=3
36558 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
36559 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
36560 JA=IABS(J)
36561 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
36562 IF(I*J.LT.0) GOTO 420
36563 NCHN=NCHN+1
36564 ISIG(NCHN,1)=I
36565 ISIG(NCHN,2)=J
36566 ISIG(NCHN,3)=1
36567 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36568 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
36569 IF(I.EQ.J) THEN
36570 IF(ILR.EQ.0) THEN
36571 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
36572 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
36573 ELSE
36574 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
36575 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36576 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
36577 ENDIF
36578 NCHN=NCHN+1
36579 ISIG(NCHN,1)=I
36580 ISIG(NCHN,2)=J
36581 ISIG(NCHN,3)=2
36582 IF(ILR.EQ.0) THEN
36583 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
36584 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
36585 ELSE
36586 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
36587 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36588 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
36589 ENDIF
36590 ENDIF
36591 420 CONTINUE
36592 430 CONTINUE
36593
36594 ELSEIF(ISUB.EQ.274) THEN
36595C...q + qbar' -> ~q + ~qbar'
36596 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
36597 XMT=XMG2-TH
36598 XMU=XMG2-UH
36599 IF(ILR.EQ.0) THEN
36600C...Mrenna...Normalization.and.1/XMT
36601 FACQQ1=COMFAC*AS**2*2D0/9D0*(
36602 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
36603 FACQQB=COMFAC*AS**2*4D0/9D0*(
36604 & (UH*TH-SQM3*SQM4)/SH2 )
36605 FACQQI=-COMFAC*AS**2*4D0/27D0*(
36606 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
36607 FACQQB=FACQQB+FACQQ1+FACQQI
36608 ELSE
36609 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
36610 FACQQB=FACQQ1
36611 ENDIF
36612 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
36613 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
36614 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
36615 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
36616 IA=IABS(I)
36617 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
36618 KCHQ=2
36619 IF(I.LT.0) KCHQ=3
36620 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
36621 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
36622 JA=IABS(J)
36623 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
36624 IF(I*J.GT.0) GOTO 440
36625 NCHN=NCHN+1
36626 ISIG(NCHN,1)=I
36627 ISIG(NCHN,2)=J
36628 ISIG(NCHN,3)=1
36629 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36630 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
36631 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
36632 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36633 440 CONTINUE
36634 450 CONTINUE
36635
36636 ELSEIF(ISUB.EQ.277) THEN
36637C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
36638C...if i .eq. j covered in 274
36639 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
36640 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36641 FAC0=0D0
36642 DO 460 I=MMIN1,MMAX1
36643 IA=IABS(I)
36644 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
36645 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
36646 IF(IA.EQ.KFNSQ) GOTO 460
36647 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
36648 EI=KCHG(IA,1)/3D0
36649 EJ=KCHG(KFNSQ,1)/3D0
36650 T3J=SIGN(0.5D0,EJ)
36651 T3I=SIGN(1D0,EI)/2D0
36652 IF(ILR.EQ.0) THEN
36653 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
36654 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
36655 ELSE
36656 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
36657 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
36658 ENDIF
36659 XLF=2D0*(T3I-EI*XW)
36660 XRF=2D0*(-EI*XW)
36661 IF(ILR.EQ.0) THEN
36662 XRQ=0D0
36663 ELSE
36664 XLQ=0D0
36665 ENDIF
36666 TAA=0.5D0*(EI*EJ)**2
36667 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
36668 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
36669 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
36670 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
36671 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
36672 ELSEIF(IA.LE.6) THEN
36673 FAC0=AS**2*8D0/9D0/2D0
36674 ENDIF
36675 NCHN=NCHN+1
36676 ISIG(NCHN,1)=I
36677 ISIG(NCHN,2)=-I
36678 ISIG(NCHN,3)=1
36679 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36680 460 CONTINUE
36681
36682 ELSEIF(ISUB.EQ.279) THEN
36683C...g + g -> ~q_j + ~q_jbar
36684 XSU=SQM3-UH
36685 XST=SQM3-TH
36686C...4=RKF because ~t ~tbar and ~b ~bbar treated separately
36687 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
36688 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
36689 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
36690 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
36691 NCHN=NCHN+1
36692 ISIG(NCHN,1)=21
36693 ISIG(NCHN,2)=21
36694 ISIG(NCHN,3)=1
36695 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36696 NCHN=NCHN+1
36697 ISIG(NCHN,1)=21
36698 ISIG(NCHN,2)=21
36699 ISIG(NCHN,3)=2
36700 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36701 470 CONTINUE
36702
36703 ENDIF
36704 ENDIF
36705CMRENNA--
36706
36707 RETURN
36708 END
36709
36710C*********************************************************************
36711
36712C...PYSGTC
36713C...Subprocess cross sections for Technicolor processes.
36714C...Auxiliary to PYSIGH.
36715
36716 SUBROUTINE PYSGTC(NCHN,SIGS)
36717
36718C...Double precision and integer declarations
36719 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36720 IMPLICIT INTEGER(I-N)
36721 INTEGER PYK,PYCHGE,PYCOMP
36722C...Parameter statement to help give large particle numbers.
36723 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36724 &KEXCIT=4000000,KDIMEN=5000000)
36725C...Commonblocks
36726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36727 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36728 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36729 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36730 COMMON/PYINT1/MINT(400),VINT(400)
36731 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36732 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36733 COMMON/PYINT4/MWID(500),WIDS(500,5)
36734 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36735 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36736 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36737 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36738 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36739 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36740 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36741C...Local arrays and complex variables
36742 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36743 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
36744 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
36745 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
36746 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
36747 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
36748 COMPLEX*16 DVVS,DVVT,DVVU
36749 INTEGER INDX(6)
36750
36751C...Combinations of weak mixing angle.
36752 TANW=SQRT(XW/XW1)
36753 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
36754
36755C...Convert almost equivalent technicolor processes into
36756C...a few basic processes, and set distinguishing parameters.
36757 IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
36758 SQTV=RTCM(12)**2
36759 SQTA=RTCM(13)**2
36760 SN2W=2D0*SQRT(XW*XW1)
36761 CS2W=1D0-2D0*XW
36762 CT2W=CS2W/SN2W
36763 CSXI=COS(ASIN(RTCM(3)))
36764 CSXIP=COS(ASIN(RTCM(4)))
36765 QUPD=2D0*RTCM(2)-1D0
36766 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
36767 CAB2=0D0
36768 VOGP=0D0
36769 VRGP=0D0
36770 AOGP=0D0
36771 ARGP=0D0
36772 VXGP=0D0
36773 AXGP=0D0
36774 VAGP=0D0
36775 VZGP=0D0
36776 VWGP=0D0
36777C... rho_tc0, etc. -> W_L W_L, W_L W_T
36778 IF(ISUB.EQ.361) THEN
36779 KFA=24
36780 KFB=24
36781 CAB2=RTCM(3)**4
36782 AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36783 ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36784 VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
36785C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
36786 AXGP = SQRT(2D0)*AXGP
36787 ARGP = SQRT(2D0)*ARGP
36788 VOGP = SQRT(2D0)*VOGP
36789C... rho_tc0 -> W_L pi_tc-
36790 ELSEIF(ISUB.EQ.362) THEN
36791 KFA=24
36792 KFB=KTECHN+211
36793 ISUB=361
36794 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36795C... pi_tc pi_tc
36796 ELSEIF(ISUB.EQ.363) THEN
36797 KFA=KTECHN+211
36798 KFB=KTECHN+211
36799 ISUB=361
36800 CAB2=(1D0-RTCM(3)**2)**2
36801C... rho_tc0/omega_tc -> gamma pi_tc
36802 ELSEIF(ISUB.EQ.364) THEN
36803 KFA=22
36804 KFB=KTECHN+111
36805 ISUB=361
36806 VOGP=CSXI/RTCM(12)
36807 VRGP=VOGP*QUPD
36808 VAGP=2D0*QUPD*CSXI
36809 VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36810C... gamma pi_tc'
36811 ELSEIF(ISUB.EQ.365) THEN
36812 KFA=22
36813 KFB=KTECHN+221
36814 ISUB=361
36815 VRGP=CSXIP/RTCM(12)
36816 VOGP=VRGP*QUPD
36817 VAGP=2D0*Q2UD*CSXIP
36818 VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
36819C... Z pi_tc
36820 ELSEIF(ISUB.EQ.366) THEN
36821 KFA=23
36822 KFB=KTECHN+111
36823 ISUB=361
36824 VOGP=CSXI*CT2W/RTCM(12)
36825 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36826 VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36827 VZGP=-QUPD*CSXI*CS2W/XW1
36828C... Z pi_tc'
36829 ELSEIF(ISUB.EQ.367) THEN
36830 KFA=23
36831 KFB=KTECHN+221
36832 ISUB=361
36833C...RTCM(48) is the M_V for the techni-a
36834 VXGP=-CSXIP/SN2W/RTCM(48)
36835 VRGP=CSXIP*CT2W/RTCM(12)
36836 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
36837 VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
36838 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
36839C... W_T pi_tc
36840 ELSEIF(ISUB.EQ.368) THEN
36841 KFA=24
36842 KFB=KTECHN+211
36843 ISUB=361
36844C...RTCM(49) is the M_A for the techni-a
36845 AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
36846 VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
36847 ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
36848 VAGP=QUPD*CSXI/(2D0*SQRT(XW))
36849 VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36850C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
36851 ELSEIF(ISUB.EQ.370) THEN
36852 KFA=24
36853 KFB=23
36854 CAB2=RTCM(3)**4
36855 ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36856 AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36857C... W_L pi_tc0
36858 ELSEIF(ISUB.EQ.371) THEN
36859 KFA=24
36860 KFB=KTECHN+111
36861 ISUB=370
36862 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36863C... Z_L pi_tc+
36864 ELSEIF(ISUB.EQ.372) THEN
36865 KFA=KTECHN+211
36866 KFB=23
36867 ISUB=370
36868 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36869C... pi_tc+ pi_tc0
36870 ELSEIF(ISUB.EQ.373) THEN
36871 KFA=KTECHN+211
36872 KFB=KTECHN+111
36873 ISUB=370
36874 CAB2=(1D0-RTCM(3)**2)**2
36875C... gamma pi_tc+
36876 ELSEIF(ISUB.EQ.374) THEN
36877 KFA=KTECHN+211
36878 KFB=22
36879 ISUB=370
36880 VRGP=QUPD*CSXI/RTCM(12)
36881 VWGP=QUPD*CSXI/(2D0*SQRT(XW))
36882 AXGP=-CSXI/RTCM(49)
36883C... Z_T pi_tc+
36884 ELSEIF(ISUB.EQ.375) THEN
36885 KFA=KTECHN+211
36886 KFB=23
36887 ISUB=370
36888 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36889 ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
36890 VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36891 AXGP=-CSXI*CT2W/RTCM(49)
36892C... W_T pi_tc0
36893 ELSEIF(ISUB.EQ.376) THEN
36894 KFA=24
36895 KFB=KTECHN+111
36896 ISUB=370
36897 VRGP=0D0
36898 ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
36899 AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
36900C... W_T pi_tc0'
36901 ELSEIF(ISUB.EQ.377) THEN
36902 KFA=24
36903 KFB=KTECHN+221
36904 ISUB=370
36905 VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
36906 VWGP=CSXIP/(2D0*XW)
36907 VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
36908C... gamma W+
36909 ELSEIF(ISUB.EQ.378) THEN
36910 KFA=24
36911 KFB=22
36912 ISUB=370
36913 VRGP=QUPD*RTCM(3)/RTCM(12)
36914 AXGP=-RTCM(3)/RTCM(49)
36915C... gamma Z
36916 ELSEIF(ISUB.EQ.379) THEN
36917 KFA=23
36918 KFB=22
36919 ISUB=361
36920 VOGP=RTCM(3)/RTCM(12)
36921 VRGP=QUPD*RTCM(3)/RTCM(12)
36922 ELSEIF(ISUB.EQ.380) THEN
36923 KFA=23
36924 KFB=23
36925 ISUB=361
36926 VOGP=RTCM(3)*CT2W/RTCM(12)
36927 VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
36928 ENDIF
36929 ENDIF
36930
36931C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
36932 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
36933 IF(ITCM(5).LE.4) THEN
36934 SQDQQS=1D0/SH2
36935 SQDQQT=1D0/TH2
36936 SQDQQU=1D0/UH2
36937 SQDGGS=SQDQQS
36938 SQDGGT=SQDQQT
36939 SQDGGU=SQDQQU
36940 REDGGS=1D0/SH
36941 REDGGT=1D0/TH
36942 REDGGU=1D0/UH
36943 REDGTU=1D0/UH/TH
36944 REDGSU=1D0/SH/UH
36945 REDGST=1D0/SH/TH
36946 REDQST=1D0/SH/TH
36947 REDQTU=1D0/UH/TH
36948 SQDLGS=0D0
36949 SQDLGT=0D0
36950 SQDQTS=SQDQQS
36951 ELSEIF(ITCM(5).EQ.5) THEN
36952 TANT3=RTCM(21)
36953 IF(ITCM(2).EQ.0) THEN
36954 IMDL=1
36955 ELSE
36956 IMDL=2
36957 ENDIF
36958 ALPRHT=2.16D0*(3D0/ITCM(1))
36959 SIN2T=2D0*TANT3/(TANT3**2+1D0)
36960 SINT3=TANT3/SQRT(TANT3**2+1D0)
36961 XIG=SQRT(PYALPS(SH)/ALPRHT)
36962 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
36963 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
36964 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
36965 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
36966 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
36967 & SINT3**2)*2D0/SIN2T
36968 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
36969 & SINT3**2)*2D0/SIN2T
36970
36971 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
36972 SM1112=X12*RTCM(28)**2*SIN2T
36973 SM1121=-X21*RTCM(28)**2*SIN2T
36974 SM2212=-SM1112
36975 SM2221=-SM1121
36976 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
36977 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
36978
36979C.........SH LOOP
36980 ZTC(1,1)=DCMPLX(SH,0D0)
36981 CALL PYWIDT(3100021,SH,WDTP,WDTE)
36982 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
36983 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
36984 CALL PYWIDT(3100113,SH,WDTP,WDTE)
36985 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
36986 CALL PYWIDT(3400113,SH,WDTP,WDTE)
36987 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
36988 CALL PYWIDT(3200113,SH,WDTP,WDTE)
36989 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
36990 CALL PYWIDT(3300113,SH,WDTP,WDTE)
36991 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
36992 ZTC(1,2)=(0D0,0D0)
36993 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
36994 ZTC(1,4)=ZTC(1,3)
36995 ZTC(1,5)=ZTC(1,2)
36996 ZTC(1,6)=ZTC(1,2)
36997 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
36998 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
36999 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
37000 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
37001 ZTC(3,4)=-SM1122
37002 ZTC(3,5)=-SM1112
37003 ZTC(3,6)=-SM1121
37004 ZTC(4,5)=-SM2212
37005 ZTC(4,6)=-SM2221
37006 ZTC(5,6)=-SM1221
37007
37008 DO 110 I=1,5
37009 DO 100 J=I+1,6
37010 ZTC(J,I)=ZTC(I,J)
37011 100 CONTINUE
37012 110 CONTINUE
37013 CALL PYLDCM(ZTC,6,6,INDX,D)
37014 DO 130 I=1,6
37015 DO 120 J=1,6
37016 YTC(I,J)=(0D0,0D0)
37017 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
37018 120 CONTINUE
37019 130 CONTINUE
37020
37021 DO 140 I=1,6
37022 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
37023 140 CONTINUE
37024 DGGS=YTC(1,1)
37025 DVVS=YTC(2,2)
37026 DGVS=YTC(1,2)
37027
37028 XIG=SQRT(PYALPS(-TH)/ALPRHT)
37029C.........TH LOOP
37030 ZTC(1,1)=DCMPLX(TH)
37031 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
37032 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
37033 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
37034 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
37035 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
37036 ZTC(1,2)=(0D0,0D0)
37037 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
37038 ZTC(1,4)=ZTC(1,3)
37039 ZTC(1,5)=ZTC(1,2)
37040 ZTC(1,6)=ZTC(1,2)
37041 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
37042 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
37043 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
37044 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
37045 ZTC(3,4)=-SM1122
37046 ZTC(3,5)=-SM1112
37047 ZTC(3,6)=-SM1121
37048 ZTC(4,5)=-SM2212
37049 ZTC(4,6)=-SM2221
37050 ZTC(5,6)=-SM1221
37051 DO 160 I=1,5
37052 DO 150 J=I+1,6
37053 ZTC(J,I)=ZTC(I,J)
37054 150 CONTINUE
37055 160 CONTINUE
37056 CALL PYLDCM(ZTC,6,6,INDX,D)
37057 DO 180 I=1,6
37058 DO 170 J=1,6
37059 YTC(I,J)=(0D0,0D0)
37060 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
37061 170 CONTINUE
37062 180 CONTINUE
37063 DO 190 I=1,6
37064 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
37065 190 CONTINUE
37066 DGGT=YTC(1,1)
37067 DVVT=YTC(2,2)
37068 DGVT=YTC(1,2)
37069
37070 XIG=SQRT(PYALPS(-UH)/ALPRHT)
37071C.........UH LOOP
37072 ZTC(1,1)=DCMPLX(UH,0D0)
37073 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
37074 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
37075 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
37076 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
37077 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
37078 ZTC(1,2)=(0D0,0D0)
37079 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
37080 ZTC(1,4)=ZTC(1,3)
37081 ZTC(1,5)=ZTC(1,2)
37082 ZTC(1,6)=ZTC(1,2)
37083 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
37084 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
37085 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
37086 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
37087 ZTC(3,4)=-SM1122
37088 ZTC(3,5)=-SM1112
37089 ZTC(3,6)=-SM1121
37090 ZTC(4,5)=-SM2212
37091 ZTC(4,6)=-SM2221
37092 ZTC(5,6)=-SM1221
37093 DO 210 I=1,5
37094 DO 200 J=I+1,6
37095 ZTC(J,I)=ZTC(I,J)
37096 200 CONTINUE
37097 210 CONTINUE
37098 CALL PYLDCM(ZTC,6,6,INDX,D)
37099 DO 230 I=1,6
37100 DO 220 J=1,6
37101 YTC(I,J)=(0D0,0D0)
37102 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
37103 220 CONTINUE
37104 230 CONTINUE
37105 DO 240 I=1,6
37106 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
37107 240 CONTINUE
37108 DGGU=YTC(1,1)
37109 DVVU=YTC(2,2)
37110 DGVU=YTC(1,2)
37111
37112 IF(IMDL.EQ.1) THEN
37113 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
37114 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
37115 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
37116 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
37117 DQGS=DGGS-DGVS*DCMPLX(TANT3)
37118 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
37119 ELSE
37120 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
37121 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
37122 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
37123 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
37124 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
37125 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
37126 ENDIF
37127
37128 SQDQTS=ABS(DQTS)**2
37129 SQDQQS=ABS(DQQS)**2
37130 SQDQQT=ABS(DQQT)**2
37131 SQDQQU=ABS(DQQU)**2
37132 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
37133 REDLGS=DBLE(DQGS)
37134 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
37135 REDHGS=DBLE(DTGS)
37136 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
37137
37138 SQDGGS=ABS(DGGS)**2
37139 SQDGGT=ABS(DGGT)**2
37140 SQDGGU=ABS(DGGU)**2
37141 REDGGS=DBLE(DGGS)
37142 REDGGT=DBLE(DGGT)
37143 REDGGU=DBLE(DGGU)
37144 REDGTU=DBLE(DGGU*DCONJG(DGGT))
37145 REDGSU=DBLE(DGGU*DCONJG(DGGS))
37146 REDGST=DBLE(DGGS*DCONJG(DGGT))
37147 REDQST=DBLE(DQQS*DCONJG(DQQT))
37148 REDQTU=DBLE(DQQT*DCONJG(DQQU))
37149 ENDIF
37150 ENDIF
37151
37152
37153C...Differential cross section expressions.
37154
37155 IF(ISUB.LE.190) THEN
37156 IF(ISUB.EQ.149) THEN
37157C...g + g -> eta_tc
37158 KCTC=PYCOMP(KTECHN+331)
37159 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
37160 HS=SHR*WDTP(0)
37161 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
37162 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37163 HP=SH
37164 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
37165 HI=HP*WDTP(3)
37166 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37167 NCHN=NCHN+1
37168 ISIG(NCHN,1)=21
37169 ISIG(NCHN,2)=21
37170 ISIG(NCHN,3)=1
37171 SIGH(NCHN)=HI*FACBW*HF
37172 250 CONTINUE
37173
37174 ELSEIF(ISUB.EQ.165) THEN
37175C...q + qbar -> l+ + l- (including contact term for compositeness)
37176 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
37177 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
37178 KFF=IABS(KFPR(ISUB,1))
37179 EF=KCHG(KFF,1)/3D0
37180 AF=SIGN(1D0,EF+0.1D0)
37181 VF=AF-4D0*EF*XWV
37182 VALF=VF+AF
37183 VARF=VF-AF
37184 FCOF=1D0
37185 IF(KFF.LE.10) FCOF=3D0
37186 WID2=1D0
37187 IF(KFF.EQ.6) WID2=WIDS(6,1)
37188 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
37189 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
37190 DO 260 I=MMINA,MMAXA
37191 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
37192 EI=KCHG(IABS(I),1)/3D0
37193 AI=SIGN(1D0,EI+0.1D0)
37194 VI=AI-4D0*EI*XWV
37195 VALI=VI+AI
37196 VARI=VI-AI
37197 FCOI=1D0
37198 IF(IABS(I).LE.10) FCOI=FACA/3D0
37199 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
37200 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
37201 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
37202 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
37203 ELSE
37204 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
37205 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
37206 ENDIF
37207 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
37208 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
37209 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
37210 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
37211 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
37212 NCHN=NCHN+1
37213 ISIG(NCHN,1)=I
37214 ISIG(NCHN,2)=-I
37215 ISIG(NCHN,3)=1
37216 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
37217 260 CONTINUE
37218
37219 ELSEIF(ISUB.EQ.166) THEN
37220C...q + q'bar -> l + nu_l (including contact term for compositeness)
37221 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
37222 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
37223 KFF=IABS(KFPR(ISUB,1))
37224 FCOF=1D0
37225 IF(KFF.LE.10) FCOF=3D0
37226 DO 280 I=MMIN1,MMAX1
37227 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
37228 IA=IABS(I)
37229 DO 270 J=MMIN2,MMAX2
37230 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
37231 JA=IABS(J)
37232 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
37233 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37234 & GOTO 270
37235 FCOI=1D0
37236 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37237 WID2=1D0
37238 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
37239 & MOD(J,2).EQ.0)) THEN
37240 IF(KFF.EQ.5) WID2=WIDS(6,2)
37241 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
37242 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
37243 ELSE
37244 IF(KFF.EQ.5) WID2=WIDS(6,3)
37245 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
37246 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
37247 ENDIF
37248 NCHN=NCHN+1
37249 ISIG(NCHN,1)=I
37250 ISIG(NCHN,2)=J
37251 ISIG(NCHN,3)=1
37252 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
37253 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
37254 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
37255 270 CONTINUE
37256 280 CONTINUE
37257 ENDIF
37258
37259 ELSEIF(ISUB.LE.200) THEN
37260 IF(ISUB.EQ.191) THEN
37261C...q + qbar -> rho_tc0.
37262 KCTC=PYCOMP(KTECHN+113)
37263 SQMRHT=PMAS(KCTC,1)**2
37264 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
37265 HS=SHR*WDTP(0)
37266 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
37267 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37268 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37269 ALPRHT=2.16D0*(3D0/ITCM(1))
37270 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
37271 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
37272 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
37273 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
37274 DO 290 I=MMINA,MMAXA
37275 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
37276 IA=IABS(I)
37277 EI=KCHG(IABS(I),1)/3D0
37278 AI=SIGN(1D0,EI+0.1D0)
37279 VI=AI-4D0*EI*XWV
37280 VALI=0.5D0*(VI+AI)
37281 VARI=0.5D0*(VI-AI)
37282 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
37283 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
37284 IF(IA.LE.10) HI=HI*FACA/3D0
37285 NCHN=NCHN+1
37286 ISIG(NCHN,1)=I
37287 ISIG(NCHN,2)=-I
37288 ISIG(NCHN,3)=1
37289 SIGH(NCHN)=HI*FACBW*HF
37290 290 CONTINUE
37291
37292 ELSEIF(ISUB.EQ.192) THEN
37293C...q + qbar' -> rho_tc+/-.
37294 KCTC=PYCOMP(KTECHN+213)
37295 SQMRHT=PMAS(KCTC,1)**2
37296 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
37297 HS=SHR*WDTP(0)
37298 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
37299 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37300 ALPRHT=2.16D0*(3D0/ITCM(1))
37301 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
37302 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
37303 DO 310 I=MMIN1,MMAX1
37304 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
37305 IA=IABS(I)
37306 DO 300 J=MMIN2,MMAX2
37307 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
37308 JA=IABS(J)
37309 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
37310 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37311 & GOTO 300
37312 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37313 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
37314 HI=HP
37315 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37316 NCHN=NCHN+1
37317 ISIG(NCHN,1)=I
37318 ISIG(NCHN,2)=J
37319 ISIG(NCHN,3)=1
37320 SIGH(NCHN)=HI*FACBW*HF
37321 300 CONTINUE
37322 310 CONTINUE
37323
37324 ELSEIF(ISUB.EQ.193) THEN
37325C...q + qbar -> omega_tc0.
37326 KCTC=PYCOMP(KTECHN+223)
37327 SQMOMT=PMAS(KCTC,1)**2
37328 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
37329 HS=SHR*WDTP(0)
37330 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
37331 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37332 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37333 ALPRHT=2.16D0*(3D0/ITCM(1))
37334 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
37335 & (2D0*RTCM(2)-1D0)**2
37336 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
37337 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
37338 DO 320 I=MMINA,MMAXA
37339 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
37340 IA=IABS(I)
37341 EI=KCHG(IABS(I),1)/3D0
37342 AI=SIGN(1D0,EI+0.1D0)
37343 VI=AI-4D0*EI*XWV
37344 VALI=0.5D0*(VI+AI)
37345 VARI=0.5D0*(VI-AI)
37346 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
37347 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
37348 IF(IA.LE.10) HI=HI*FACA/3D0
37349 NCHN=NCHN+1
37350 ISIG(NCHN,1)=I
37351 ISIG(NCHN,2)=-I
37352 ISIG(NCHN,3)=1
37353 SIGH(NCHN)=HI*FACBW*HF
37354 320 CONTINUE
37355
37356 ELSEIF(ISUB.EQ.194) THEN
37357C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
37358C...Default final state is e+e-
37359 KFA=KFPR(ISUBSV,1)
37360 ALPRHT=2.16D0*(3D0/ITCM(1))
37361 HP=AEM**2*COMFAC
37362
37363 SN2W=2D0*SQRT(XW*XW1)
37364C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
37365C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
37366
37367 QUPD=2D0*RTCM(2)-1D0
37368 FAR=SQRT(AEM/ALPRHT)
37369 FAO=FAR*QUPD
37370 FZR=FAR*CT2W
37371 FZO=-FAO*TANW
37372C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37373 FZX=-FAR/SN2W*RTCM(47)
37374 SFAR=FAR**2
37375 SFAO=FAO**2
37376 SFZR=FZR**2
37377 SFZO=FZO**2
37378 SFZX=FZX**2
37379 CALL PYWIDT(23,SH,WDTP,WDTE)
37380 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
37381 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
37382 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
37383 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
37384 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
37385 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
37386 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
37387C...Propagator including a_T^0
37388 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
37389 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
37390C...Add in techni-a contribution
37391 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
37392 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
37393 $ SFZX*SSMR*SSMO)/DETD/SH
37394 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
37395 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
37396
37397 XWRHT=1D0/(4D0*XW*(1D0-XW))
37398 KFF=IABS(KFPR(ISUB,1))
37399 EF=KCHG(KFF,1)/3D0
37400 AF=SIGN(1D0,EF+0.1D0)
37401 VF=AF-4D0*EF*XWV
37402 VALF=0.5D0*(VF+AF)
37403 VARF=0.5D0*(VF-AF)
37404 FCOF=1D0
37405 IF(KFF.LE.10) FCOF=3D0
37406
37407 WID2=1D0
37408 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
37409 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
37410 DZZ=DZZ*DCMPLX(XWRHT,0D0)
37411 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
37412
37413 DO 330 I=MMINA,MMAXA
37414 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
37415 EI=KCHG(IABS(I),1)/3D0
37416 AI=SIGN(1D0,EI+0.1D0)
37417 VI=AI-4D0*EI*XWV
37418 VALI=0.5D0*(VI+AI)
37419 VARI=0.5D0*(VI-AI)
37420 FCOI=FCOF
37421 IF(IABS(I).LE.10) FCOI=FCOI/3D0
37422 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
37423 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
37424 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
37425 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
37426 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
37427 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
37428 NCHN=NCHN+1
37429 ISIG(NCHN,1)=I
37430 ISIG(NCHN,2)=-I
37431 ISIG(NCHN,3)=1
37432 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
37433 330 CONTINUE
37434
37435 ELSEIF(ISUB.EQ.195) THEN
37436C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
37437 KFA=KFPR(ISUBSV,1)
37438 KFB=KFA+1
37439 ALPRHT=2.16D0*(3D0/ITCM(1))
37440 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
37441
37442 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
37443C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37444C
37445C...Propagator including a_T^+
37446 FWX=-FWR*RTCM(47)
37447 CALL PYWIDT(24,SH,WDTP,WDTE)
37448 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
37449 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
37450 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
37451 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
37452 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
37453 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
37454 & DCMPLX(FWX**2,0D0)*SSMR
37455 DWW=SSMR*SSMX/DETD/SH
37456 FCOF=1D0
37457 IF(KFA.LE.8) FCOF=3D0
37458 HP=FACTC*ABS(DWW)**2*FCOF
37459
37460 DO 350 I=MMIN1,MMAX1
37461 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
37462 IA=IABS(I)
37463 DO 340 J=MMIN2,MMAX2
37464 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
37465 JA=IABS(J)
37466 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
37467 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37468 & GOTO 340
37469 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37470 HI=HP
37471 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
37472 NCHN=NCHN+1
37473 ISIG(NCHN,1)=I
37474 ISIG(NCHN,2)=J
37475 ISIG(NCHN,3)=1
37476 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
37477 340 CONTINUE
37478 350 CONTINUE
37479 ENDIF
37480
37481 ELSEIF(ISUB.LE.380) THEN
37482 ALPRHT=2.16D0*(3D0/ITCM(1))
37483 IF(ISUB.EQ.361) THEN
37484 FAR=SQRT(AEM/ALPRHT)
37485 FAO=FAR*QUPD
37486 FZR=FAR*CT2W
37487 FZO=-FAO*TANW
37488C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37489 FZX=-FAR/SN2W*RTCM(47)
37490 SFAR=FAR**2
37491 SFAO=FAO**2
37492 SFZR=FZR**2
37493 SFZO=FZO**2
37494 SFZX=FZX**2
37495 CALL PYWIDT(23,SH,WDTP,WDTE)
37496 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
37497 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
37498 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
37499 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
37500 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
37501 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
37502 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
37503 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
37504 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
37505C...Add in techni-a contribution
37506 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
37507 DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
37508 $ SFZX*FAR*SSMO)/DETD/SH
37509 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
37510 DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
37511 $ SFZX*FAO*SSMR)/DETD/SH
37512 DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
37513 DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
37514 DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
37515 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
37516 $ SFZX*SSMR*SSMO)/DETD/SH
37517 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
37518 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
37519
37520C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
37521C...W+W-, W pi_tc, pi_T pi_T, etc.
37522 FACA=(SH**2*BE34**2-(TH-UH)**2)
37523 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
37524 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
37525 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
37526 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
37527 DO 370 I=MMINA,MMAXA
37528 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
37529 IA=IABS(I)
37530 EI=KCHG(IABS(I),1)/3D0
37531 AI=SIGN(1D0,EI+0.1D0)
37532 VI=AI-4D0*EI*XWV
37533 VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
37534 VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
37535C...........Eqs. (5) and (6) in LSTC-rates.pdf
37536 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
37537 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
37538 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
37539 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
37540 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
37541 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
37542 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
37543 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
37544 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
37545 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
37546 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
37547C...........Eqs. (5) and (7) in LSTC-rates.pdf
37548 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
37549 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
37550 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
37551 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
37552 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
37553 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
37554 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
37555C
37556C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
37557C
37558c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
37559c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
37560c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
37561c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
37562 F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
37563 F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
37564 HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
37565 HI=HI+HJ+HK
37566 IF(IA.LE.10) HI=HI/3D0
37567 NCHN=NCHN+1
37568 ISIG(NCHN,1)=I
37569 ISIG(NCHN,2)=-I
37570 ISIG(NCHN,3)=1
37571 IF(KFA.EQ.KFB) THEN
37572 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
37573 ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
37574 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
37575 NCHN=NCHN+1
37576 ISIG(NCHN,1)=I
37577 ISIG(NCHN,2)=-I
37578 ISIG(NCHN,3)=2
37579 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
37580 ELSE
37581 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
37582 ENDIF
37583 370 CONTINUE
37584
37585 ELSEIF(ISUB.EQ.370) THEN
37586C...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
37587C...f + fbar' -> gamma pi_tc, etc.
37588 FACA=(SH**2*BE34**2-(TH-UH)**2)
37589 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
37590 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
37591 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
37592 ALPRHT=2.16D0*(3D0/ITCM(1))
37593 FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
37594 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
37595C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37596 FWX=-FWR*RTCM(47)
37597 CALL PYWIDT(24,SH,WDTP,WDTE)
37598 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
37599 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
37600 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
37601 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
37602 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
37603 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
37604 & DCMPLX(FWX**2,0D0)*SSMR
37605 DWW=SSMR*SSMX/DETD/SH
37606 DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
37607 DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
37608 HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
37609 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
37610C
37611C...........Eq. (25) in PRD67-115011 with DWW term dropped.
37612C
37613c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
37614 HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
37615C...Add in W_L Z_T axial and vector contributions.
37616 IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
37617 $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
37618 $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
37619 $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
37620 DO 410 I=MMIN1,MMAX1
37621 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
37622 IA=IABS(I)
37623 DO 400 J=MMIN2,MMAX2
37624 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
37625 JA=IABS(J)
37626 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
37627 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37628 & GOTO 400
37629 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37630 HI=HP
37631 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
37632 NCHN=NCHN+1
37633 ISIG(NCHN,1)=I
37634 ISIG(NCHN,2)=J
37635 ISIG(NCHN,3)=1
37636 IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
37637 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
37638 ELSE
37639 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
37640 & WIDS(PYCOMP(KFB),2)
37641 ENDIF
37642 400 CONTINUE
37643 410 CONTINUE
37644 ENDIF
37645
37646 ELSEIF(ISUB.LE.390) THEN
37647 IF(ISUB.EQ.381) THEN
37648C...f + f' -> f + f' (g exchange)
37649 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
37650 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
37651 & MSTP(34)*2D0/3D0*UH2*REDQST)
37652 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
37653 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
37654 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
37655 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
37656C...Modifications from contact interactions (compositeness)
37657 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
37658 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
37659 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
37660 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
37661 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
37662 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
37663 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
37664 ELSEIF(ITCM(5).EQ.5) THEN
37665 FACCI1=FACQQ1
37666 FACCIB=FACQQB
37667 FACCI2=FACQQ2
37668 FACCI3=FACQQ1
37669CSM.......Check this change from
37670CSM RATCII=1D0
37671 RATCII=RATQQI
37672 ENDIF
37673 DO 430 I=MMIN1,MMAX1
37674 IA=IABS(I)
37675 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
37676 DO 420 J=MMIN2,MMAX2
37677 JA=IABS(J)
37678 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
37679 NCHN=NCHN+1
37680 ISIG(NCHN,1)=I
37681 ISIG(NCHN,2)=J
37682 ISIG(NCHN,3)=1
37683 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
37684 & JA.GE.3))) THEN
37685 SIGH(NCHN)=FACQQ1
37686 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
37687 ELSE
37688 SIGH(NCHN)=FACCI1
37689 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
37690 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
37691 ENDIF
37692 IF(I.EQ.J) THEN
37693 NCHN=NCHN+1
37694 ISIG(NCHN,1)=I
37695 ISIG(NCHN,2)=J
37696 ISIG(NCHN,3)=2
37697 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
37698 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
37699 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
37700 ELSE
37701 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
37702 SIGH(NCHN)=0.5D0*FACCI2*RATCII
37703 ENDIF
37704 ENDIF
37705 420 CONTINUE
37706 430 CONTINUE
37707
37708 ELSEIF(ISUB.EQ.382) THEN
37709C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
37710 CALL PYWIDT(21,SH,WDTP,WDTE)
37711 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
37712 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37713 IF(ITCM(5).EQ.1) THEN
37714C...Modifications from contact interactions (compositeness)
37715 FACCIB=FACQQB
37716 DO 440 I=1,2
37717 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
37718 & WDTE(I,2)+WDTE(I,4))
37719 440 CONTINUE
37720 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
37721 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
37722 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37723 ELSEIF(ITCM(5).EQ.5) THEN
37724 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
37725 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
37726 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
37727 ENDIF
37728 DO 450 I=MMINA,MMAXA
37729 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37730 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
37731 NCHN=NCHN+1
37732 ISIG(NCHN,1)=I
37733 ISIG(NCHN,2)=-I
37734 ISIG(NCHN,3)=1
37735 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
37736 SIGH(NCHN)=FACQQB
37737 ELSEIF(ITCM(5).EQ.5) THEN
37738 SIGH(NCHN)=FACQQB
37739 NCHN=NCHN+1
37740 ISIG(NCHN,1)=I
37741 ISIG(NCHN,2)=-I
37742 ISIG(NCHN,3)=2
37743 SIGH(NCHN)=FACCIB
37744 ELSE
37745 SIGH(NCHN)=FACCIB
37746 ENDIF
37747 450 CONTINUE
37748
37749 ELSEIF(ISUB.EQ.383) THEN
37750C...f + fbar -> g + g (q + qbar -> g + g only)
37751 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37752 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37753 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37754 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37755 IF(ITCM(5).EQ.5) THEN
37756 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37757 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37758 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37759 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37760 ENDIF
37761 DO 460 I=MMINA,MMAXA
37762 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37763 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
37764 NCHN=NCHN+1
37765 ISIG(NCHN,1)=I
37766 ISIG(NCHN,2)=-I
37767 ISIG(NCHN,3)=1
37768 SIGH(NCHN)=0.5D0*FACGG1
37769 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
37770 NCHN=NCHN+1
37771 ISIG(NCHN,1)=I
37772 ISIG(NCHN,2)=-I
37773 ISIG(NCHN,3)=2
37774 SIGH(NCHN)=0.5D0*FACGG2
37775 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
37776 460 CONTINUE
37777
37778 ELSEIF(ISUB.EQ.384) THEN
37779C...f + g -> f + g (q + g -> q + g only)
37780 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
37781 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
37782 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
37783 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
37784 DO 480 I=MMINA,MMAXA
37785 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
37786 DO 470 ISDE=1,2
37787 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
37788 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
37789 NCHN=NCHN+1
37790 ISIG(NCHN,ISDE)=I
37791 ISIG(NCHN,3-ISDE)=21
37792 ISIG(NCHN,3)=1
37793 SIGH(NCHN)=FACQG1
37794 NCHN=NCHN+1
37795 ISIG(NCHN,ISDE)=I
37796 ISIG(NCHN,3-ISDE)=21
37797 ISIG(NCHN,3)=2
37798 SIGH(NCHN)=FACQG2
37799 470 CONTINUE
37800 480 CONTINUE
37801
37802 ELSEIF(ISUB.EQ.385) THEN
37803C...g + g -> f + fbar (g + g -> q + qbar only)
37804 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
37805 IDC0=MDCY(21,2)-1
37806C...Begin by d, u, s flavours.
37807 FLAVWT=0D0
37808 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
37809 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
37810 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
37811 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
37812 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
37813 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
37814 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37815 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37816 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37817 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37818 NCHN=NCHN+1
37819 ISIG(NCHN,1)=21
37820 ISIG(NCHN,2)=21
37821 ISIG(NCHN,3)=1
37822 SIGH(NCHN)=FACQQ1
37823 NCHN=NCHN+1
37824 ISIG(NCHN,1)=21
37825 ISIG(NCHN,2)=21
37826 ISIG(NCHN,3)=2
37827 SIGH(NCHN)=FACQQ2
37828C...Next c and b flavours: modified that and uhat for fixed
37829C...cos(theta-hat).
37830 DO 490 IFL=4,5
37831 SQMAVG=PMAS(IFL,1)**2
37832 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
37833 BE34=SQRT(1D0-4D0*SQMAVG/SH)
37834 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37835 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37836 THUHQ=THQ*UHQ-SQMAVG*SH
37837 IF(MSTP(34).EQ.0) THEN
37838 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37839 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37840 ELSE
37841 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37842 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37843 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37844 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37845 ENDIF
37846 IF(ITCM(5).GE.5) THEN
37847 IF(IFL.EQ.4) THEN
37848 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37849 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37850 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37851 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37852 ELSE
37853 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37854 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37855 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37856 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37857 ENDIF
37858 ENDIF
37859 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
37860 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
37861 NCHN=NCHN+1
37862 ISIG(NCHN,1)=21
37863 ISIG(NCHN,2)=21
37864 ISIG(NCHN,3)=1+2*(IFL-3)
37865 SIGH(NCHN)=FACQQ1
37866 NCHN=NCHN+1
37867 ISIG(NCHN,1)=21
37868 ISIG(NCHN,2)=21
37869 ISIG(NCHN,3)=2+2*(IFL-3)
37870 SIGH(NCHN)=FACQQ2
37871 ENDIF
37872 490 CONTINUE
37873 500 CONTINUE
37874
37875 ELSEIF(ISUB.EQ.386) THEN
37876C...g + g -> g + g
37877 IF(ITCM(5).LE.4) THEN
37878 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
37879 & 2D0*TH/SH+TH2/SH2)*FACA
37880 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
37881 & 2D0*SH/UH+SH2/UH2)*FACA
37882 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
37883 & 2D0*UH/TH+UH2/TH2)
37884 ELSE
37885 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
37886 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
37887 & 4D0*REDGST*(SH + 2D0*TH)*
37888 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
37889 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
37890 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
37891 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
37892 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
37893 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
37894 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
37895 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
37896 & 4D0*REDGSU*(SH + 2D0*UH)*
37897 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
37898 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
37899 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
37900 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
37901 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
37902 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
37903 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
37904 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
37905 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
37906 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
37907 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
37908 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
37909 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
37910 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
37911 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
37912 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
37913 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
37914 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
37915 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
37916 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
37917 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
37918 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
37919 ENDIF
37920 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
37921 NCHN=NCHN+1
37922 ISIG(NCHN,1)=21
37923 ISIG(NCHN,2)=21
37924 ISIG(NCHN,3)=1
37925 SIGH(NCHN)=0.5D0*FACGG1
37926 NCHN=NCHN+1
37927 ISIG(NCHN,1)=21
37928 ISIG(NCHN,2)=21
37929 ISIG(NCHN,3)=2
37930 SIGH(NCHN)=0.5D0*FACGG2
37931 NCHN=NCHN+1
37932 ISIG(NCHN,1)=21
37933 ISIG(NCHN,2)=21
37934 ISIG(NCHN,3)=3
37935 SIGH(NCHN)=0.5D0*FACGG3
37936 510 CONTINUE
37937
37938 ELSEIF(ISUB.EQ.387) THEN
37939C...q + qbar -> Q + Qbar
37940 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37941 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37942 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37943 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
37944 & 2D0*SQMAVG/SH)
37945 IF(ITCM(5).GE.5) THEN
37946 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37947 FACQQB=FACQQB*SH2*SQDQTS
37948 ELSE
37949 FACQQB=FACQQB*SH2*SQDQQS
37950 ENDIF
37951 ENDIF
37952 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
37953 WID2=1D0
37954 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37955 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37956 FACQQB=FACQQB*WID2
37957 DO 520 I=MMINA,MMAXA
37958 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37959 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
37960 NCHN=NCHN+1
37961 ISIG(NCHN,1)=I
37962 ISIG(NCHN,2)=-I
37963 ISIG(NCHN,3)=1
37964 SIGH(NCHN)=FACQQB
37965 520 CONTINUE
37966
37967 ELSEIF(ISUB.EQ.388) THEN
37968C...g + g -> Q + Qbar
37969 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37970 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37971 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37972 THUHQ=THQ*UHQ-SQMAVG*SH
37973 IF(MSTP(34).EQ.0) THEN
37974 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37975 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37976 ELSE
37977 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37978 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37979 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37980 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37981 ENDIF
37982 IF(ITCM(5).GE.5) THEN
37983 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37984 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37985 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37986 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37987 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37988 ELSE
37989 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37990 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37991 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37992 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37993 ENDIF
37994 ENDIF
37995 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
37996 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
37997 IF(MSTP(35).GE.1) THEN
37998 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
37999 FACQQ1=FACQQ1*FATRE
38000 FACQQ2=FACQQ2*FATRE
38001 ENDIF
38002 WID2=1D0
38003 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
38004 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
38005 FACQQ1=FACQQ1*WID2
38006 FACQQ2=FACQQ2*WID2
38007 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
38008 NCHN=NCHN+1
38009 ISIG(NCHN,1)=21
38010 ISIG(NCHN,2)=21
38011 ISIG(NCHN,3)=1
38012 SIGH(NCHN)=FACQQ1
38013 NCHN=NCHN+1
38014 ISIG(NCHN,1)=21
38015 ISIG(NCHN,2)=21
38016 ISIG(NCHN,3)=2
38017 SIGH(NCHN)=FACQQ2
38018 530 CONTINUE
38019 ENDIF
38020 ENDIF
38021
38022CMRENNA--
38023
38024 RETURN
38025 END
38026
38027C*********************************************************************
38028
38029C...PYSGEX
38030C...Subprocess cross sections for assorted exotic processes,
38031C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
38032C...Auxiliary to PYSIGH.
38033
38034 SUBROUTINE PYSGEX(NCHN,SIGS)
38035
38036C...Double precision and integer declarations
38037 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38038 IMPLICIT INTEGER(I-N)
38039 INTEGER PYK,PYCHGE,PYCOMP
38040C...Parameter statement to help give large particle numbers.
38041 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38042 &KEXCIT=4000000,KDIMEN=5000000)
38043C...Commonblocks
38044 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38045 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38046 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
38047 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38048 COMMON/PYINT1/MINT(400),VINT(400)
38049 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
38050 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
38051 COMMON/PYINT4/MWID(500),WIDS(500,5)
38052 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
38053 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
38054 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
38055 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
38056 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
38057 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
38058 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
38059C...Local arrays
38060 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
38061
38062C...Differential cross section expressions.
38063
38064 IF(ISUB.LE.160) THEN
38065 IF(ISUB.EQ.141) THEN
38066C...f + fbar -> gamma*/Z0/Z'0
38067 SQMZP=PMAS(32,1)**2
38068 MINT(61)=2
38069 CALL PYWIDT(32,SH,WDTP,WDTE)
38070 HP0=AEM/3D0*SH
38071 HP1=AEM/3D0*XWC*SH
38072 HP2=HP1
38073 HS=SHR*VINT(117)
38074 HSP=SHR*WDTP(0)
38075 FACZP=4D0*COMFAC*3D0
38076 DO 100 I=MMINA,MMAXA
38077 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
38078 EI=KCHG(IABS(I),1)/3D0
38079 AI=SIGN(1D0,EI)
38080 VI=AI-4D0*EI*XWV
38081 IA=IABS(I)
38082 IF(IA.LT.10) THEN
38083 IF(IA.LE.2) THEN
38084 VPI=PARU(123-2*MOD(IABS(I),2))
38085 API=PARU(124-2*MOD(IABS(I),2))
38086 ELSEIF(IA.LE.4) THEN
38087 VPI=PARJ(182-2*MOD(IABS(I),2))
38088 API=PARJ(183-2*MOD(IABS(I),2))
38089 ELSE
38090 VPI=PARJ(190-2*MOD(IABS(I),2))
38091 API=PARJ(191-2*MOD(IABS(I),2))
38092 ENDIF
38093 ELSE
38094 IF(IA.LE.12) THEN
38095 VPI=PARU(127-2*MOD(IABS(I),2))
38096 API=PARU(128-2*MOD(IABS(I),2))
38097 ELSEIF(IA.LE.14) THEN
38098 VPI=PARJ(186-2*MOD(IABS(I),2))
38099 API=PARJ(187-2*MOD(IABS(I),2))
38100 ELSE
38101 VPI=PARJ(194-2*MOD(IABS(I),2))
38102 API=PARJ(195-2*MOD(IABS(I),2))
38103 ENDIF
38104 ENDIF
38105 HI0=HP0
38106 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
38107 HI1=HP1
38108 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
38109 HI2=HP2
38110 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
38111 NCHN=NCHN+1
38112 ISIG(NCHN,1)=I
38113 ISIG(NCHN,2)=-I
38114 ISIG(NCHN,3)=1
38115C...Special case: if only branching ratios known then use them.
38116 IF(MWID(32).EQ.2.AND.MSTP(44).EQ.3) THEN
38117 HI=0D0
38118 IF(IA.LT.10) THEN
38119 HI=SHR*WDTP(IA)*FACA/9D0
38120 ELSEIF(IA.LT.20) THEN
38121 HI=SHR*WDTP(IA-2)
38122 ENDIF
38123 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38124 SIGH(NCHN)=HI*FACZP*HF/((SH-SQMZP)**2+HSP**2)
38125 ELSE
38126C...Normal cross section.
38127 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
38128 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
38129 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
38130 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
38131 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
38132 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
38133 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
38134 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
38135 ENDIF
38136 100 CONTINUE
38137
38138 ELSEIF(ISUB.EQ.142) THEN
38139C...f + fbar' -> W'+/-
38140 SQMWP=PMAS(34,1)**2
38141 CALL PYWIDT(34,SH,WDTP,WDTE)
38142 HS=SHR*WDTP(0)
38143 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
38144 HP=AEM/(24D0*XW)*SH
38145 DO 120 I=MMIN1,MMAX1
38146 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
38147 IA=IABS(I)
38148 DO 110 J=MMIN2,MMAX2
38149 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
38150 JA=IABS(J)
38151 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
38152 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
38153 & GOTO 110
38154 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38155C...Special case: if only branching ratios known then use them.
38156 IF(MWID(34).EQ.2) THEN
38157 HI=0D0
38158 DO 105 IDC=MDCY(34,2),MDCY(34,2)+MDCY(34,3)-1
38159 IF((IA.EQ.IABS(KFDP(IDC,1)).AND.JA.EQ.
38160 & IABS(KFDP(IDC,2))).OR.(IA.EQ.IABS(KFDP(IDC,2))
38161 & .AND.JA.EQ.IABS(KFDP(IDC,1))))
38162 & HI=SHR*WDTP(IDC+1-MDCY(34,2))
38163 105 CONTINUE
38164 IF(IA.LT.10) HI=HI*FACA/9D0
38165 ELSE
38166C...Normal cross section.
38167 HI=HP*(PARU(133)**2+PARU(134)**2)
38168 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
38169 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
38170 ENDIF
38171 NCHN=NCHN+1
38172 ISIG(NCHN,1)=I
38173 ISIG(NCHN,2)=J
38174 ISIG(NCHN,3)=1
38175 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
38176 SIGH(NCHN)=HI*FACBW*HF
38177 110 CONTINUE
38178 120 CONTINUE
38179
38180 ELSEIF(ISUB.EQ.144) THEN
38181C...f + fbar' -> R
38182 SQMR=PMAS(41,1)**2
38183 CALL PYWIDT(41,SH,WDTP,WDTE)
38184 HS=SHR*WDTP(0)
38185 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
38186 HP=AEM/(12D0*XW)*SH
38187 DO 140 I=MMIN1,MMAX1
38188 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
38189 IA=IABS(I)
38190 DO 130 J=MMIN2,MMAX2
38191 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
38192 JA=IABS(J)
38193 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
38194 HI=HP
38195 IF(IA.LE.10) HI=HI*FACA/3D0
38196 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
38197 NCHN=NCHN+1
38198 ISIG(NCHN,1)=I
38199 ISIG(NCHN,2)=J
38200 ISIG(NCHN,3)=1
38201 SIGH(NCHN)=HI*FACBW*HF
38202 130 CONTINUE
38203 140 CONTINUE
38204
38205 ELSEIF(ISUB.EQ.145) THEN
38206C...q + l -> LQ (leptoquark)
38207 SQMLQ=PMAS(42,1)**2
38208 CALL PYWIDT(42,SH,WDTP,WDTE)
38209 HS=SHR*WDTP(0)
38210 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
38211 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
38212 HP=AEM/4D0*SH
38213 KFLQQ=KFDP(MDCY(42,2),1)
38214 KFLQL=KFDP(MDCY(42,2),2)
38215 DO 160 I=MMIN1,MMAX1
38216 IF(KFAC(1,I).EQ.0) GOTO 160
38217 IA=IABS(I)
38218 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
38219 DO 150 J=MMIN2,MMAX2
38220 IF(KFAC(2,J).EQ.0) GOTO 150
38221 JA=IABS(J)
38222 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
38223 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
38224 IF(JA.EQ.IA) GOTO 150
38225 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
38226 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
38227 HI=HP*PARU(151)
38228 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
38229 NCHN=NCHN+1
38230 ISIG(NCHN,1)=I
38231 ISIG(NCHN,2)=J
38232 ISIG(NCHN,3)=1
38233 SIGH(NCHN)=HI*FACBW*HF
38234 150 CONTINUE
38235 160 CONTINUE
38236
38237 ELSEIF(ISUB.EQ.146) THEN
38238C...e + gamma* -> e* (excited lepton)
38239 KFQSTR=KFPR(ISUB,1)
38240 KCQSTR=PYCOMP(KFQSTR)
38241 KFQEXC=MOD(KFQSTR,KEXCIT)
38242 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
38243 HS=SHR*WDTP(0)
38244 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
38245 QF=-RTCM(43)/2D0-RTCM(44)/2D0
38246 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
38247 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
38248 & FACBW=0D0
38249 HP=SH
38250 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
38251 DO 170 ISDE=1,2
38252 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
38253 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
38254 HI=HP
38255 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38256 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
38257 NCHN=NCHN+1
38258 ISIG(NCHN,ISDE)=I
38259 ISIG(NCHN,3-ISDE)=22
38260 ISIG(NCHN,3)=1
38261 SIGH(NCHN)=HI*FACBW*HF
38262 170 CONTINUE
38263 180 CONTINUE
38264
38265 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
38266C...d + g -> d* and u + g -> u* (excited quarks)
38267 KFQSTR=KFPR(ISUB,1)
38268 KCQSTR=PYCOMP(KFQSTR)
38269 KFQEXC=MOD(KFQSTR,KEXCIT)
38270 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
38271 HS=SHR*WDTP(0)
38272 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
38273 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
38274 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
38275 & FACBW=0D0
38276 HP=SH
38277 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
38278 DO 190 ISDE=1,2
38279 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
38280 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
38281 HI=HP
38282 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38283 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
38284 NCHN=NCHN+1
38285 ISIG(NCHN,ISDE)=I
38286 ISIG(NCHN,3-ISDE)=21
38287 ISIG(NCHN,3)=1
38288 SIGH(NCHN)=HI*FACBW*HF
38289 190 CONTINUE
38290 200 CONTINUE
38291 ENDIF
38292
38293 ELSEIF(ISUB.LE.190) THEN
38294 IF(ISUB.EQ.162) THEN
38295C...q + g -> LQ + lbar; LQ=leptoquark
38296 SQMLQ=PMAS(42,1)**2
38297 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
38298 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
38299 KFLQQ=KFDP(MDCY(42,2),1)
38300 DO 220 I=MMINA,MMAXA
38301 IF(IABS(I).NE.KFLQQ) GOTO 220
38302 KCHLQ=ISIGN(1,I)
38303 DO 210 ISDE=1,2
38304 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
38305 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
38306 NCHN=NCHN+1
38307 ISIG(NCHN,ISDE)=I
38308 ISIG(NCHN,3-ISDE)=21
38309 ISIG(NCHN,3)=1
38310 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
38311 210 CONTINUE
38312 220 CONTINUE
38313
38314 ELSEIF(ISUB.EQ.163) THEN
38315C...g + g -> LQ + LQbar; LQ=leptoquark
38316 SQMLQ=PMAS(42,1)**2
38317 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
38318 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
38319 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
38320 & ((TH-SQMLQ)*(UH-SQMLQ)))
38321 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
38322 NCHN=NCHN+1
38323 ISIG(NCHN,1)=21
38324 ISIG(NCHN,2)=21
38325C...Since don't know proper colour flow, randomize between alternatives
38326 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
38327 SIGH(NCHN)=FACLQ
38328 230 CONTINUE
38329
38330 ELSEIF(ISUB.EQ.164) THEN
38331C...q + qbar -> LQ + LQbar; LQ=leptoquark
38332 DELTA=0.25D0*(SQM3-SQM4)**2/SH
38333 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
38334 TH=TH-DELTA
38335 UH=UH-DELTA
38336C SQMLQ=PMAS(42,1)**2
38337 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
38338 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
38339 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
38340 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
38341 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
38342 KFLQQ=KFDP(MDCY(42,2),1)
38343 DO 240 I=MMINA,MMAXA
38344 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
38345 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
38346 NCHN=NCHN+1
38347 ISIG(NCHN,1)=I
38348 ISIG(NCHN,2)=-I
38349 ISIG(NCHN,3)=1
38350 SIGH(NCHN)=FACLQA
38351 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
38352 240 CONTINUE
38353
38354 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
38355C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
38356 KFQSTR=KFPR(ISUB,2)
38357 KCQSTR=PYCOMP(KFQSTR)
38358 KFQEXC=MOD(KFQSTR,KEXCIT)
38359 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
38360 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
38361 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
38362C...Propagators: as simulated in PYOFSH and as desired
38363 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
38364 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
38365 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
38366 GMMQC=SQRT(SQM4)*WDTP(0)
38367 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
38368 FACQSA=FACQSA*HBW4C/HBW4
38369 FACQSB=FACQSB*HBW4C/HBW4
38370C...Branching ratios.
38371 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
38372 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
38373 DO 260 I=MMIN1,MMAX1
38374 IA=IABS(I)
38375 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
38376 DO 250 J=MMIN2,MMAX2
38377 JA=IABS(J)
38378 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
38379 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
38380 NCHN=NCHN+1
38381 ISIG(NCHN,1)=I
38382 ISIG(NCHN,2)=J
38383 ISIG(NCHN,3)=1
38384 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
38385 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
38386 NCHN=NCHN+1
38387 ISIG(NCHN,1)=I
38388 ISIG(NCHN,2)=J
38389 ISIG(NCHN,3)=2
38390 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
38391 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
38392 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
38393 NCHN=NCHN+1
38394 ISIG(NCHN,1)=I
38395 ISIG(NCHN,2)=J
38396 ISIG(NCHN,3)=1
38397 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
38398 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
38399 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
38400 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
38401 NCHN=NCHN+1
38402 ISIG(NCHN,1)=I
38403 ISIG(NCHN,2)=J
38404 ISIG(NCHN,3)=1
38405 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
38406 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
38407 NCHN=NCHN+1
38408 ISIG(NCHN,1)=I
38409 ISIG(NCHN,2)=J
38410 ISIG(NCHN,3)=2
38411 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
38412 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
38413 ELSEIF(I.EQ.-J) THEN
38414 NCHN=NCHN+1
38415 ISIG(NCHN,1)=I
38416 ISIG(NCHN,2)=J
38417 ISIG(NCHN,3)=1
38418 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38419 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38420 NCHN=NCHN+1
38421 ISIG(NCHN,1)=I
38422 ISIG(NCHN,2)=J
38423 ISIG(NCHN,3)=2
38424 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38425 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38426 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
38427 NCHN=NCHN+1
38428 ISIG(NCHN,1)=I
38429 ISIG(NCHN,2)=J
38430 ISIG(NCHN,3)=1
38431 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
38432 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
38433 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
38434 ENDIF
38435 250 CONTINUE
38436 260 CONTINUE
38437
38438 ELSEIF(ISUB.EQ.169) THEN
38439C...q + qbar -> e + e* (excited lepton)
38440 KFQSTR=KFPR(ISUB,2)
38441 KCQSTR=PYCOMP(KFQSTR)
38442 KFQEXC=MOD(KFQSTR,KEXCIT)
38443 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
38444 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
38445C...Propagators: as simulated in PYOFSH and as desired
38446 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
38447 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
38448 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
38449 GMMQC=SQRT(SQM4)*WDTP(0)
38450 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
38451 FACQSB=FACQSB*HBW4C/HBW4
38452C...Branching ratios.
38453 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
38454 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
38455 DO 270 I=MMIN1,MMAX1
38456 IA=IABS(I)
38457 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
38458 J=-I
38459 JA=IABS(J)
38460 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
38461 NCHN=NCHN+1
38462 ISIG(NCHN,1)=I
38463 ISIG(NCHN,2)=J
38464 ISIG(NCHN,3)=1
38465 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38466 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38467 NCHN=NCHN+1
38468 ISIG(NCHN,1)=I
38469 ISIG(NCHN,2)=J
38470 ISIG(NCHN,3)=2
38471 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38472 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38473 270 CONTINUE
38474 ENDIF
38475
38476 ELSEIF(ISUB.LE.360) THEN
38477 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
38478C...l + l -> H_L++/-- or H_R++/--.
38479 KFRES=KFPR(ISUB,1)
38480 KFREC=PYCOMP(KFRES)
38481 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
38482 HS=SHR*WDTP(0)
38483 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
38484 DO 290 I=MMIN1,MMAX1
38485 IA=IABS(I)
38486 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
38487 & GOTO 290
38488 DO 280 J=MMIN2,MMAX2
38489 JA=IABS(J)
38490 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
38491 & GOTO 280
38492 IF(I*J.LT.0) GOTO 280
38493 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38494 NCHN=NCHN+1
38495 ISIG(NCHN,1)=I
38496 ISIG(NCHN,2)=J
38497 ISIG(NCHN,3)=1
38498 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
38499 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
38500 SIGH(NCHN)=HI*FACBW*HF
38501 280 CONTINUE
38502 290 CONTINUE
38503
38504 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
38505C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
38506 KFRES=KFPR(ISUB,1)
38507 KFREC=PYCOMP(KFRES)
38508C...Propagators: as simulated in PYOFSH and as desired
38509 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
38510 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
38511 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
38512 GMMC=SQRT(SQM3)*WDTP(0)
38513 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
38514 FHCC=COMFAC*AEM*HBW3C/HBW3
38515 DO 310 I=MMINA,MMAXA
38516 IA=IABS(I)
38517 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
38518 SQML=PMAS(IA,1)**2
38519 J=ISIGN(KFPR(ISUB,2),-I)
38520 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
38521 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
38522 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
38523 & (UH-SQM3)**2
38524 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
38525 & (TH-SQM4)*SH)/(TH-SQM4)**2
38526 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
38527 & SH)/(SH-SQML)**2
38528 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
38529 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
38530 & ((UH-SQM3)*(TH-SQM4))
38531 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
38532 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
38533 & ((UH-SQM3)*(SH-SQML))
38534 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
38535 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
38536 & ((SH-SQML)*(TH-SQM4))
38537 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
38538 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
38539 DO 300 ISDE=1,2
38540 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
38541 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
38542 NCHN=NCHN+1
38543 ISIG(NCHN,ISDE)=I
38544 ISIG(NCHN,3-ISDE)=22
38545 ISIG(NCHN,3)=0
38546 SIGH(NCHN)=FHCC*SMM*WIDSC
38547 300 CONTINUE
38548 310 CONTINUE
38549
38550 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
38551C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
38552 KFRES=KFPR(ISUB,1)
38553 KFREC=PYCOMP(KFRES)
38554 SQMH=PMAS(KFREC,1)**2
38555 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
38556C...Propagators: H++/-- as simulated in PYOFSH and as desired
38557 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
38558 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
38559 GMMH3=SQRT(SQM3)*WDTP(0)
38560 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
38561 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
38562 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
38563 GMMH4=SQRT(SQM4)*WDTP(0)
38564 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
38565C...Kinematical and coupling functions
38566 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
38567 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
38568C...Loop over allowed flavours
38569 DO 320 I=MMINA,MMAXA
38570 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
38571 EI=KCHG(IABS(I),1)/3D0
38572 AI=SIGN(1D0,EI+0.1D0)
38573 VI=AI-4D0*EI*XWV
38574 FCOI=1D0
38575 IF(IABS(I).LE.10) FCOI=FACA/3D0
38576 IF(ISUB.EQ.349) THEN
38577 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
38578 IF(IABS(I).LT.10) THEN
38579 DSIGHH=8D0*AEM**2*(EI**2/SH2+
38580 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
38581 & (VI**2+AI**2)*XWHH**2*HBWZ)
38582 ELSE
38583 IAOFF=181+3*((IABS(I)-11)/2)
38584 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
38585 & (4D0*PARU(1))
38586 DSIGHH=8D0*AEM**2*(EI**2/SH2+
38587 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
38588 & (VI**2+AI**2)*XWHH**2*HBWZ)+
38589 & 8D0*AEM*(EI*HSUM/(SH*TH)+
38590 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
38591 & 4D0*HSUM**2/TH2
38592 ENDIF
38593 ELSE
38594 IF(IABS(I).LT.10) THEN
38595 DSIGHH=8D0*AEM**2*EI**2/SH2
38596 ELSE
38597 IAOFF=181+3*((IABS(I)-11)/2)
38598 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
38599 & (4D0*PARU(1))
38600 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
38601 & 4D0*HSUM**2/TH2
38602 ENDIF
38603 ENDIF
38604 NCHN=NCHN+1
38605 ISIG(NCHN,1)=I
38606 ISIG(NCHN,2)=-I
38607 ISIG(NCHN,3)=1
38608 SIGH(NCHN)=FACHH*FCOI*DSIGHH
38609 320 CONTINUE
38610
38611 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
38612C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
38613 KFRES=KFPR(ISUB,1)
38614 KFREC=PYCOMP(KFRES)
38615 SQMH=PMAS(KFREC,1)**2
38616 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
38617 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
38618 & PMAS(PYCOMP(9900024),1)**2
38619 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
38620 FACPRT=1D0/((VINT(204)**2-VINT(215))*
38621 & (VINT(209)**2-VINT(216)))
38622 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
38623 & (VINT(209)**2+2D0*VINT(218)))
38624 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
38625 HS=SHR*WDTP(0)
38626 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
38627 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
38628 & FACBW=0D0
38629 DO 340 I=MMIN1,MMAX1
38630 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
38631 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
38632 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
38633 DO 330 J=MMIN2,MMAX2
38634 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
38635 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
38636 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
38637 KCHH=KCHWI+KCHWJ
38638 IF(IABS(KCHH).NE.2) GOTO 330
38639 FACLR=VINT(180+I)*VINT(180+J)
38640 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
38641 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
38642 FACPRP=0.5D0*(FACPRT+FACPRU)**2
38643 ELSE
38644 FACPRP=FACPRT**2
38645 ENDIF
38646 NCHN=NCHN+1
38647 ISIG(NCHN,1)=I
38648 ISIG(NCHN,2)=J
38649 ISIG(NCHN,3)=1
38650 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
38651 330 CONTINUE
38652 340 CONTINUE
38653
38654 ELSEIF(ISUB.EQ.353) THEN
38655C...f + fbar -> Z_R0
38656 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
38657 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
38658 HS=SHR*WDTP(0)
38659 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
38660 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38661 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
38662 DO 350 I=MMINA,MMAXA
38663 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
38664 IF(IABS(I).LE.8) THEN
38665 EI=KCHG(IABS(I),1)/3D0
38666 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
38667 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
38668 ELSE
38669 AI=-(1D0-2D0*XW)
38670 VI=-1D0+4D0*XW
38671 ENDIF
38672 HI=HP*(VI**2+AI**2)
38673 IF(IABS(I).LE.10) HI=HI*FACA/3D0
38674 NCHN=NCHN+1
38675 ISIG(NCHN,1)=I
38676 ISIG(NCHN,2)=-I
38677 ISIG(NCHN,3)=1
38678 SIGH(NCHN)=HI*FACBW*HF
38679 350 CONTINUE
38680
38681 ELSEIF(ISUB.EQ.354) THEN
38682C...f + fbar' -> W_R+/-
38683 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
38684 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
38685 HS=SHR*WDTP(0)
38686 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
38687 HP=AEM/(24D0*XW)*SH
38688 DO 370 I=MMIN1,MMAX1
38689 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
38690 IA=IABS(I)
38691 DO 360 J=MMIN2,MMAX2
38692 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
38693 JA=IABS(J)
38694 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
38695 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
38696 & GOTO 360
38697 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38698 HI=HP*2D0
38699 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
38700 NCHN=NCHN+1
38701 ISIG(NCHN,1)=I
38702 ISIG(NCHN,2)=J
38703 ISIG(NCHN,3)=1
38704 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
38705 SIGH(NCHN)=HI*FACBW*HF
38706 360 CONTINUE
38707 370 CONTINUE
38708 ENDIF
38709
38710 ELSEIF(ISUB.LE.400) THEN
38711 IF(ISUB.EQ.391) THEN
38712C...f + fbar -> G*.
38713 KFGSTR=KFPR(ISUB,1)
38714 KCGSTR=PYCOMP(KFGSTR)
38715 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38716 HS=SHR*WDTP(0)
38717 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38718 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
38719 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38720C...Modify cross section in wings of peak.
38721 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38722 DO 380 I=MMINA,MMAXA
38723 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
38724 HI=1D0
38725 IF(IABS(I).LE.10) HI=HI*FACA/3D0
38726 NCHN=NCHN+1
38727 ISIG(NCHN,1)=I
38728 ISIG(NCHN,2)=-I
38729 ISIG(NCHN,3)=1
38730 SIGH(NCHN)=FACG*HI
38731 380 CONTINUE
38732
38733 ELSEIF(ISUB.EQ.392) THEN
38734C...g + g -> G*.
38735 KFGSTR=KFPR(ISUB,1)
38736 KCGSTR=PYCOMP(KFGSTR)
38737 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38738 HS=SHR*WDTP(0)
38739 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38740 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
38741 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38742C...Modify cross section in wings of peak.
38743 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38744 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
38745 NCHN=NCHN+1
38746 ISIG(NCHN,1)=21
38747 ISIG(NCHN,2)=21
38748 ISIG(NCHN,3)=1
38749 SIGH(NCHN)=FACG
38750 390 CONTINUE
38751
38752 ELSEIF(ISUB.EQ.393) THEN
38753C...q + qbar -> g + G*.
38754 KFGSTR=KFPR(ISUB,2)
38755 KCGSTR=PYCOMP(KFGSTR)
38756 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
38757 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
38758 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
38759 & 2D0*SH2/(TH*UH))
38760C...Propagators: as simulated in PYOFSH and as desired
38761 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38762 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38763 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38764 HS=SQRT(SQM4)*WDTP(0)
38765 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38766 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38767 FACG=FACG*HBW4C/HBW4
38768 DO 400 I=MMINA,MMAXA
38769 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
38770 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
38771 NCHN=NCHN+1
38772 ISIG(NCHN,1)=I
38773 ISIG(NCHN,2)=-I
38774 ISIG(NCHN,3)=1
38775 SIGH(NCHN)=FACG
38776 400 CONTINUE
38777
38778 ELSEIF(ISUB.EQ.394) THEN
38779C...q + g -> q + G*.
38780 KFGSTR=KFPR(ISUB,2)
38781 KCGSTR=PYCOMP(KFGSTR)
38782 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
38783 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
38784 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
38785 & 2D0*TH2*TH/(UH*SH2))
38786C...Propagators: as simulated in PYOFSH and as desired
38787 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38788 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38789 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38790 HS=SQRT(SQM4)*WDTP(0)
38791 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38792 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38793 FACG=FACG*HBW4C/HBW4
38794 DO 420 I=MMINA,MMAXA
38795 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
38796 DO 410 ISDE=1,2
38797 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
38798 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
38799 NCHN=NCHN+1
38800 ISIG(NCHN,ISDE)=I
38801 ISIG(NCHN,3-ISDE)=21
38802 ISIG(NCHN,3)=1
38803 SIGH(NCHN)=FACG
38804 410 CONTINUE
38805 420 CONTINUE
38806
38807 ELSEIF(ISUB.EQ.395) THEN
38808C...g + g -> g + G*.
38809 KFGSTR=KFPR(ISUB,2)
38810 KCGSTR=PYCOMP(KFGSTR)
38811 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
38812 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
38813 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
38814C...Propagators: as simulated in PYOFSH and as desired
38815 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38816 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38817 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38818 HS=SQRT(SQM4)*WDTP(0)
38819 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38820 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38821 FACG=FACG*HBW4C/HBW4
38822 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
38823 NCHN=NCHN+1
38824 ISIG(NCHN,1)=21
38825 ISIG(NCHN,2)=21
38826 ISIG(NCHN,3)=1
38827 SIGH(NCHN)=FACG
38828 ENDIF
38829 ENDIF
38830 ELSEIF(ISUB.LE.500) THEN
38831 IF(ISUBSV.EQ.481) ISUB=482
38832c... GENERIC 2->(1)->2
38833 IF(ISUB.EQ.482) THEN
38834 KFRES=9900001
38835 KCRES=PYCOMP(KFRES)
38836 IF(KCRES.EQ.0) RETURN
38837 IDCY=MDCY(KCRES,2)
38838 KCOL=KCHG(KCRES,2)
38839 KCEM=KCHG(KCRES,1)
38840 FACT=COMFAC
38841 KCF1=PYCOMP(KFPR(ISUB,1))
38842 KCF2=PYCOMP(KFPR(ISUB,2))
38843 IF(ISUBSV.EQ.481) THEN
38844 SQMZR=PMAS(KCRES,1)**2
38845 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
38846 HS=SHR*WDTP(0)
38847 FACBW=SH2/((SH-SQMZR)**2+HS**2)
38848 FACT=FACT*FACBW
38849 ELSE
38850 SQMH=PMAS(KCF1,1)**2
38851 GMMH=PMAS(KCF1,1)*PMAS(KCF1,2)
38852C...Propagators: as simulated in PYOFSH and as desired
38853 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
38854 CALL PYWIDT(KFPR(ISUB,1),SQM3,WDTP,WDTE)
38855 GMMH3=SQRT(SQM3)*WDTP(0)
38856 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
38857 SQMH=PMAS(KCF2,1)**2
38858 GMMH=PMAS(KCF2,1)*PMAS(KCF2,2)
38859 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
38860 CALL PYWIDT(KFPR(ISUB,2),SQM4,WDTP,WDTE)
38861 GMMH4=SQRT(SQM4)*WDTP(0)
38862 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
38863 FACT=FACT*(HBW3C/HBW3)*(HBW4C/HBW4)
38864 ENDIF
38865
38866 KCI1=ABS(PYCOMP(KFDP(IDCY,1)))
38867 KCI2=ABS(PYCOMP(KFDP(IDCY,2)))
38868 JCOL1=SIGN(KCHG(KCF1,2),KFPR(ISUB,1))
38869 JCOL2=SIGN(KCHG(KCF2,2),KFPR(ISUB,2))
38870 IF(KCOL.EQ.0) THEN
38871 NCOL=1
38872 ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.KCOL.EQ.2) THEN
38873 IF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
38874 NCOL=3
38875 ELSE
38876 NCOL=2
38877 ENDIF
38878 ELSEIF(KCOL.EQ.-1.OR.KCOL.EQ.1) THEN
38879 NCOL=2
38880 ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.JCOL1.EQ.0.AND.
38881 $ JCOL2.EQ.0) THEN
38882 NCOL=1
38883 ELSEIF(KCOL.EQ.2.AND.((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR.
38884 $ (JCOL1.EQ.2.AND.JCOL2.EQ.0))) THEN
38885 NCOL=1
38886 ELSE
38887 NCOL=2
38888 ENDIF
38889 DO 440 I=MMIN1,MMAX1
38890 IF(KFAC(1,I).EQ.0) GOTO 440
38891 IP=I
38892 IF(IP.EQ.0) IP=21
38893 IA=ABS(IP)
38894 DO 430 J=MMIN2,MMAX2
38895 IF(KFAC(2,J).EQ.0) GOTO 430
38896 JP=J
38897 IF(JP.EQ.0) JP=21
38898 JA=ABS(JP)
38899 IF((IA.EQ.KCI1.AND.JA.EQ.KCI2).OR.
38900 $ (JA.EQ.KCI1.AND.IA.EQ.KCI2)) THEN
38901 KCHW=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
38902 IF(ABS(KCHW).EQ.ABS(KCEM)) THEN
38903 DO II=1,NCOL
38904 NCHN=NCHN+1
38905 ISIG(NCHN,1)=IP
38906 ISIG(NCHN,2)=JP
38907 ISIG(NCHN,3)=II
38908 SIGH(NCHN)=FACT/NCOL
38909 ENDDO
38910 ENDIF
38911 ENDIF
38912 430 CONTINUE
38913 440 CONTINUE
38914 ENDIF
38915 ENDIF
38916
38917 RETURN
38918 END
38919
38920C*********************************************************************
38921
38922C...PYPDFU
38923C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
38924C...parton distributions according to a few different parametrizations.
38925C...Note that what is coded is x times the probability distribution,
38926C...i.e. xq(x,Q2) etc.
38927
38928 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
38929
38930C...Double precision and integer declarations.
38931 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38932 IMPLICIT INTEGER(I-N)
38933 INTEGER PYK,PYCHGE,PYCOMP
38934C...Commonblocks.
38935 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38936 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38937 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38938 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38939 COMMON/PYINT1/MINT(400),VINT(400)
38940 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38941 &XPDIR(-6:6)
38942 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38943 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
38944 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
38945 & XMI(2,240),PT2MI(240),IMISEP(0:240)
38946 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
38947 &/PYINT9/,/PYINTM/
38948C...Local arrays.
38949 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
38950 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
38951 SAVE PPAR
38952
38953C...Interface to PDFLIB.
38954 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
38955 SAVE /W50513/
38956 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38957 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38958 CHARACTER*20 PARM(20)
38959 DATA VALUE/20*0D0/,PARM/20*' '/
38960
38961C...Data related to Schuler-Sjostrand photon distributions.
38962 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
38963
38964C...Valence PDF momentum integral parametrizations PER PARTON!
38965 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
38966 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
38967 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
38968 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
38969
38970C...Reset parton distributions.
38971 MINT(92)=0
38972 DO 100 KFL=-25,25
38973 XPQ(KFL)=0D0
38974 100 CONTINUE
38975 DO 110 KFL=-6,6
38976 XPVAL(KFL)=0D0
38977 110 CONTINUE
38978
38979C...Check x and particle species.
38980 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38981 WRITE(MSTU(11),5000) X
38982 GOTO 9999
38983 ENDIF
38984 KFA=IABS(KF)
38985 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
38986 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
38987 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
38988 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
38989 &KFA.NE.310.AND.KFA.NE.130) THEN
38990 WRITE(MSTU(11),5100) KF
38991 GOTO 9999
38992 ENDIF
38993
38994C...Electron (or muon or tau) parton distribution call.
38995 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
38996 CALL PYPDEL(KFA,X,Q2,XPEL)
38997 DO 120 KFL=-25,25
38998 XPQ(KFL)=XPEL(KFL)
38999 120 CONTINUE
39000
39001C...Photon parton distribution call (VDM+anomalous).
39002 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
39003 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
39004 CALL PYPDGA(X,Q2,XPGA)
39005 DO 130 KFL=-6,6
39006 XPQ(KFL)=XPGA(KFL)
39007 130 CONTINUE
39008 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
39009 XPVAL(1)=XPVU/4D0
39010 XPVAL(2)=XPVU
39011 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
39012 XPVAL(4)=MIN(XPQ(4),XPVU)
39013 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
39014 XPVAL(-1)=XPVAL(1)
39015 XPVAL(-2)=XPVAL(2)
39016 XPVAL(-3)=XPVAL(3)
39017 XPVAL(-4)=XPVAL(4)
39018 XPVAL(-5)=XPVAL(5)
39019 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
39020 Q2MX=Q2
39021 P2MX=0.36D0
39022 IF(MSTP(55).GE.7) P2MX=4.0D0
39023 IF(MSTP(57).EQ.0) Q2MX=P2MX
39024 P2=0D0
39025 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39026 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39027 DO 140 KFL=-6,6
39028 XPQ(KFL)=XPGA(KFL)
39029 XPVAL(KFL)=VXPDGM(KFL)
39030 140 CONTINUE
39031 VINT(231)=P2MX
39032 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
39033 Q2MX=Q2
39034 P2MX=0.36D0
39035 IF(MSTP(55).GE.11) P2MX=4.0D0
39036 IF(MSTP(57).EQ.0) Q2MX=P2MX
39037 P2=0D0
39038 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39039 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39040 DO 150 KFL=-6,6
39041 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
39042 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
39043 150 CONTINUE
39044 VINT(231)=P2MX
39045 ELSEIF(MSTP(56).EQ.2) THEN
39046C...Call PDFLIB parton distributions.
39047 PARM(1)='NPTYPE'
39048 VALUE(1)=3
39049 PARM(2)='NGROUP'
39050 VALUE(2)=MSTP(55)/1000
39051 PARM(3)='NSET'
39052 VALUE(3)=MOD(MSTP(55),1000)
39053 IF(MINT(93).NE.3000000+MSTP(55)) THEN
39054 CALL PDFSET_ALICE(PARM,VALUE)
39055 MINT(93)=3000000+MSTP(55)
39056 ENDIF
39057 XX=X
39058 QQ2=MAX(0D0,Q2MIN,Q2)
39059 IF(MSTP(57).EQ.0) QQ2=Q2MIN
39060 P2=0D0
39061 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39062 IP2=MSTP(60)
39063 IF(MSTP(55).EQ.5004) THEN
39064 IF(5D0*P2.LT.QQ2.AND.
39065 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
39066 & P2.GE.0D0.AND.P2.LT.10D0.AND.
39067 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
39068 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
39069 & BOT,TOP,GLU)
39070 ELSE
39071 UPV=0D0
39072 DNV=0D0
39073 USEA=0D0
39074 DSEA=0D0
39075 STR=0D0
39076 CHM=0D0
39077 BOT=0D0
39078 TOP=0D0
39079 GLU=0D0
39080 ENDIF
39081 ELSE
39082 IF(P2.LT.QQ2) THEN
39083 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
39084 & BOT,TOP,GLU)
39085 ELSE
39086 UPV=0D0
39087 DNV=0D0
39088 USEA=0D0
39089 DSEA=0D0
39090 STR=0D0
39091 CHM=0D0
39092 BOT=0D0
39093 TOP=0D0
39094 GLU=0D0
39095 ENDIF
39096 ENDIF
39097 VINT(231)=Q2MIN
39098 XPQ(0)=GLU
39099 XPQ(1)=DNV
39100 XPQ(-1)=DNV
39101 XPQ(2)=UPV
39102 XPQ(-2)=UPV
39103 XPQ(3)=STR
39104 XPQ(-3)=STR
39105 XPQ(4)=CHM
39106 XPQ(-4)=CHM
39107 XPQ(5)=BOT
39108 XPQ(-5)=BOT
39109 XPQ(6)=TOP
39110 XPQ(-6)=TOP
39111 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
39112 XPVAL(1)=XPVU/4D0
39113 XPVAL(2)=XPVU
39114 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
39115 XPVAL(4)=MIN(XPQ(4),XPVU)
39116 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
39117 XPVAL(-1)=XPVAL(1)
39118 XPVAL(-2)=XPVAL(2)
39119 XPVAL(-3)=XPVAL(3)
39120 XPVAL(-4)=XPVAL(4)
39121 XPVAL(-5)=XPVAL(5)
39122 ELSE
39123 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
39124 ENDIF
39125
39126C...Pion/gammaVDM parton distribution call.
39127 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
39128 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
39129 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
39130 & MSTP(55).LE.12) THEN
39131 ISET=1+MOD(MSTP(55)-1,4)
39132 Q2MX=Q2
39133 P2MX=0.36D0
39134 IF(ISET.GE.3) P2MX=4.0D0
39135 IF(MSTP(57).EQ.0) Q2MX=P2MX
39136 P2=0D0
39137 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39138 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39139 DO 160 KFL=-6,6
39140 XPQ(KFL)=XPVMD(KFL)
39141 XPVAL(KFL)=VXPVMD(KFL)
39142 160 CONTINUE
39143 VINT(231)=P2MX
39144 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
39145 CALL PYPDPI(X,Q2,XPPI)
39146 DO 170 KFL=-6,6
39147 XPQ(KFL)=XPPI(KFL)
39148 170 CONTINUE
39149 XPVAL(2)=XPQ(2)-XPQ(-2)
39150 XPVAL(-1)=XPQ(-1)-XPQ(1)
39151 ELSEIF(MSTP(54).EQ.2) THEN
39152C...Call PDFLIB parton distributions.
39153 PARM(1)='NPTYPE'
39154 VALUE(1)=2
39155 PARM(2)='NGROUP'
39156 VALUE(2)=MSTP(53)/1000
39157 PARM(3)='NSET'
39158 VALUE(3)=MOD(MSTP(53),1000)
39159 IF(MINT(93).NE.2000000+MSTP(53)) THEN
39160 CALL PDFSET_ALICE(PARM,VALUE)
39161 MINT(93)=2000000+MSTP(53)
39162 ENDIF
39163 XX=X
39164 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39165 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39166 CALL STRUCTM_ALICE(XX,QQ,UPV,DNV,USEA,
39167 + DSEA,STR,CHM,BOT,TOP,GLU)
39168 VINT(231)=Q2MIN
39169 XPQ(0)=GLU
39170 XPQ(1)=DSEA
39171 XPQ(-1)=UPV+DSEA
39172 XPQ(2)=UPV+USEA
39173 XPQ(-2)=USEA
39174 XPQ(3)=STR
39175 XPQ(-3)=STR
39176 XPQ(4)=CHM
39177 XPQ(-4)=CHM
39178 XPQ(5)=BOT
39179 XPQ(-5)=BOT
39180 XPQ(6)=TOP
39181 XPQ(-6)=TOP
39182 XPVAL(2)=UPV
39183 XPVAL(-1)=UPV
39184 ELSE
39185 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
39186 ENDIF
39187
39188C...Anomalous photon parton distribution call.
39189 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
39190 Q2MX=Q2
39191 P2MX=PARP(15)**2
39192 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
39193 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
39194 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
39195 IF(MSTP(57).EQ.0) Q2MX=P2MX
39196 P2=0D0
39197 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39198 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
39199 DO 180 KFL=-6,6
39200 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
39201 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
39202 180 CONTINUE
39203 VINT(231)=P2MX
39204 ELSEIF(MSTP(56).EQ.1) THEN
39205 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
39206 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
39207 IF(MSTP(57).EQ.0) Q2MX=P2MX
39208 P2=0D0
39209 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39210 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
39211 DO 190 KFL=-6,6
39212 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
39213 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
39214 190 CONTINUE
39215 VINT(231)=P2MX
39216 ELSEIF(MSTP(56).EQ.2) THEN
39217 IF(MSTP(57).EQ.0) Q2MX=P2MX
39218 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
39219 DO 200 KFL=-6,6
39220 XPQ(KFL)=XPGA(KFL)
39221 XPVAL(KFL)=VXPGA(KFL)
39222 200 CONTINUE
39223 VINT(231)=P2MX
39224 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
39225 IF(MSTP(57).EQ.0) Q2MX=P2MX
39226 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
39227 DO 210 KFL=-6,6
39228 XPQ(KFL)=XPGA(KFL)
39229 XPVAL(KFL)=VXPGA(KFL)
39230 210 CONTINUE
39231 VINT(231)=P2MX
39232 ELSE
39233 220 RKF=11D0*PYR(0)
39234 KFR=1
39235 IF(RKF.GT.1D0) KFR=2
39236 IF(RKF.GT.5D0) KFR=3
39237 IF(RKF.GT.6D0) KFR=4
39238 IF(RKF.GT.10D0) KFR=5
39239 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
39240 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
39241 IF(MSTP(57).EQ.0) Q2MX=P2MX
39242 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
39243 DO 230 KFL=-6,6
39244 XPQ(KFL)=XPGA(KFL)
39245 XPVAL(KFL)=VXPGA(KFL)
39246 230 CONTINUE
39247 VINT(231)=P2MX
39248 ENDIF
39249
39250C...Proton parton distribution call.
39251 ELSE
39252 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
39253 CALL PYPDPR(X,Q2,XPPR)
39254 DO 240 KFL=-6,6
39255 XPQ(KFL)=XPPR(KFL)
39256 240 CONTINUE
39257C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
39258 XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1))
39259 XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2))
39260 ELSEIF(MSTP(52).EQ.2) THEN
39261C...Call PDFLIB parton distributions.
39262 PARM(1)='NPTYPE'
39263 VALUE(1)=1
39264 PARM(2)='NGROUP'
39265 VALUE(2)=MSTP(51)/1000
39266 PARM(3)='NSET'
39267 VALUE(3)=MOD(MSTP(51),1000)
39268 IF(MINT(93).NE.1000000+MSTP(51)) THEN
39269 CALL PDFSET_ALICE(PARM,VALUE)
39270 MINT(93)=1000000+MSTP(51)
39271 ENDIF
39272 XX=X
39273 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39274 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39275 CALL STRUCTM_ALICE(XX,QQ,UPV,DNV,USEA,
39276 + DSEA,STR,CHM,BOT,TOP,GLU)
39277 VINT(231)=Q2MIN
39278 XPQ(0)=GLU
39279 XPQ(1)=DNV+DSEA
39280 XPQ(-1)=DSEA
39281 XPQ(2)=UPV+USEA
39282 XPQ(-2)=USEA
39283 XPQ(3)=STR
39284 XPQ(-3)=STR
39285 XPQ(4)=CHM
39286 XPQ(-4)=CHM
39287 XPQ(5)=BOT
39288 XPQ(-5)=BOT
39289 XPQ(6)=TOP
39290 XPQ(-6)=TOP
39291 XPVAL(1)=DNV
39292 XPVAL(2)=UPV
39293 ELSE
39294 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
39295 ENDIF
39296 ENDIF
39297
39298C...Isospin average for pi0/gammaVDM.
39299 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
39300 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
39301 XPV=XPQ(2)-XPQ(1)
39302 XPQ(2)=XPQ(1)
39303 XPQ(-2)=XPQ(-1)
39304 ELSE
39305 XPS=0.5D0*(XPQ(1)+XPQ(-2))
39306 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
39307 XPQ(2)=XPS
39308 XPQ(-1)=XPS
39309 ENDIF
39310 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
39311 & XPVAL(3)+XPVAL(4)+XPVAL(5)
39312 DO 250 KFL=-6,6
39313 XPVAL(KFL)=0D0
39314 250 CONTINUE
39315 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
39316 XPQ(1)=XPQ(1)+0.2D0*XPV
39317 XPQ(2)=XPQ(2)+0.8D0*XPV
39318 XPVAL(1)=0.2D0*XPVL
39319 XPVAL(2)=0.8D0*XPVL
39320 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
39321 XPQ(3)=XPQ(3)+XPV
39322 XPVAL(3)=XPVL
39323 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
39324 XPQ(4)=XPQ(4)+XPV
39325 XPVAL(4)=XPVL
39326 IF(MSTP(55).GE.9) THEN
39327 DO 260 KFL=-6,6
39328 XPQ(KFL)=0D0
39329 260 CONTINUE
39330 ENDIF
39331 ELSE
39332 XPQ(1)=XPQ(1)+0.5D0*XPV
39333 XPQ(2)=XPQ(2)+0.5D0*XPV
39334 XPVAL(1)=0.5D0*XPVL
39335 XPVAL(2)=0.5D0*XPVL
39336 ENDIF
39337 DO 270 KFL=1,6
39338 XPQ(-KFL)=XPQ(KFL)
39339 XPVAL(-KFL)=XPVAL(KFL)
39340 270 CONTINUE
39341
39342C...Rescale for gammaVDM by effective gamma -> rho coupling.
39343C+++Do not rescale?
39344 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
39345 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
39346 DO 280 KFL=-6,6
39347 XPQ(KFL)=VINT(281)*XPQ(KFL)
39348 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
39349 280 CONTINUE
39350 VINT(232)=VINT(281)*XPV
39351 ENDIF
39352
39353C...Simple recipes for kaons.
39354 ELSEIF(KFA.EQ.321) THEN
39355 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
39356 XPQ(-1)=XPQ(1)
39357 XPVAL(-3)=XPVAL(-1)
39358 XPVAL(-1)=0D0
39359 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
39360 XPS=0.5D0*(XPQ(1)+XPQ(-2))
39361 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
39362 XPQ(2)=XPS
39363 XPQ(-1)=XPS
39364 XPQ(1)=XPQ(1)+0.5D0*XPV
39365 XPQ(-1)=XPQ(-1)+0.5D0*XPV
39366 XPQ(3)=XPQ(3)+0.5D0*XPV
39367 XPQ(-3)=XPQ(-3)+0.5D0*XPV
39368 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
39369 XPVAL(2)=0D0
39370 XPVAL(-1)=0D0
39371 XPVAL(1)=0.5D0*XPV
39372 XPVAL(-1)=0.5D0*XPV
39373 XPVAL(3)=0.5D0*XPV
39374 XPVAL(-3)=0.5D0*XPV
39375
39376C...Isospin conjugation for neutron.
39377 ELSEIF(KFA.EQ.2112) THEN
39378 XPSV=XPQ(1)
39379 XPQ(1)=XPQ(2)
39380 XPQ(2)=XPSV
39381 XPSV=XPQ(-1)
39382 XPQ(-1)=XPQ(-2)
39383 XPQ(-2)=XPSV
39384 XPSV=XPVAL(1)
39385 XPVAL(1)=XPVAL(2)
39386 XPVAL(2)=XPSV
39387
39388C...Simple recipes for hyperon (average valence parton distribution).
39389 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
39390 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
39391 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
39392 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
39393 XPQ(1)=XPS
39394 XPQ(2)=XPS
39395 XPQ(-1)=XPS
39396 XPQ(-2)=XPS
39397 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
39398 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
39399 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
39400 XPV=(XPVAL(1)+XPVAL(2))/3D0
39401 XPVAL(1)=0D0
39402 XPVAL(2)=0D0
39403 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
39404 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
39405 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
39406 ENDIF
39407
39408C...Charge conjugation for antiparticle.
39409 IF(KF.LT.0) THEN
39410 DO 290 KFL=1,25
39411 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
39412 XPSV=XPQ(KFL)
39413 XPQ(KFL)=XPQ(-KFL)
39414 XPQ(-KFL)=XPSV
39415 290 CONTINUE
39416 DO 300 KFL=1,6
39417 XPSV=XPVAL(KFL)
39418 XPVAL(KFL)=XPVAL(-KFL)
39419 XPVAL(-KFL)=XPSV
39420 300 CONTINUE
39421 ENDIF
39422
39423C...MULTIPLE INTERACTIONS - PDF RESHAPING.
39424C...Set side.
39425 JS=MINT(30)
39426C...Only reshape PDFs for the non-first interactions;
39427C...But need valence/sea separation already from first interaction.
39428 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
39429 KFVSEL=KFIVAL(JS,1)
39430C...If valence quark kicked out of pi0 or gamma then that decides
39431C...whether we should consider state as d dbar, u ubar, s sbar, etc.
39432 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
39433 XPVL=0D0
39434 DO 310 KFL=1,6
39435 XPVL=XPVL+XPVAL(KFL)
39436 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
39437 XPVAL(KFL)=0D0
39438 310 CONTINUE
39439 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
39440 XPVAL(IABS(KFVSEL))=XPVL
39441 DO 320 KFL=1,6
39442 XPQ(-KFL)=XPQ(KFL)
39443 XPVAL(-KFL)=XPVAL(KFL)
39444 320 CONTINUE
39445
39446C...If valence quark kicked out of K0S or K0S then that decides whether
39447C...we should consider state as d sbar or s dbar.
39448 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
39449 KFS=1
39450 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
39451 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
39452 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
39453 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
39454 XPVAL(-KFS)=0D0
39455 KFS=-3*KFS
39456 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
39457 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
39458 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
39459 XPVAL(-KFS)=0D0
39460 ENDIF
39461
39462C...XPQ distributions are nominal for a (signed) beam particle
39463C...of KF type, with 1-Sum(x_prev) rescaled to 1.
39464 CMPFAC=1D0
39465 NRESC=0
39466 345 NRESC=NRESC+1
39467 PVCTOT(JS,-1)=0D0
39468 PVCTOT(JS, 0)=0D0
39469 PVCTOT(JS, 1)=0D0
39470 DO 350 IFL=-6,6
39471 IF(IFL.EQ.0) GOTO 350
39472
39473C...Count up number of original IFL valence quarks.
39474 IVORG=0
39475 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
39476 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
39477 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
39478C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
39479C...bookkeep as if d dbar (for total momentum sum in valence sector).
39480 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
39481C...Count down number of remaining IFL valence quarks. Skip current
39482C...interaction initiator.
39483 IVREM=IVORG
39484 DO 330 I1=1,NMI(JS)
39485 IF (I1.EQ.MINT(36)) GOTO 330
39486 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
39487 & IVREM=IVREM-1
39488 330 CONTINUE
39489
39490C...Separate out original VALENCE and SEA content.
39491 VAL=XPVAL(IFL)
39492 SEA=MAX(0D0,XPQ(IFL)-VAL)
39493 XPSVC(IFL,0)=VAL
39494 XPSVC(IFL,-1)=SEA
39495
39496C...Rescale valence content if changed.
39497 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
39498 & (VAL*IVREM)/IVORG
39499
39500C...Momentum integrals of original and removed valence quarks.
39501 IF(IVORG.NE.0) THEN
39502C...For p/n/pbar/nbar beams can split into d_val and u_val.
39503C...Isospin conjugation for neutrons
39504 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
39505 IAFLP=IABS(IFL)
39506 IF (KFA.EQ.2112) IAFLP=3-IAFLP
39507 VPAVG=PAVG(IAFLP,Q2)
39508C...For other baryons average d_val and u_val, like for PDFs.
39509 ELSEIF(KFA.GT.1000) THEN
39510 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
39511C...For mesons and photon average d_val and u_val and scale by 3/2.
39512C...Very crude, especially for photon.
39513 ELSE
39514 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
39515 ENDIF
39516 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
39517 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
39518 ENDIF
39519
39520C...Now add companions (at X with partner having been at Z=XASSOC).
39521C...NOTE: due to the assumed simple x scaling, the partner was at what
39522C...corresponds to a higher Z than XASSOC, if there were intermediate
39523C...scatterings. Nothing done about that for the moment.
39524 DO 340 IVC=1,NVC(JS,IFL)
39525C...Skip companions that have been kicked out
39526 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
39527 XPSVC(IFL,IVC)=0D0
39528 GOTO 340
39529 ELSE
39530C...Momentum fraction of the partner quark.
39531C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
39532 XS=XASSOC(JS,IFL,IVC)
39533 XREM=VINT(142+JS)
39534 YS=XS/(XREM+XS)
39535C...Momentum fraction of the companion quark.
39536C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
39537 Y=X*(1D0-YS)
39538 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
39539C...Add to momentum sum, with rescaling compensation factor.
39540 XCFAC=(XREM+XS)/XREM*CMPFAC
39541 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
39542 ENDIF
39543 340 CONTINUE
39544 350 CONTINUE
39545
39546C...Wait until all flavours treated, then rescale seas and gluon.
39547 XPSVC(0,-1)=XPQ(0)
39548 XPSVC(0,0)=0D0
39549 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
39550 IF (RSFAC.LE.0D0) THEN
39551C...First calculate factor needed to exactly restore pz cons.
39552 IF (NRESC.EQ.1) CMPFAC =
39553 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
39554C...Add a bit of headroom
39555 CMPFAC=0.99*CMPFAC
39556C...Try a few times if more headroom is needed, then print error message.
39557 IF (NRESC.LE.10) GOTO 345
39558 CALL PYERRM(15,
39559 & '(PYPDFU:) Negative reshaping factor persists!')
39560 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
39561 RSFAC=0D0
39562 ENDIF
39563 DO 370 IFL=-6,6
39564 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
39565C...Also store resulting distributions in XPQ
39566 XPQ(IFL)=0D0
39567 DO 360 ISVC=-1,NVC(JS,IFL)
39568 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
39569 360 CONTINUE
39570 370 CONTINUE
39571C...Save companion reweighting factor for PYPTIS.
39572 VINT(140)=CMPFAC
39573 ENDIF
39574
39575
39576C...Allow gluon also in position 21.
39577 XPQ(21)=XPQ(0)
39578
39579C...Check positivity and reset above maximum allowed flavour.
39580 DO 380 KFL=-25,25
39581 XPQ(KFL)=MAX(0D0,XPQ(KFL))
39582 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
39583 380 CONTINUE
39584
39585C...Formats for error printouts.
39586 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
39587 5100 FORMAT(' Error: illegal particle code for parton distribution;',
39588 &' KF =',I5)
39589 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
39590 &3I5)
39591 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
39592 & ' Removed valence momentum fraction : ',F6.3/
39593 & ' Added companion momentum fraction : ',F6.3/
39594 & ' Resulting rescale factor : ',F6.3)
39595
39596C...Reset side pointer and return
39597 9999 MINT(30)=0
39598
39599 RETURN
39600 END
39601
39602C*********************************************************************
39603
39604C...PYPDFL
39605C...Gives proton parton distribution at small x and/or Q^2 according to
39606C...correct limiting behaviour.
39607
39608 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
39609
39610C...Double precision and integer declarations.
39611 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39612 IMPLICIT INTEGER(I-N)
39613 INTEGER PYK,PYCHGE,PYCOMP
39614C...Commonblocks.
39615 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39616 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39617 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39618 COMMON/PYINT1/MINT(400),VINT(400)
39619 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39620C...Local arrays.
39621 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
39622 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
39623
39624C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
39625 MINT(92)=0
39626 KFA=IABS(KF)
39627 IACC=0
39628 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
39629 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
39630 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
39631 IF(IACC.EQ.0) THEN
39632 CALL PYPDFU(KF,X,Q2,XPQ)
39633 RETURN
39634 ENDIF
39635
39636C...Reset. Check x.
39637 DO 100 KFL=-25,25
39638 XPQ(KFL)=0D0
39639 100 CONTINUE
39640 IF(X.LE.0D0.OR.X.GE.1D0) THEN
39641 WRITE(MSTU(11),5000) X
39642 RETURN
39643 ENDIF
39644
39645C...Define valence content.
39646 KFC=KF
39647 NV1=2
39648 NV2=1
39649 IF(KF.EQ.2212) THEN
39650 KFV1=2
39651 KFV2=1
39652 ELSEIF(KF.EQ.-2212) THEN
39653 KFV1=-2
39654 KFV2=-1
39655 ELSEIF(KF.EQ.2112) THEN
39656 KFV1=1
39657 KFV2=2
39658 ELSEIF(KF.EQ.-2112) THEN
39659 KFV1=-1
39660 KFV2=-2
39661 ELSEIF(KF.EQ.211) THEN
39662 NV1=1
39663 KFV1=2
39664 KFV2=-1
39665 ELSEIF(KF.EQ.-211) THEN
39666 NV1=1
39667 KFV1=-2
39668 KFV2=1
39669 ELSEIF(MINT(105).LE.223) THEN
39670 KFV1=1
39671 WTV1=0.2D0
39672 KFV2=2
39673 WTV2=0.8D0
39674 ELSEIF(MINT(105).EQ.333) THEN
39675 KFV1=3
39676 WTV1=1.0D0
39677 KFV2=1
39678 WTV2=0.0D0
39679 ELSEIF(MINT(105).EQ.443) THEN
39680 KFV1=4
39681 WTV1=1.0D0
39682 KFV2=1
39683 WTV2=0.0D0
39684 ENDIF
39685
39686C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
39687 MINT30=MINT(30)
39688 CALL PYPDFU(KFC,X,Q2,XPA)
39689 Q2MN=MAX(3D0,VINT(231))
39690 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
39691 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
39692
39693C...Large Q2 and large x: naive call is enough.
39694 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
39695 DO 110 KFL=-25,25
39696 XPQ(KFL)=XPA(KFL)
39697 110 CONTINUE
39698 MINT(92)=1
39699
39700C...Small Q2 and large x: dampen boundary value.
39701 ELSEIF(X.GT.XMN) THEN
39702
39703C...Evaluate at boundary and define dampening factors.
39704 MINT(30)=MINT30
39705 CALL PYPDFU(KFC,X,Q2MN,XPA)
39706 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
39707 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
39708
39709C...Separate valence and sea parts of parton distribution.
39710 IF(KFA.NE.22) THEN
39711 XFV1=XPA(KFV1)-XPA(-KFV1)
39712 XPA(KFV1)=XPA(-KFV1)
39713 XFV2=XPA(KFV2)-XPA(-KFV2)
39714 XPA(KFV2)=XPA(-KFV2)
39715 ELSE
39716 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
39717 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
39718 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
39719 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
39720 ENDIF
39721
39722C...Dampen valence and sea separately. Put back together.
39723 DO 120 KFL=-25,25
39724 XPQ(KFL)=FS*XPA(KFL)
39725 120 CONTINUE
39726 IF(KFA.NE.22) THEN
39727 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
39728 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
39729 ELSE
39730 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
39731 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
39732 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
39733 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
39734 ENDIF
39735 MINT(92)=2
39736
39737C...Large Q2 and small x: interpolate behaviour.
39738 ELSEIF(Q2.GT.Q2MN) THEN
39739
39740C...Evaluate at extremes and define coefficients for interpolation.
39741 MINT(30)=MINT30
39742 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
39743 VI232A=VINT(232)
39744 MINT(30)=MINT30
39745 CALL PYPDFU(KFC,X,Q2B,XPB)
39746 VI232B=VINT(232)
39747 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
39748 FVA=(X/XMN)**0.45D0*FLA
39749 FSA=(X/XMN)**(-0.08D0)*FLA
39750 FB=1D0-FLA
39751
39752C...Separate valence and sea parts of parton distribution.
39753 IF(KFA.NE.22) THEN
39754 XFVA1=XPA(KFV1)-XPA(-KFV1)
39755 XPA(KFV1)=XPA(-KFV1)
39756 XFVA2=XPA(KFV2)-XPA(-KFV2)
39757 XPA(KFV2)=XPA(-KFV2)
39758 XFVB1=XPB(KFV1)-XPB(-KFV1)
39759 XPB(KFV1)=XPB(-KFV1)
39760 XFVB2=XPB(KFV2)-XPB(-KFV2)
39761 XPB(KFV2)=XPB(-KFV2)
39762 ELSE
39763 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
39764 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
39765 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
39766 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
39767 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
39768 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
39769 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
39770 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
39771 ENDIF
39772
39773C...Interpolate for valence and sea. Put back together.
39774 DO 130 KFL=-25,25
39775 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
39776 130 CONTINUE
39777 IF(KFA.NE.22) THEN
39778 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
39779 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
39780 ELSE
39781 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39782 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39783 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39784 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39785 ENDIF
39786 MINT(92)=3
39787
39788C...Small Q2 and small x: dampen boundary value and add term.
39789 ELSE
39790
39791C...Evaluate at boundary and define dampening factors.
39792 MINT(30)=MINT30
39793 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
39794 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
39795 FA=1D0-FB
39796 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
39797 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
39798 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
39799 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
39800 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
39801 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
39802
39803C...Separate valence and sea parts of parton distribution.
39804 IF(KFA.NE.22) THEN
39805 XFV1=XPA(KFV1)-XPA(-KFV1)
39806 XPA(KFV1)=XPA(-KFV1)
39807 XFV2=XPA(KFV2)-XPA(-KFV2)
39808 XPA(KFV2)=XPA(-KFV2)
39809 ELSE
39810 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
39811 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
39812 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
39813 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
39814 ENDIF
39815
39816C...Dampen valence and sea separately. Add constant terms.
39817C...Put back together.
39818 DO 140 KFL=-25,25
39819 XPQ(KFL)=FSA*XPA(KFL)
39820 140 CONTINUE
39821 IF(KFA.NE.22) THEN
39822 DO 150 KFL=-3,3
39823 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
39824 150 CONTINUE
39825 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
39826 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
39827 ELSE
39828 DO 160 KFL=-3,3
39829 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
39830 160 CONTINUE
39831 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39832 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39833 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39834 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39835 ENDIF
39836 XPQ(21)=XPQ(0)
39837 MINT(92)=4
39838 ENDIF
39839
39840C...Format for error printout.
39841 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
39842
39843 RETURN
39844 END
39845
39846C*********************************************************************
39847
39848C...PYPDEL
39849C...Gives electron (or muon, or tau) parton distribution.
39850
39851 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
39852
39853C...Double precision and integer declarations.
39854 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39855 IMPLICIT INTEGER(I-N)
39856 INTEGER PYK,PYCHGE,PYCOMP
39857C...Commonblocks.
39858 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39859 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39860 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39861 COMMON/PYINT1/MINT(400),VINT(400)
39862 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39863C...Local arrays.
39864 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
39865
39866C...Interface to PDFLIB.
39867 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
39868 SAVE /W50513/
39869 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
39870 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
39871 CHARACTER*20 PARM(20)
39872 DATA VALUE/20*0D0/,PARM/20*' '/
39873
39874C...Some common constants.
39875 DO 100 KFL=-25,25
39876 XPEL(KFL)=0D0
39877 100 CONTINUE
39878 AEM=PARU(101)
39879 PME=PMAS(11,1)
39880 IF(KFA.EQ.13) PME=PMAS(13,1)
39881 IF(KFA.EQ.15) PME=PMAS(15,1)
39882 XL=LOG(MAX(1D-10,X))
39883 X1L=LOG(MAX(1D-10,1D0-X))
39884 HLE=LOG(MAX(3D0,Q2/PME**2))
39885 HBE2=(AEM/PARU(1))*(HLE-1D0)
39886
39887C...Electron inside electron, see R. Kleiss et al., in Z physics at
39888C...LEP 1, CERN 89-08, p. 34
39889 IF(MSTP(59).LE.1) THEN
39890 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
39891 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
39892 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
39893 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
39894 & 4D0*XL/(1D0-X)-5D0-X)
39895 ELSE
39896 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
39897 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
39898 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
39899 ENDIF
39900C...Zero distribution for very large x and rescale it for intermediate.
39901 IF(X.GT.1D0-1D-10) THEN
39902 HEE=0D0
39903 ELSEIF(X.GT.1D0-1D-7) THEN
39904 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
39905 ENDIF
39906 XPEL(KFA)=X*HEE
39907
39908C...Photon and (transverse) W- inside electron.
39909 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
39910 IF(MSTP(13).LE.1) THEN
39911 HLG=HLE
39912 ELSE
39913 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
39914 ENDIF
39915 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
39916 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
39917 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
39918
39919C...Electron or positron inside photon inside electron.
39920 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
39921 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
39922 & 2D0*X*(1D0+X)*XL)
39923 XPEL(11)=XPEL(11)+XFSEA
39924 XPEL(-11)=XFSEA
39925
39926C...Initialize PDFLIB photon parton distributions.
39927 IF(MSTP(56).EQ.2) THEN
39928 PARM(1)='NPTYPE'
39929 VALUE(1)=3
39930 PARM(2)='NGROUP'
39931 VALUE(2)=MSTP(55)/1000
39932 PARM(3)='NSET'
39933 VALUE(3)=MOD(MSTP(55),1000)
39934 IF(MINT(93).NE.3000000+MSTP(55)) THEN
39935 CALL PDFSET_ALICE(PARM,VALUE)
39936 MINT(93)=3000000+MSTP(55)
39937 ENDIF
39938 ENDIF
39939
39940C...Quarks and gluons inside photon inside electron:
39941C...numerical convolution required.
39942 DO 110 KFL=0,6
39943 SXP(KFL)=0D0
39944 110 CONTINUE
39945 SUMXPP=0D0
39946 ITER=-1
39947 120 ITER=ITER+1
39948 SUMXP=SUMXPP
39949 NSTP=2**(ITER-1)
39950 IF(ITER.EQ.0) NSTP=2
39951 DO 130 KFL=0,6
39952 SXP(KFL)=0.5D0*SXP(KFL)
39953 130 CONTINUE
39954 WTSTP=0.5D0/NSTP
39955 IF(ITER.EQ.0) WTSTP=0.5D0
39956C...Pick grid of x_{gamma} values logarithmically even.
39957 DO 150 ISTP=1,NSTP
39958 IF(ITER.EQ.0) THEN
39959 XLE=XL*(ISTP-1)
39960 ELSE
39961 XLE=XL*(ISTP-0.5D0)/NSTP
39962 ENDIF
39963 XE=MIN(1D0-1D-10,EXP(XLE))
39964 XG=MIN(1D0-1D-10,X/XE)
39965C...Evaluate photon inside electron parton distribution for convolution.
39966 XPGP=1D0+(1D0-XE)**2
39967 IF(MSTP(13).LE.1) THEN
39968 XPGP=XPGP*HLE
39969 ELSE
39970 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
39971 ENDIF
39972C...Evaluate photon parton distributions for convolution.
39973 IF(MSTP(56).EQ.1) THEN
39974 IF(MSTP(55).EQ.1) THEN
39975 CALL PYPDGA(XG,Q2,XPGA)
39976 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
39977 Q2MX=Q2
39978 P2MX=0.36D0
39979 IF(MSTP(55).GE.7) P2MX=4.0D0
39980 IF(MSTP(57).EQ.0) Q2MX=P2MX
39981 P2=0D0
39982 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39983 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39984 VINT(231)=P2MX
39985 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
39986 Q2MX=Q2
39987 P2MX=0.36D0
39988 IF(MSTP(55).GE.11) P2MX=4.0D0
39989 IF(MSTP(57).EQ.0) Q2MX=P2MX
39990 P2=0D0
39991 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39992 CALL PYGGAM(MSTP(55)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39993 VINT(231)=P2MX
39994 ENDIF
39995 DO 140 KFL=0,5
39996 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
39997 140 CONTINUE
39998 ELSEIF(MSTP(56).EQ.2) THEN
39999C...Call PDFLIB parton distributions.
40000 XX=XG
40001 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
40002 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
40003 CALL STRUCTM_ALICE(XX,QQ,UPV,DNV,USEA,
40004 + DSEA,STR,CHM,BOT,TOP,GLU)
40005 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
40006 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
40007 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
40008 SXP(3)=SXP(3)+WTSTP*XPGP*STR
40009 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
40010 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
40011 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
40012 ENDIF
40013 150 CONTINUE
40014 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
40015 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
40016 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
40017
40018C...Put convolution into output arrays.
40019 FCONV=AEMP*(-XL)
40020 XPEL(0)=FCONV*SXP(0)
40021 DO 160 KFL=1,6
40022 XPEL(KFL)=FCONV*SXP(KFL)
40023 XPEL(-KFL)=XPEL(KFL)
40024 160 CONTINUE
40025 ENDIF
40026
40027 RETURN
40028 END
40029
40030C*********************************************************************
40031
40032C...PYPDGA
40033C...Gives photon parton distribution.
40034
40035 SUBROUTINE PYPDGA(X,Q2,XPGA)
40036
40037C...Double precision and integer declarations.
40038 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40039 IMPLICIT INTEGER(I-N)
40040 INTEGER PYK,PYCHGE,PYCOMP
40041C...Commonblocks.
40042 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40043 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40044 COMMON/PYINT1/MINT(400),VINT(400)
40045 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40046C...Local arrays.
40047 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
40048 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
40049 &DGCS(4,3),DGDS(4,3),DGES(4,3)
40050
40051C...The following data lines are coefficients needed in the
40052C...Drees and Grassie photon parton distribution parametrization.
40053 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
40054 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
40055 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
40056 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
40057 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
40058 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
40059 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
40060 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
40061 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
40062 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
40063 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
40064 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
40065 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
40066 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
40067 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
40068 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
40069 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
40070 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
40071 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
40072 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
40073 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
40074 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
40075 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
40076 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
40077 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
40078 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
40079
40080C...Photon parton distribution from Drees and Grassie.
40081C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
40082 DO 100 KFL=-6,6
40083 XPGA(KFL)=0D0
40084 100 CONTINUE
40085 VINT(231)=1D0
40086 IF(MSTP(57).LE.0) THEN
40087 T=LOG(1D0/0.16D0)
40088 ELSE
40089 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
40090 ENDIF
40091 X1=1D0-X
40092 NF=3
40093 IF(Q2.GT.25D0) NF=4
40094 IF(Q2.GT.300D0) NF=5
40095 NFE=NF-2
40096 AEM=PARU(101)
40097
40098C...Evaluate gluon content.
40099 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
40100 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
40101 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
40102 XPGL=DGA*X**DGB*X1**DGC
40103
40104C...Evaluate up- and down-type quark content.
40105 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
40106 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
40107 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
40108 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
40109 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
40110 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
40111 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
40112 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
40113 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
40114 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
40115 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
40116 DGF=9D0
40117 IF(NF.EQ.4) DGF=10D0
40118 IF(NF.EQ.5) DGF=55D0/6D0
40119 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
40120 IF(NF.LE.3) THEN
40121 XPQU=(XPQS+9D0*XPQN)/6D0
40122 XPQD=(XPQS-4.5D0*XPQN)/6D0
40123 ELSEIF(NF.EQ.4) THEN
40124 XPQU=(XPQS+6D0*XPQN)/8D0
40125 XPQD=(XPQS-6D0*XPQN)/8D0
40126 ELSE
40127 XPQU=(XPQS+7.5D0*XPQN)/10D0
40128 XPQD=(XPQS-5D0*XPQN)/10D0
40129 ENDIF
40130
40131C...Put into output arrays.
40132 XPGA(0)=AEM*XPGL
40133 XPGA(1)=AEM*XPQD
40134 XPGA(2)=AEM*XPQU
40135 XPGA(3)=AEM*XPQD
40136 IF(NF.GE.4) XPGA(4)=AEM*XPQU
40137 IF(NF.GE.5) XPGA(5)=AEM*XPQD
40138 DO 110 KFL=1,6
40139 XPGA(-KFL)=XPGA(KFL)
40140 110 CONTINUE
40141
40142 RETURN
40143 END
40144
40145C*********************************************************************
40146
40147C...PYGGAM
40148C...Constructs the F2 and parton distributions of the photon
40149C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40150C...For F2, c and b are included by the Bethe-Heitler formula;
40151C...in the 'MSbar' scheme additionally a Cgamma term is added.
40152C...Contains the SaS sets 1D, 1M, 2D and 2M.
40153C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40154
40155 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40156
40157C...Double precision and integer declarations.
40158 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40159 IMPLICIT INTEGER(I-N)
40160 INTEGER PYK,PYCHGE,PYCOMP
40161C...Commonblocks.
40162 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40163 &XPDIR(-6:6)
40164 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40165 SAVE /PYINT8/,/PYINT9/
40166C...Local arrays.
40167 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
40168C...Charm and bottom masses (low to compensate for J/psi etc.).
40169 DATA PMC/1.3D0/, PMB/4.6D0/
40170C...alpha_em and alpha_em/(2*pi).
40171 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
40172C...Lambda value for 4 flavours.
40173 DATA ALAM/0.20D0/
40174C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40175 DATA FRACU/0.8D0/
40176C...VMD couplings f_V**2/(4*pi).
40177 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
40178C...Masses for rho (=omega) and phi.
40179 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
40180C...Number of points in integration for IP2=1.
40181 DATA NSTEP/100/
40182
40183C...Reset output.
40184 F2GM=0D0
40185 DO 100 KFL=-6,6
40186 XPDFGM(KFL)=0D0
40187 XPVMD(KFL)=0D0
40188 XPANL(KFL)=0D0
40189 XPANH(KFL)=0D0
40190 XPBEH(KFL)=0D0
40191 XPDIR(KFL)=0D0
40192 VXPVMD(KFL)=0D0
40193 VXPANL(KFL)=0D0
40194 VXPANH(KFL)=0D0
40195 VXPDGM(KFL)=0D0
40196 100 CONTINUE
40197
40198C...Set Q0 cut-off parameter as function of set used.
40199 IF(ISET.LE.2) THEN
40200 Q0=0.6D0
40201 ELSE
40202 Q0=2D0
40203 ENDIF
40204 Q02=Q0**2
40205
40206C...Scale choice for off-shell photon; common factors.
40207 Q2A=Q2
40208 FACNOR=1D0
40209 IF(IP2.EQ.1) THEN
40210 P2MX=P2+Q02
40211 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40212 FACNOR=LOG(Q2/Q02)/NSTEP
40213 ELSEIF(IP2.EQ.2) THEN
40214 P2MX=MAX(P2,Q02)
40215 ELSEIF(IP2.EQ.3) THEN
40216 P2MX=P2+Q02
40217 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40218 ELSEIF(IP2.EQ.4) THEN
40219 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40220 & ((Q2+P2)*(Q02+P2)))
40221 ELSEIF(IP2.EQ.5) THEN
40222 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40223 & ((Q2+P2)*(Q02+P2)))
40224 P2MX=Q0*SQRT(P2MXA)
40225 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
40226 ELSEIF(IP2.EQ.6) THEN
40227 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40228 & ((Q2+P2)*(Q02+P2)))
40229 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
40230 ELSE
40231 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40232 & ((Q2+P2)*(Q02+P2)))
40233 P2MX=Q0*SQRT(P2MXA)
40234 P2MXB=P2MX
40235 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
40236 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
40237 IF(ABS(Q2-Q02).GT.1D-6) THEN
40238 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
40239 ELSEIF(P2.LT.Q02) THEN
40240 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
40241 ELSE
40242 FACNOR=1D0
40243 ENDIF
40244 ENDIF
40245
40246C...Call VMD parametrization for d quark and use to give rho, omega,
40247C...phi. Note dipole dampening for off-shell photon.
40248 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40249 XFVAL=VXPGA(1)
40250 XPGA(1)=XPGA(2)
40251 XPGA(-1)=XPGA(-2)
40252 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
40253 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
40254 DO 110 KFL=-5,5
40255 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
40256 110 CONTINUE
40257 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
40258 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
40259 XPVMD(3)=XPVMD(3)+FACS*XFVAL
40260 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
40261 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
40262 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
40263 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
40264 VXPVMD(2)=FRACU*FACUD*XFVAL
40265 VXPVMD(3)=FACS*XFVAL
40266 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
40267 VXPVMD(-2)=FRACU*FACUD*XFVAL
40268 VXPVMD(-3)=FACS*XFVAL
40269
40270 IF(IP2.NE.1) THEN
40271C...Anomalous parametrizations for different strategies
40272C...for off-shell photons; except full integration.
40273
40274C...Call anomalous parametrization for d + u + s.
40275 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40276 DO 120 KFL=-5,5
40277 XPANL(KFL)=FACNOR*XPGA(KFL)
40278 VXPANL(KFL)=FACNOR*VXPGA(KFL)
40279 120 CONTINUE
40280
40281C...Call anomalous parametrization for c and b.
40282 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40283 DO 130 KFL=-5,5
40284 XPANH(KFL)=FACNOR*XPGA(KFL)
40285 VXPANH(KFL)=FACNOR*VXPGA(KFL)
40286 130 CONTINUE
40287 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40288 DO 140 KFL=-5,5
40289 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
40290 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
40291 140 CONTINUE
40292
40293 ELSE
40294C...Special option: loop over flavours and integrate over k2.
40295 DO 170 KF=1,5
40296 DO 160 ISTEP=1,NSTEP
40297 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
40298 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
40299 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
40300 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
40301 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
40302 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
40303 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
40304 DO 150 KFL=-5,5
40305 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
40306 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
40307 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
40308 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
40309 150 CONTINUE
40310 160 CONTINUE
40311 170 CONTINUE
40312 ENDIF
40313
40314C...Call Bethe-Heitler term expression for charm and bottom.
40315 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
40316 XPBEH(4)=XPBH
40317 XPBEH(-4)=XPBH
40318 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
40319 XPBEH(5)=XPBH
40320 XPBEH(-5)=XPBH
40321
40322C...For MSbar subtraction call C^gamma term expression for d, u, s.
40323 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
40324 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
40325 DO 180 KFL=-5,5
40326 XPDIR(KFL)=XPGA(KFL)
40327 180 CONTINUE
40328 ENDIF
40329
40330C...Store result in output array.
40331 DO 190 KFL=-5,5
40332 CHSQ=1D0/9D0
40333 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
40334 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
40335 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
40336 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
40337 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
40338 190 CONTINUE
40339
40340 RETURN
40341 END
40342
40343C*********************************************************************
40344
40345C...PYGVMD
40346C...Evaluates the VMD parton distributions of a photon,
40347C...evolved homogeneously from an initial scale P2 to Q2.
40348C...Does not include dipole suppression factor.
40349C...ISET is parton distribution set, see above;
40350C...additionally ISET=0 is used for the evolution of an anomalous photon
40351C...which branched at a scale P2 and then evolved homogeneously to Q2.
40352C...ALAM is the 4-flavour Lambda, which is automatically converted
40353C...to 3- and 5-flavour equivalents as needed.
40354C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40355
40356 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40357
40358C...Double precision and integer declarations.
40359 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40360 IMPLICIT INTEGER(I-N)
40361 INTEGER PYK,PYCHGE,PYCOMP
40362C...Local arrays and data.
40363 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40364 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
40365
40366C...Reset output.
40367 DO 100 KFL=-6,6
40368 XPGA(KFL)=0D0
40369 VXPGA(KFL)=0D0
40370 100 CONTINUE
40371 KFA=IABS(KF)
40372
40373C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40374 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
40375 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
40376 P2EFF=MAX(P2,1.2D0*ALAM3**2)
40377 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40378 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40379 Q2EFF=MAX(Q2,P2EFF)
40380
40381C...Find number of flavours at lower and upper scale.
40382 NFP=4
40383 IF(P2EFF.LT.PMC**2) NFP=3
40384 IF(P2EFF.GT.PMB**2) NFP=5
40385 NFQ=4
40386 IF(Q2EFF.LT.PMC**2) NFQ=3
40387 IF(Q2EFF.GT.PMB**2) NFQ=5
40388
40389C...Find s as sum of 3-, 4- and 5-flavour parts.
40390 S=0D0
40391 IF(NFP.EQ.3) THEN
40392 Q2DIV=PMC**2
40393 IF(NFQ.EQ.3) Q2DIV=Q2EFF
40394 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
40395 ENDIF
40396 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
40397 P2DIV=P2EFF
40398 IF(NFP.EQ.3) P2DIV=PMC**2
40399 Q2DIV=Q2EFF
40400 IF(NFQ.EQ.5) Q2DIV=PMB**2
40401 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
40402 ENDIF
40403 IF(NFQ.EQ.5) THEN
40404 P2DIV=PMB**2
40405 IF(NFP.EQ.5) P2DIV=P2EFF
40406 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
40407 ENDIF
40408
40409C...Calculate frequent combinations of x and s.
40410 X1=1D0-X
40411 XL=-LOG(X)
40412 S2=S**2
40413 S3=S**3
40414 S4=S**4
40415
40416C...Evaluate homogeneous anomalous parton distributions below or
40417C...above threshold.
40418 IF(ISET.EQ.0) THEN
40419 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40420 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40421 XVAL = X * 1.5D0 * (X**2+X1**2)
40422 XGLU = 0D0
40423 XSEA = 0D0
40424 ELSE
40425 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
40426 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
40427 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
40428 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
40429 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
40430 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
40431 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
40432 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
40433 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
40434 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
40435 & (2D0*X-1D0)*X*XL**2)
40436 ENDIF
40437
40438C...Evaluate set 1D parton distributions below or above threshold.
40439 ELSEIF(ISET.EQ.1) THEN
40440 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40441 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40442 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
40443 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
40444 XSEA = 0.100D0 * X1**3.76D0
40445 ELSE
40446 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
40447 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
40448 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
40449 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
40450 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
40451 & X**0.40D0 * X1**(1.76D0+3D0*S)
40452 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
40453 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
40454 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
40455 XSEA0 = 0.100D0 * X1**3.76D0
40456 ENDIF
40457
40458C...Evaluate set 1M parton distributions below or above threshold.
40459 ELSEIF(ISET.EQ.2) THEN
40460 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40461 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40462 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
40463 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
40464 XSEA = 0D0
40465 ELSE
40466 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
40467 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
40468 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
40469 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
40470 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
40471 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
40472 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
40473 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
40474 & XL**(2.8D0*S)
40475 XSEA0 = 0D0
40476 ENDIF
40477
40478C...Evaluate set 2D parton distributions below or above threshold.
40479 ELSEIF(ISET.EQ.3) THEN
40480 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40481 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40482 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
40483 XGLU = 1.925D0 * X1**2
40484 XSEA = 0.242D0 * X1**4
40485 ELSE
40486 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
40487 & X**(0.46D0+0.25D0*S) *
40488 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
40489 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
40490 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
40491 & EXP(-18.67D0*S) *
40492 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
40493 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
40494 & XL**(9.3D0*S/(1D0+1.7D0*S))
40495 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
40496 & (1D0-0.607D0*S+21.95D0*S2) *
40497 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
40498 XSEA0 = 0.242D0 * X1**4
40499 ENDIF
40500
40501C...Evaluate set 2M parton distributions below or above threshold.
40502 ELSEIF(ISET.EQ.4) THEN
40503 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40504 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40505 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
40506 XGLU = 1.808D0 * X1**2
40507 XSEA = 0.209D0 * X1**4
40508 ELSE
40509 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
40510 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
40511 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
40512 & XL**(5.15D0*S/(1D0+2D0*S)) +
40513 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
40514 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
40515 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
40516 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
40517 & XL**(10.9D0*S/(1D0+2.5D0*S))
40518 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
40519 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
40520 & X1**(4D0+S) * XL**(0.45D0*S)
40521 XSEA0 = 0.209D0 * X1**4
40522 ENDIF
40523 ENDIF
40524
40525C...Threshold factors for c and b sea.
40526 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40527 XCHM=0D0
40528 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40529 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40530 IF(ISET.EQ.0) THEN
40531 XCHM=XSEA*(1D0-(SCH/SLL)**2)
40532 ELSE
40533 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
40534 ENDIF
40535 ENDIF
40536 XBOT=0D0
40537 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40538 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40539 IF(ISET.EQ.0) THEN
40540 XBOT=XSEA*(1D0-(SBT/SLL)**2)
40541 ELSE
40542 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
40543 ENDIF
40544 ENDIF
40545
40546C...Fill parton distributions.
40547 XPGA(0)=XGLU
40548 XPGA(1)=XSEA
40549 XPGA(2)=XSEA
40550 XPGA(3)=XSEA
40551 XPGA(4)=XCHM
40552 XPGA(5)=XBOT
40553 XPGA(KFA)=XPGA(KFA)+XVAL
40554 DO 110 KFL=1,5
40555 XPGA(-KFL)=XPGA(KFL)
40556 110 CONTINUE
40557 VXPGA(KFA)=XVAL
40558 VXPGA(-KFA)=XVAL
40559
40560 RETURN
40561 END
40562
40563C*********************************************************************
40564
40565C...PYGANO
40566C...Evaluates the parton distributions of the anomalous photon,
40567C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
40568C...KF=0 gives the sum over (up to) 5 flavours,
40569C...KF<0 limits to flavours up to abs(KF),
40570C...KF>0 is for flavour KF only.
40571C...ALAM is the 4-flavour Lambda, which is automatically converted
40572C...to 3- and 5-flavour equivalents as needed.
40573C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40574
40575 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40576
40577C...Double precision and integer declarations.
40578 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40579 IMPLICIT INTEGER(I-N)
40580 INTEGER PYK,PYCHGE,PYCOMP
40581C...Local arrays and data.
40582 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
40583 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
40584
40585C...Reset output.
40586 DO 100 KFL=-6,6
40587 XPGA(KFL)=0D0
40588 VXPGA(KFL)=0D0
40589 100 CONTINUE
40590 IF(Q2.LE.P2) RETURN
40591 KFA=IABS(KF)
40592
40593C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40594 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
40595 ALAMSQ(4)=ALAM**2
40596 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
40597 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
40598 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40599 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40600 Q2EFF=MAX(Q2,P2EFF)
40601 XL=-LOG(X)
40602
40603C...Find number of flavours at lower and upper scale.
40604 NFP=4
40605 IF(P2EFF.LT.PMC**2) NFP=3
40606 IF(P2EFF.GT.PMB**2) NFP=5
40607 NFQ=4
40608 IF(Q2EFF.LT.PMC**2) NFQ=3
40609 IF(Q2EFF.GT.PMB**2) NFQ=5
40610
40611C...Define range of flavour loop.
40612 IF(KF.EQ.0) THEN
40613 KFLMN=1
40614 KFLMX=5
40615 ELSEIF(KF.LT.0) THEN
40616 KFLMN=1
40617 KFLMX=KFA
40618 ELSE
40619 KFLMN=KFA
40620 KFLMX=KFA
40621 ENDIF
40622
40623C...Loop over flavours the photon can branch into.
40624 DO 110 KFL=KFLMN,KFLMX
40625
40626C...Light flavours: calculate t range and (approximate) s range.
40627 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
40628 TDIFF=LOG(Q2EFF/P2EFF)
40629 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
40630 & LOG(P2EFF/ALAMSQ(NFQ)))
40631 IF(NFQ.GT.NFP) THEN
40632 Q2DIV=PMB**2
40633 IF(NFQ.EQ.4) Q2DIV=PMC**2
40634 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
40635 & LOG(P2EFF/ALAMSQ(NFQ)))
40636 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
40637 & LOG(P2EFF/ALAMSQ(NFQ-1)))
40638 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
40639 ENDIF
40640 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
40641 Q2DIV=PMC**2
40642 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
40643 & LOG(P2EFF/ALAMSQ(4)))
40644 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
40645 & LOG(P2EFF/ALAMSQ(3)))
40646 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
40647 ENDIF
40648
40649C...u and s quark do not need a separate treatment when d has been done.
40650 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
40651
40652C...Charm: as above, but only include range above c threshold.
40653 ELSEIF(KFL.EQ.4) THEN
40654 IF(Q2.LE.PMC**2) GOTO 110
40655 P2EFF=MAX(P2EFF,PMC**2)
40656 Q2EFF=MAX(Q2EFF,P2EFF)
40657 TDIFF=LOG(Q2EFF/P2EFF)
40658 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
40659 & LOG(P2EFF/ALAMSQ(NFQ)))
40660 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
40661 Q2DIV=PMB**2
40662 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
40663 & LOG(P2EFF/ALAMSQ(NFQ)))
40664 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
40665 & LOG(P2EFF/ALAMSQ(NFQ-1)))
40666 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
40667 ENDIF
40668
40669C...Bottom: as above, but only include range above b threshold.
40670 ELSEIF(KFL.EQ.5) THEN
40671 IF(Q2.LE.PMB**2) GOTO 110
40672 P2EFF=MAX(P2EFF,PMB**2)
40673 Q2EFF=MAX(Q2,P2EFF)
40674 TDIFF=LOG(Q2EFF/P2EFF)
40675 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
40676 & LOG(P2EFF/ALAMSQ(NFQ)))
40677 ENDIF
40678
40679C...Evaluate flavour-dependent prefactor (charge^2 etc.).
40680 CHSQ=1D0/9D0
40681 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
40682 FAC=AEM2PI*2D0*CHSQ*TDIFF
40683
40684C...Evaluate parton distributions (normalized to unit momentum sum).
40685 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
40686 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
40687 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
40688 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
40689 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
40690 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
40691 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
40692 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
40693 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
40694 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
40695 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
40696 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
40697
40698C...Threshold factors for c and b sea.
40699 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40700 XCHM=0D0
40701 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40702 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40703 XCHM=XSEA*(1D0-(SCH/SLL)**3)
40704 ENDIF
40705 XBOT=0D0
40706 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40707 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40708 XBOT=XSEA*(1D0-(SBT/SLL)**3)
40709 ENDIF
40710 ENDIF
40711
40712C...Add contribution of each valence flavour.
40713 XPGA(0)=XPGA(0)+FAC*XGLU
40714 XPGA(1)=XPGA(1)+FAC*XSEA
40715 XPGA(2)=XPGA(2)+FAC*XSEA
40716 XPGA(3)=XPGA(3)+FAC*XSEA
40717 XPGA(4)=XPGA(4)+FAC*XCHM
40718 XPGA(5)=XPGA(5)+FAC*XBOT
40719 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
40720 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
40721 110 CONTINUE
40722 DO 120 KFL=1,5
40723 XPGA(-KFL)=XPGA(KFL)
40724 VXPGA(-KFL)=VXPGA(KFL)
40725 120 CONTINUE
40726
40727 RETURN
40728 END
40729
40730
40731C*********************************************************************
40732
40733C...PYGBEH
40734C...Evaluates the Bethe-Heitler cross section for heavy flavour
40735C...production.
40736C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40737
40738 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
40739
40740C...Double precision and integer declarations.
40741 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40742 IMPLICIT INTEGER(I-N)
40743 INTEGER PYK,PYCHGE,PYCOMP
40744
40745C...Local data.
40746 DATA AEM2PI/0.0011614D0/
40747
40748C...Reset output.
40749 XPBH=0D0
40750 SIGBH=0D0
40751
40752C...Check kinematics limits.
40753 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
40754 W2=Q2*(1D0-X)/X-P2
40755 BETA2=1D0-4D0*PM2/W2
40756 IF(BETA2.LT.1D-10) RETURN
40757 BETA=SQRT(BETA2)
40758 RMQ=4D0*PM2/Q2
40759
40760C...Simple case: P2 = 0.
40761 IF(P2.LT.1D-4) THEN
40762 IF(BETA.LT.0.99D0) THEN
40763 XBL=LOG((1D0+BETA)/(1D0-BETA))
40764 ELSE
40765 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
40766 ENDIF
40767 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
40768 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
40769
40770C...Complicated case: P2 > 0, based on approximation of
40771C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
40772 ELSE
40773 RPQ=1D0-4D0*X**2*P2/Q2
40774 IF(RPQ.GT.1D-10) THEN
40775 RPBE=SQRT(RPQ*BETA2)
40776 IF(RPBE.LT.0.99D0) THEN
40777 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
40778 XBI=2D0*RPBE/(1D0-RPBE**2)
40779 ELSE
40780 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
40781 XBL=LOG((1D0+RPBE)**2/RPBESN)
40782 XBI=2D0*RPBE/RPBESN
40783 ENDIF
40784 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
40785 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
40786 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
40787 ENDIF
40788 ENDIF
40789
40790C...Multiply by charge-squared etc. to get parton distribution.
40791 CHSQ=1D0/9D0
40792 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
40793 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
40794
40795 RETURN
40796 END
40797
40798C*********************************************************************
40799
40800C...PYGDIR
40801C...Evaluates the direct contribution, i.e. the C^gamma term,
40802C...as needed in MSbar parametrizations.
40803C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40804
40805 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
40806
40807C...Double precision and integer declarations.
40808 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40809 IMPLICIT INTEGER(I-N)
40810 INTEGER PYK,PYCHGE,PYCOMP
40811C...Local array and data.
40812 DIMENSION XPGA(-6:6)
40813 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
40814
40815C...Reset output.
40816 DO 100 KFL=-6,6
40817 XPGA(KFL)=0D0
40818 100 CONTINUE
40819
40820C...Evaluate common x-dependent expression.
40821 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
40822 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
40823
40824C...d, u, s part by simple charge factor.
40825 XPGA(1)=(1D0/9D0)*CGAM
40826 XPGA(2)=(4D0/9D0)*CGAM
40827 XPGA(3)=(1D0/9D0)*CGAM
40828
40829C...Also fill for antiquarks.
40830 DO 110 KF=1,5
40831 XPGA(-KF)=XPGA(KF)
40832 110 CONTINUE
40833
40834 RETURN
40835 END
40836
40837C*********************************************************************
40838
40839C...PYPDPI
40840C...Gives pi+ parton distribution according to two different
40841C...parametrizations.
40842
40843 SUBROUTINE PYPDPI(X,Q2,XPPI)
40844
40845C...Double precision and integer declarations.
40846 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40847 IMPLICIT INTEGER(I-N)
40848 INTEGER PYK,PYCHGE,PYCOMP
40849C...Commonblocks.
40850 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40851 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40852 COMMON/PYINT1/MINT(400),VINT(400)
40853 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40854C...Local arrays.
40855 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
40856
40857C...The following data lines are coefficients needed in the
40858C...Owens pion parton distribution parametrizations, see below.
40859C...Expansion coefficients for up and down valence quark distributions.
40860 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
40861 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40862 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40863 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40864 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
40865 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40866 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40867 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40868C...Expansion coefficients for gluon distribution.
40869 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
40870 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
40871 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
40872 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
40873 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
40874 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
40875 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
40876 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
40877C...Expansion coefficients for (up+down+strange) quark sea distribution.
40878 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
40879 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40880 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
40881 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
40882 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
40883 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40884 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
40885 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
40886C...Expansion coefficients for charm quark sea distribution.
40887 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
40888 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
40889 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
40890 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
40891 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
40892 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
40893 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
40894 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
40895
40896C...Euler's beta function, requires ordinary Gamma function
40897 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
40898
40899C...Reset output array.
40900 DO 100 KFL=-6,6
40901 XPPI(KFL)=0D0
40902 100 CONTINUE
40903
40904 IF(MSTP(53).LE.2) THEN
40905C...Pion parton distributions from Owens.
40906C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
40907
40908C...Determine set, Lambda and s expansion variable.
40909 NSET=MSTP(53)
40910 IF(NSET.EQ.1) ALAM=0.2D0
40911 IF(NSET.EQ.2) ALAM=0.4D0
40912 VINT(231)=4D0
40913 IF(MSTP(57).LE.0) THEN
40914 SD=0D0
40915 ELSE
40916 Q2IN=MIN(2D3,MAX(4D0,Q2))
40917 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
40918 ENDIF
40919
40920C...Calculate parton distributions.
40921 DO 120 KFL=1,4
40922 DO 110 IS=1,5
40923 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
40924 & COW(3,IS,KFL,NSET)*SD**2
40925 110 CONTINUE
40926 IF(KFL.EQ.1) THEN
40927 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
40928 ELSE
40929 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
40930 & TS(5)*X**2)
40931 ENDIF
40932 120 CONTINUE
40933
40934C...Put into output array.
40935 XPPI(0)=XQ(2)
40936 XPPI(1)=XQ(3)/6D0
40937 XPPI(2)=XQ(1)+XQ(3)/6D0
40938 XPPI(3)=XQ(3)/6D0
40939 XPPI(4)=XQ(4)
40940 XPPI(-1)=XQ(1)+XQ(3)/6D0
40941 XPPI(-2)=XQ(3)/6D0
40942 XPPI(-3)=XQ(3)/6D0
40943 XPPI(-4)=XQ(4)
40944
40945C...Leading order pion parton distributions from Glueck, Reya and Vogt.
40946C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40947C...10^-5 < x < 1.
40948 ELSE
40949
40950C...Determine s expansion variable and some x expressions.
40951 VINT(231)=0.25D0
40952 IF(MSTP(57).LE.0) THEN
40953 SD=0D0
40954 ELSE
40955 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
40956 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
40957 ENDIF
40958 SD2=SD**2
40959 XL=-LOG(X)
40960 XS=SQRT(X)
40961
40962C...Evaluate valence, gluon and sea distributions.
40963 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
40964 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
40965 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
40966 & SD-0.175D0*SD2)+
40967 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
40968 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
40969 & XL)))*
40970 & (1D0-X)**(0.390D0+1.053D0*SD)
40971 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
40972 & X)**3.359D0*
40973 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
40974 & XL))/
40975 & XL**(2.538D0-0.763D0*SD)
40976 IF(SD.LE.0.888D0) THEN
40977 XFCHM=0D0
40978 ELSE
40979 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
40980 & 0.771D0*SD)*
40981 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
40982 & XL))
40983 ENDIF
40984 IF(SD.LE.1.351D0) THEN
40985 XFBOT=0D0
40986 ELSE
40987 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
40988 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
40989 & XL))
40990 ENDIF
40991
40992C...Put into output array.
40993 XPPI(0)=XFGLU
40994 XPPI(1)=XFSEA
40995 XPPI(2)=XFSEA
40996 XPPI(3)=XFSEA
40997 XPPI(4)=XFCHM
40998 XPPI(5)=XFBOT
40999 DO 130 KFL=1,5
41000 XPPI(-KFL)=XPPI(KFL)
41001 130 CONTINUE
41002 XPPI(2)=XPPI(2)+XFVAL
41003 XPPI(-1)=XPPI(-1)+XFVAL
41004 ENDIF
41005
41006 RETURN
41007 END
41008
41009C*********************************************************************
41010
41011C...PYPDPR
41012C...Gives proton parton distributions according to a few different
41013C...parametrizations.
41014
41015 SUBROUTINE PYPDPR(X,Q2,XPPR)
41016
41017C...Double precision and integer declarations.
41018 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41019 IMPLICIT INTEGER(I-N)
41020 INTEGER PYK,PYCHGE,PYCOMP
41021C...Commonblocks.
41022 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41023 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41024 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41025 COMMON/PYINT1/MINT(400),VINT(400)
41026 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
41027C...Arrays and data.
41028 DIMENSION XPPR(-6:6),Q2MIN(16)
41029 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
41030 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
41031
41032C...Reset output array.
41033 DO 100 KFL=-6,6
41034 XPPR(KFL)=0D0
41035 100 CONTINUE
41036
41037C...Common preliminaries.
41038 NSET=MAX(1,MIN(16,MSTP(51)))
41039 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
41040 VINT(231)=Q2MIN(NSET)
41041 IF(MSTP(57).EQ.0) THEN
41042 Q2L=Q2MIN(NSET)
41043 ELSE
41044 Q2L=MAX(Q2MIN(NSET),Q2)
41045 ENDIF
41046
41047 IF(NSET.GE.1.AND.NSET.LE.3) THEN
41048C...Interface to the CTEQ 3 parton distributions.
41049 QRT=SQRT(MAX(1D0,Q2L))
41050
41051C...Loop over flavours.
41052 DO 110 I=-6,6
41053 IF(I.LE.0) THEN
41054 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
41055 ELSEIF(I.LE.2) THEN
41056 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
41057 ELSE
41058 XPPR(I)=XPPR(-I)
41059 ENDIF
41060 110 CONTINUE
41061
41062 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
41063C...Interface to the GRV 94 distributions.
41064 IF(NSET.EQ.4) THEN
41065 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41066 ELSEIF(NSET.EQ.5) THEN
41067 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41068 ELSE
41069 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41070 ENDIF
41071
41072C...Put into output array.
41073 XPPR(0)=GL
41074 XPPR(-1)=0.5D0*(UDB+DEL)
41075 XPPR(-2)=0.5D0*(UDB-DEL)
41076 XPPR(-3)=SB
41077 XPPR(-4)=CHM
41078 XPPR(-5)=BOT
41079 XPPR(1)=DV+XPPR(-1)
41080 XPPR(2)=UV+XPPR(-2)
41081 XPPR(3)=SB
41082 XPPR(4)=CHM
41083 XPPR(5)=BOT
41084
41085 ELSEIF(NSET.EQ.7) THEN
41086C...Interface to the CTEQ 5L parton distributions.
41087C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
41088C...freezing x*f(x,Q2) at borders.
41089 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
41090 XIN=MAX(1D-6,MIN(1D0,X))
41091
41092C...Loop over flavours (with u <-> d notation mismatch).
41093 SUMUDB=PYCT5L(-1,XIN,QRT)
41094 RATUDB=PYCT5L(-2,XIN,QRT)
41095 DO 120 I=-5,2
41096 IF(I.EQ.1) THEN
41097 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
41098 ELSEIF(I.EQ.2) THEN
41099 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
41100 ELSEIF(I.EQ.-1) THEN
41101 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
41102 ELSEIF(I.EQ.-2) THEN
41103 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
41104 ELSE
41105 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
41106 IF(I.LT.0) XPPR(-I)=XPPR(I)
41107 ENDIF
41108 120 CONTINUE
41109
41110 ELSEIF(NSET.EQ.8) THEN
41111C...Interface to the CTEQ 5M1 parton distributions.
41112 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
41113 XIN=MAX(1D-6,MIN(1D0,X))
41114
41115C...Loop over flavours (with u <-> d notation mismatch).
41116 SUMUDB=PYCT5M(-1,XIN,QRT)
41117 RATUDB=PYCT5M(-2,XIN,QRT)
41118 DO 130 I=-5,2
41119 IF(I.EQ.1) THEN
41120 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
41121 ELSEIF(I.EQ.2) THEN
41122 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
41123 ELSEIF(I.EQ.-1) THEN
41124 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
41125 ELSEIF(I.EQ.-2) THEN
41126 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
41127 ELSE
41128 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
41129 IF(I.LT.0) XPPR(-I)=XPPR(I)
41130 ENDIF
41131 130 CONTINUE
41132
41133 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
41134C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
41135C...obsolete but offers backwards compatibility.
41136 CALL PYPDPO(X,Q2L,XPPR)
41137
41138C...Symmetric choice for debugging only
41139 ELSEIF(NSET.EQ.16) THEN
41140 XPPR(0)=.5D0/X
41141 XPPR(1)=.05D0/X
41142 XPPR(2)=.05D0/X
41143 XPPR(3)=.05D0/X
41144 XPPR(4)=.05D0/X
41145 XPPR(5)=.05D0/X
41146 XPPR(-1)=.05D0/X
41147 XPPR(-2)=.05D0/X
41148 XPPR(-3)=.05D0/X
41149 XPPR(-4)=.05D0/X
41150 XPPR(-5)=.05D0/X
41151
41152 ENDIF
41153
41154 RETURN
41155 END
41156
41157C*********************************************************************
41158
41159C...PYCTEQ
41160C...Gives the CTEQ 3 parton distribution function sets in
41161C...parametrized form, of October 24, 1994.
41162C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
41163C...J. Qiu, W.K. Tung and H. Weerts.
41164
41165 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
41166
41167C...Double precision declaration.
41168 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41169 IMPLICIT INTEGER(I-N)
41170
41171C...Data on Lambda values of fits, minimum Q and quark masses.
41172 DIMENSION ALM(3), QMS(4:6)
41173 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
41174 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
41175
41176C....Check flavour thresholds. Set up QI for SB.
41177 IP = IABS(IPRT)
41178 IF(IP .GE. 4) THEN
41179 IF(Q .LE. QMS(IP)) THEN
41180 PYCTEQ = 0D0
41181 RETURN
41182 ENDIF
41183 QI = QMS(IP)
41184 ELSE
41185 QI = QMN
41186 ENDIF
41187
41188C...Use "standard lambda" of parametrization program for expansion.
41189 ALAM = ALM (ISET)
41190 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
41191 SB = LOG (SBL)
41192 SB2 = SB*SB
41193 SB3 = SB2*SB
41194
41195C...Expansion for CTEQ3L.
41196 IF(ISET .EQ. 1) THEN
41197 IF(IPRT .EQ. 2) THEN
41198 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
41199 & 0.3171D+00*SB3)
41200 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
41201 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
41202 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
41203 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
41204 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
41205 ELSEIF(IPRT .EQ. 1) THEN
41206 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
41207 & 0.7728D+00*SB3)
41208 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
41209 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
41210 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
41211 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
41212 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
41213 ELSEIF(IPRT .EQ. 0) THEN
41214 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
41215 & 0.5343D+00*SB3)
41216 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
41217 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
41218 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
41219 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
41220 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
41221 ELSEIF(IPRT .EQ. -1) THEN
41222 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
41223 & 0.2031D+01*SB3)
41224 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
41225 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
41226 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
41227 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
41228 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
41229 ELSEIF(IPRT .EQ. -2) THEN
41230 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
41231 & 0.9872D-01*SB3)
41232 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
41233 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
41234 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
41235 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
41236 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
41237 ELSEIF(IPRT .EQ. -3) THEN
41238 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
41239 & 0.8390D+00*SB3)
41240 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
41241 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
41242 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
41243 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
41244 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
41245 ELSEIF(IPRT .EQ. -4) THEN
41246 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
41247 & 0.1651D-01*SB2)
41248 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
41249 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
41250 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
41251 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
41252 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
41253 ELSEIF(IPRT .EQ. -5) THEN
41254 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
41255 & 0.3702D+01*SB2)
41256 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
41257 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
41258 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
41259 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
41260 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
41261 ELSEIF(IPRT .EQ. -6) THEN
41262 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
41263 & 0.6943D+00*SB2)
41264 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
41265 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
41266 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
41267 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
41268 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
41269 ENDIF
41270
41271C...Expansion for CTEQ3M.
41272 ELSEIF(ISET .EQ. 2) THEN
41273 IF(IPRT .EQ. 2) THEN
41274 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
41275 & 0.2935D+00*SB3)
41276 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
41277 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
41278 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
41279 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
41280 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
41281 ELSEIF(IPRT .EQ. 1) THEN
41282 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
41283 & 0.4305D-01*SB3)
41284 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
41285 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
41286 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
41287 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
41288 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
41289 ELSEIF(IPRT .EQ. 0) THEN
41290 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
41291 & 0.1037D-01*SB3)
41292 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
41293 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
41294 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
41295 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
41296 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
41297 ELSEIF(IPRT .EQ. -1) THEN
41298 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
41299 & 0.1602D+01*SB3)
41300 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
41301 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
41302 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
41303 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
41304 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
41305 ELSEIF(IPRT .EQ. -2) THEN
41306 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
41307 & 0.2496D+00*SB3)
41308 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
41309 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
41310 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
41311 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
41312 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
41313 ELSEIF(IPRT .EQ. -3) THEN
41314 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
41315 & 0.1936D+01*SB3)
41316 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
41317 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
41318 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
41319 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
41320 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
41321 ELSEIF(IPRT .EQ. -4) THEN
41322 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
41323 & 0.5348D+00*SB2)
41324 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
41325 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
41326 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
41327 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
41328 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
41329 ELSEIF(IPRT .EQ. -5) THEN
41330 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
41331 & 0.1569D+01*SB2)
41332 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
41333 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
41334 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
41335 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
41336 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
41337 ELSEIF(IPRT .EQ. -6) THEN
41338 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
41339 & 0.8838D+01*SB2)
41340 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
41341 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
41342 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
41343 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
41344 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
41345 ENDIF
41346
41347C...Expansion for CTEQ3D.
41348 ELSEIF(ISET .EQ. 3) THEN
41349 IF(IPRT .EQ. 2) THEN
41350 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
41351 & 0.2902D+00*SB3)
41352 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
41353 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
41354 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
41355 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
41356 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
41357 ELSEIF(IPRT .EQ. 1) THEN
41358 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
41359 & 0.7257D+00*SB3)
41360 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
41361 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
41362 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
41363 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
41364 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
41365 ELSEIF(IPRT .EQ. 0) THEN
41366 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
41367 & 0.2734D-04*SB3)
41368 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
41369 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
41370 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
41371 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
41372 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
41373 ELSEIF(IPRT .EQ. -1) THEN
41374 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
41375 & 0.1671D+01*SB3)
41376 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
41377 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
41378 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
41379 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
41380 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
41381 ELSEIF(IPRT .EQ. -2) THEN
41382 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
41383 & 0.2223D+00*SB3)
41384 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
41385 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
41386 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
41387 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
41388 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
41389 ELSEIF(IPRT .EQ. -3) THEN
41390 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
41391 & 0.1937D+01*SB3)
41392 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
41393 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
41394 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
41395 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
41396 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
41397 ELSEIF(IPRT .EQ. -4) THEN
41398 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
41399 & 0.5137D+00*SB2)
41400 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
41401 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
41402 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
41403 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
41404 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
41405 ELSEIF(IPRT .EQ. -5) THEN
41406 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
41407 & 0.2143D+01*SB2)
41408 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
41409 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
41410 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
41411 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
41412 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
41413 ELSEIF(IPRT .EQ. -6) THEN
41414 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
41415 & 0.9998D+01*SB2)
41416 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
41417 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
41418 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
41419 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
41420 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
41421 ENDIF
41422 ENDIF
41423
41424C...Calculation of x * f(x, Q).
41425 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
41426 & *(LOG(1D0+1D0/X))**A5 )
41427
41428 RETURN
41429 END
41430
41431C*********************************************************************
41432
41433C...PYGRVL
41434C...Gives the GRV 94 L (leading order) parton distribution function set
41435C...in parametrized form.
41436C...Authors: M. Glueck, E. Reya and A. Vogt.
41437
41438 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41439
41440C...Double precision declaration.
41441 IMPLICIT DOUBLE PRECISION (A - Z)
41442
41443C...Common expressions.
41444 MU2 = 0.23D0
41445 LAM2 = 0.2322D0 * 0.2322D0
41446 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
41447 DS = SQRT (S)
41448 S2 = S * S
41449 S3 = S2 * S
41450
41451C...uv :
41452 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
41453 AKU = 0.590D0 - 0.024D0 * S
41454 BKU = 0.131D0 + 0.063D0 * S
41455 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
41456 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
41457 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
41458 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
41459 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
41460
41461C...dv :
41462 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
41463 AKD = 0.376D0
41464 BKD = 0.486D0 + 0.062D0 * S
41465 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
41466 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
41467 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
41468 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
41469 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
41470
41471C...del :
41472 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
41473 AKE = 0.409D0 - 0.005D0 * S
41474 BKE = 0.799D0 + 0.071D0 * S
41475 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
41476 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
41477 CE = 0.0D0
41478 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
41479 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
41480
41481C...udb :
41482 ALX = 1.451D0
41483 BEX = 0.271D0
41484 AKX = 0.410D0 - 0.232D0 * S
41485 BKX = 0.534D0 - 0.457D0 * S
41486 AGX = 0.890D0 - 0.140D0 * S
41487 BGX = -0.981D0
41488 CX = 0.320D0 + 0.683D0 * S
41489 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
41490 EX = 4.119D0 + 1.713D0 * S
41491 ESX = 0.682D0 + 2.978D0 * S
41492 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
41493 & DX, EX, ESX)
41494
41495C...sb :
41496 STS = 0D0
41497 ALS = 0.914D0
41498 BES = 0.577D0
41499 AKS = 1.798D0 - 0.596D0 * S
41500 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
41501 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
41502 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
41503 EST = 3.981D0 + 1.638D0 * S
41504 ESS = 6.402D0
41505 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
41506
41507C...cb :
41508 STC = 0.888D0
41509 ALC = 1.01D0
41510 BEC = 0.37D0
41511 AKC = 0D0
41512 AC = 0D0
41513 BC = 4.24D0 - 0.804D0 * S
41514 DCT = 3.46D0 - 1.076D0 * S
41515 ECT = 4.61D0 + 1.49D0 * S
41516 ESC = 2.555D0 + 1.961D0 * S
41517 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
41518
41519C...bb :
41520 STB = 1.351D0
41521 ALB = 1.00D0
41522 BEB = 0.51D0
41523 AKB = 0D0
41524 AB = 0D0
41525 BB = 1.848D0
41526 DBT = 2.929D0 + 1.396D0 * S
41527 EBT = 4.71D0 + 1.514D0 * S
41528 ESB = 4.02D0 + 1.239D0 * S
41529 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
41530
41531C...gl :
41532 ALG = 0.524D0
41533 BEG = 1.088D0
41534 AKG = 1.742D0 - 0.930D0 * S
41535 BKG = - 0.399D0 * S2
41536 AG = 7.486D0 - 2.185D0 * S
41537 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
41538 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
41539 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
41540 EG = 0.807D0 + 2.005D0 * S
41541 ESG = 3.841D0 + 0.316D0 * S
41542 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
41543 & DG, EG, ESG)
41544
41545 RETURN
41546 END
41547
41548C*********************************************************************
41549
41550C...PYGRVM
41551C...Gives the GRV 94 M (MSbar) parton distribution function set
41552C...in parametrized form.
41553C...Authors: M. Glueck, E. Reya and A. Vogt.
41554
41555 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41556
41557C...Double precision declaration.
41558 IMPLICIT DOUBLE PRECISION (A - Z)
41559
41560C...Common expressions.
41561 MU2 = 0.34D0
41562 LAM2 = 0.248D0 * 0.248D0
41563 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
41564 DS = SQRT (S)
41565 S2 = S * S
41566 S3 = S2 * S
41567
41568C...uv :
41569 NU = 1.304D0 + 0.863D0 * S
41570 AKU = 0.558D0 - 0.020D0 * S
41571 BKU = 0.183D0 * S
41572 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
41573 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
41574 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
41575 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
41576 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
41577
41578C...dv :
41579 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
41580 AKD = 0.270D0 - 0.019D0 * S
41581 BKD = 0.260D0
41582 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
41583 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
41584 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
41585 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
41586 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
41587
41588C...del :
41589 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
41590 AKE = 0.409D0 - 0.007D0 * S
41591 BKE = 0.782D0 + 0.082D0 * S
41592 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
41593 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
41594 CE = 0.0D0
41595 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
41596 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
41597
41598C...udb :
41599 ALX = 0.877D0
41600 BEX = 0.561D0
41601 AKX = 0.275D0
41602 BKX = 0.0D0
41603 AGX = 0.997D0
41604 BGX = 3.210D0 - 1.866D0 * S
41605 CX = 7.300D0
41606 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
41607 EX = 3.077D0 + 1.446D0 * S
41608 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
41609 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
41610 & DX, EX, ESX)
41611
41612C...sb :
41613 STS = 0D0
41614 ALS = 0.756D0
41615 BES = 0.216D0
41616 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
41617 AS = -4.329D0 + 1.131D0 * S
41618 BS = 9.568D0 - 1.744D0 * S
41619 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
41620 EST = 3.031D0 + 1.639D0 * S
41621 ESS = 5.837D0 + 0.815D0 * S
41622 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
41623
41624C...cb :
41625 STC = 0.820D0
41626 ALC = 0.98D0
41627 BEC = 0D0
41628 AKC = -0.625D0 - 0.523D0 * S
41629 AC = 0D0
41630 BC = 1.896D0 + 1.616D0 * S
41631 DCT = 4.12D0 + 0.683D0 * S
41632 ECT = 4.36D0 + 1.328D0 * S
41633 ESC = 0.677D0 + 0.679D0 * S
41634 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
41635
41636C...bb :
41637 STB = 1.297D0
41638 ALB = 0.99D0
41639 BEB = 0D0
41640 AKB = - 0.193D0 * S
41641 AB = 0D0
41642 BB = 0D0
41643 DBT = 3.447D0 + 0.927D0 * S
41644 EBT = 4.68D0 + 1.259D0 * S
41645 ESB = 1.892D0 + 2.199D0 * S
41646 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
41647
41648C...gl :
41649 ALG = 1.014D0
41650 BEG = 1.738D0
41651 AKG = 1.724D0 + 0.157D0 * S
41652 BKG = 0.800D0 + 1.016D0 * S
41653 AG = 7.517D0 - 2.547D0 * S
41654 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
41655 CG = 4.039D0 + 1.491D0 * S
41656 DG = 3.404D0 + 0.830D0 * S
41657 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
41658 ESG = 3.256D0 - 0.436D0 * S
41659 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
41660
41661 RETURN
41662 END
41663
41664C*********************************************************************
41665
41666C...PYGRVD
41667C...Gives the GRV 94 D (DIS) parton distribution function set
41668C...in parametrized form.
41669C...Authors: M. Glueck, E. Reya and A. Vogt.
41670
41671 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41672
41673C...Double precision declaration.
41674 IMPLICIT DOUBLE PRECISION (A - Z)
41675
41676C...Common expressions.
41677 MU2 = 0.34D0
41678 LAM2 = 0.248D0 * 0.248D0
41679 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
41680 DS = SQRT (S)
41681 S2 = S * S
41682 S3 = S2 * S
41683
41684C...uv :
41685 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
41686 AKU = 0.563D0 - 0.025D0 * S
41687 BKU = 0.054D0 + 0.154D0 * S
41688 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
41689 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
41690 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
41691 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
41692 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
41693
41694C...dv :
41695 ND = 0.156D0 - 0.017D0 * S
41696 AKD = 0.299D0 - 0.022D0 * S
41697 BKD = 0.259D0 - 0.015D0 * S
41698 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
41699 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
41700 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
41701 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
41702 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
41703
41704C...del :
41705 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
41706 AKE = 0.419D0 - 0.013D0 * S
41707 BKE = 1.064D0 - 0.038D0 * S
41708 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
41709 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
41710 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
41711 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
41712 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
41713
41714C...udb :
41715 ALX = 1.215D0
41716 BEX = 0.466D0
41717 AKX = 0.326D0 + 0.150D0 * S
41718 BKX = 0.956D0 + 0.405D0 * S
41719 AGX = 0.272D0
41720 BGX = 3.794D0 - 2.359D0 * DS
41721 CX = 2.014D0
41722 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
41723 EX = 3.049D0 + 1.597D0 * S
41724 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
41725 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
41726 & DX, EX, ESX)
41727
41728C...sb :
41729 STS = 0D0
41730 ALS = 0.175D0
41731 BES = 0.344D0
41732 AKS = 1.415D0 - 0.641D0 * DS
41733 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
41734 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
41735 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
41736 EST = 4.546D0 + 0.372D0 * S2
41737 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
41738 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
41739
41740C...cb :
41741 STC = 0.820D0
41742 ALC = 0.98D0
41743 BEC = 0D0
41744 AKC = -0.625D0 - 0.523D0 * S
41745 AC = 0D0
41746 BC = 1.896D0 + 1.616D0 * S
41747 DCT = 4.12D0 + 0.683D0 * S
41748 ECT = 4.36D0 + 1.328D0 * S
41749 ESC = 0.677D0 + 0.679D0 * S
41750 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
41751
41752C...bb :
41753 STB = 1.297D0
41754 ALB = 0.99D0
41755 BEB = 0D0
41756 AKB = - 0.193D0 * S
41757 AB = 0D0
41758 BB = 0D0
41759 DBT = 3.447D0 + 0.927D0 * S
41760 EBT = 4.68D0 + 1.259D0 * S
41761 ESB = 1.892D0 + 2.199D0 * S
41762 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
41763
41764C...gl :
41765 ALG = 1.258D0
41766 BEG = 1.846D0
41767 AKG = 2.423D0
41768 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
41769 AG = 25.09D0 - 7.935D0 * S
41770 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
41771 CG = 590.3D0 - 173.8D0 * S
41772 DG = 5.196D0 + 1.857D0 * S
41773 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
41774 ESG = 3.232D0 - 0.542D0 * S
41775 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
41776
41777 RETURN
41778 END
41779
41780C*********************************************************************
41781
41782C...PYGRVV
41783C...Auxiliary for the GRV 94 parton distribution functions
41784C...for u and d valence and d-u sea.
41785C...Authors: M. Glueck, E. Reya and A. Vogt.
41786
41787 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
41788
41789C...Double precision declaration.
41790 IMPLICIT DOUBLE PRECISION (A - Z)
41791
41792C...Evaluation.
41793 DX = SQRT (X)
41794 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
41795 & (1D0- X)**D
41796
41797 RETURN
41798 END
41799
41800C*********************************************************************
41801
41802C...PYGRVW
41803C...Auxiliary for the GRV 94 parton distribution functions
41804C...for d+u sea and gluon.
41805C...Authors: M. Glueck, E. Reya and A. Vogt.
41806
41807 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
41808
41809C...Double precision declaration.
41810 IMPLICIT DOUBLE PRECISION (A - Z)
41811
41812C...Evaluation.
41813 LX = LOG (1D0/X)
41814 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
41815 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
41816
41817 RETURN
41818 END
41819
41820C*********************************************************************
41821
41822C...PYGRVS
41823C...Auxiliary for the GRV 94 parton distribution functions
41824C...for s, c and b sea.
41825C...Authors: M. Glueck, E. Reya and A. Vogt.
41826
41827 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
41828
41829C...Double precision declaration.
41830 IMPLICIT DOUBLE PRECISION (A - Z)
41831
41832C...Evaluation.
41833 IF(S.LE.STH) THEN
41834 PYGRVS = 0D0
41835 ELSE
41836 DX = SQRT (X)
41837 LX = LOG (1D0/X)
41838 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
41839 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
41840 ENDIF
41841
41842 RETURN
41843 END
41844
41845C*********************************************************************
41846
41847C...PYCT5L
41848C...Auxiliary function for parametrization of CTEQ5L.
41849C...Author: J. Pumplin 9/99.
41850
41851C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
41852C...in Parametrized Form
41853C... September 15, 1999
41854C
41855C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
41856C... CTEQ5 PPARTON DISTRIBUTIONS"
41857C...hep-ph/9903282
41858
41859C...The CTEQ5M1 set given here is an updated version of the original
41860C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
41861C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
41862C...almost all applications.
41863C...The improvement is in the QCD evolution which is now more
41864C...accurate, and which agrees completely with the benchmark work
41865C...of the HERA 96/97 Workshop.
41866C...The differences between the parametrized and the corresponding
41867C...table versions (on which it is based) are of similar order as
41868C...between the two version.
41869
41870C...!! Because accurate parametrizations over a wide range of (x,Q)
41871C...is hard to obtain, only the most widely used sets CTEQ5M and
41872C...CTEQ5L are available in parametrized form for now.
41873
41874C...These parametrizations were obtained by Jon Pumplin.
41875
41876C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
41877C -------------------------------------------------------------------
41878C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
41879C 3 CTEQ5L Leading Order 0.127 192 146
41880C -------------------------------------------------------------------
41881C...Note the Qcd-lambda values given for CTEQ5L is for the leading
41882C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
41883C...calibration.
41884
41885C...The two Iset value are adopted to agree with the standard table
41886C...versions.
41887
41888C...Range of validity:
41889C...The range of (x, Q) covered by this parametrization of the QCD
41890C...evolved parton distributions is 1E-6 < x < 1 ;
41891C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
41892C...data only in a subset of that region; and the assumed DGLAP
41893C...evolution is unlikely to be valid for all of it either.
41894
41895C...The range of (x, Q) used in the CTEQ5 round of global analysis is
41896C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
41897C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
41898C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
41899
41900 FUNCTION PYCT5L(IFL,X,Q)
41901
41902C...Double precision declaration.
41903 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41904 IMPLICIT INTEGER(I-N)
41905
41906 PARAMETER (NEX=8, NLF=2)
41907 DIMENSION AM(0:NEX,0:NLF,-5:2)
41908 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41909 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41910 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41911 DIMENSION AF(0:NEX)
41912
41913 DATA MEXVEC( 2) / 8 /
41914 DATA MLFVEC( 2) / 2 /
41915 DATA UT1VEC( 2) / 0.4971265E+01 /
41916 DATA UT2VEC( 2) / -0.1105128E+01 /
41917 DATA ALFVEC( 2) / 0.2987216E+00 /
41918 DATA QMAVEC( 2) / 0.0000000E+00 /
41919 DATA (AM( 0,K, 2),K=0, 2)
41920 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
41921 DATA (AM( 1,K, 2),K=0, 2)
41922 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
41923 DATA (AM( 2,K, 2),K=0, 2)
41924 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
41925 DATA (AM( 3,K, 2),K=0, 2)
41926 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
41927 DATA (AM( 4,K, 2),K=0, 2)
41928 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
41929 DATA (AM( 5,K, 2),K=0, 2)
41930 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
41931 DATA (AM( 6,K, 2),K=0, 2)
41932 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
41933 DATA (AM( 7,K, 2),K=0, 2)
41934 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
41935 DATA (AM( 8,K, 2),K=0, 2)
41936 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
41937
41938 DATA MEXVEC( 1) / 8 /
41939 DATA MLFVEC( 1) / 2 /
41940 DATA UT1VEC( 1) / 0.2612618E+01 /
41941 DATA UT2VEC( 1) / -0.1258304E+06 /
41942 DATA ALFVEC( 1) / 0.3407552E+00 /
41943 DATA QMAVEC( 1) / 0.0000000E+00 /
41944 DATA (AM( 0,K, 1),K=0, 2)
41945 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
41946 DATA (AM( 1,K, 1),K=0, 2)
41947 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
41948 DATA (AM( 2,K, 1),K=0, 2)
41949 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
41950 DATA (AM( 3,K, 1),K=0, 2)
41951 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
41952 DATA (AM( 4,K, 1),K=0, 2)
41953 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
41954 DATA (AM( 5,K, 1),K=0, 2)
41955 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
41956 DATA (AM( 6,K, 1),K=0, 2)
41957 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
41958 DATA (AM( 7,K, 1),K=0, 2)
41959 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
41960 DATA (AM( 8,K, 1),K=0, 2)
41961 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
41962
41963 DATA MEXVEC( 0) / 8 /
41964 DATA MLFVEC( 0) / 2 /
41965 DATA UT1VEC( 0) / -0.4656819E+00 /
41966 DATA UT2VEC( 0) / -0.2742390E+03 /
41967 DATA ALFVEC( 0) / 0.4491863E+00 /
41968 DATA QMAVEC( 0) / 0.0000000E+00 /
41969 DATA (AM( 0,K, 0),K=0, 2)
41970 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
41971 DATA (AM( 1,K, 0),K=0, 2)
41972 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
41973 DATA (AM( 2,K, 0),K=0, 2)
41974 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
41975 DATA (AM( 3,K, 0),K=0, 2)
41976 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
41977 DATA (AM( 4,K, 0),K=0, 2)
41978 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
41979 DATA (AM( 5,K, 0),K=0, 2)
41980 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
41981 DATA (AM( 6,K, 0),K=0, 2)
41982 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
41983 DATA (AM( 7,K, 0),K=0, 2)
41984 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
41985 DATA (AM( 8,K, 0),K=0, 2)
41986 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
41987
41988 DATA MEXVEC(-1) / 8 /
41989 DATA MLFVEC(-1) / 2 /
41990 DATA UT1VEC(-1) / 0.3862583E+01 /
41991 DATA UT2VEC(-1) / -0.1265969E+01 /
41992 DATA ALFVEC(-1) / 0.2457668E+00 /
41993 DATA QMAVEC(-1) / 0.0000000E+00 /
41994 DATA (AM( 0,K,-1),K=0, 2)
41995 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
41996 DATA (AM( 1,K,-1),K=0, 2)
41997 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
41998 DATA (AM( 2,K,-1),K=0, 2)
41999 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
42000 DATA (AM( 3,K,-1),K=0, 2)
42001 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
42002 DATA (AM( 4,K,-1),K=0, 2)
42003 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
42004 DATA (AM( 5,K,-1),K=0, 2)
42005 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
42006 DATA (AM( 6,K,-1),K=0, 2)
42007 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
42008 DATA (AM( 7,K,-1),K=0, 2)
42009 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
42010 DATA (AM( 8,K,-1),K=0, 2)
42011 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
42012
42013 DATA MEXVEC(-2) / 7 /
42014 DATA MLFVEC(-2) / 2 /
42015 DATA UT1VEC(-2) / 0.1895615E+00 /
42016 DATA UT2VEC(-2) / -0.3069097E+01 /
42017 DATA ALFVEC(-2) / 0.5293999E+00 /
42018 DATA QMAVEC(-2) / 0.0000000E+00 /
42019 DATA (AM( 0,K,-2),K=0, 2)
42020 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
42021 DATA (AM( 1,K,-2),K=0, 2)
42022 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
42023 DATA (AM( 2,K,-2),K=0, 2)
42024 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
42025 DATA (AM( 3,K,-2),K=0, 2)
42026 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
42027 DATA (AM( 4,K,-2),K=0, 2)
42028 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
42029 DATA (AM( 5,K,-2),K=0, 2)
42030 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
42031 DATA (AM( 6,K,-2),K=0, 2)
42032 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
42033 DATA (AM( 7,K,-2),K=0, 2)
42034 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
42035
42036 DATA MEXVEC(-3) / 7 /
42037 DATA MLFVEC(-3) / 2 /
42038 DATA UT1VEC(-3) / 0.3753257E+01 /
42039 DATA UT2VEC(-3) / -0.1113085E+01 /
42040 DATA ALFVEC(-3) / 0.3713141E+00 /
42041 DATA QMAVEC(-3) / 0.0000000E+00 /
42042 DATA (AM( 0,K,-3),K=0, 2)
42043 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
42044 DATA (AM( 1,K,-3),K=0, 2)
42045 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
42046 DATA (AM( 2,K,-3),K=0, 2)
42047 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
42048 DATA (AM( 3,K,-3),K=0, 2)
42049 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
42050 DATA (AM( 4,K,-3),K=0, 2)
42051 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
42052 DATA (AM( 5,K,-3),K=0, 2)
42053 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
42054 DATA (AM( 6,K,-3),K=0, 2)
42055 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
42056 DATA (AM( 7,K,-3),K=0, 2)
42057 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
42058
42059 DATA MEXVEC(-4) / 7 /
42060 DATA MLFVEC(-4) / 2 /
42061 DATA UT1VEC(-4) / 0.4400772E+01 /
42062 DATA UT2VEC(-4) / -0.1356116E+01 /
42063 DATA ALFVEC(-4) / 0.3712017E-01 /
42064 DATA QMAVEC(-4) / 0.1300000E+01 /
42065 DATA (AM( 0,K,-4),K=0, 2)
42066 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
42067 DATA (AM( 1,K,-4),K=0, 2)
42068 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
42069 DATA (AM( 2,K,-4),K=0, 2)
42070 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
42071 DATA (AM( 3,K,-4),K=0, 2)
42072 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
42073 DATA (AM( 4,K,-4),K=0, 2)
42074 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
42075 DATA (AM( 5,K,-4),K=0, 2)
42076 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
42077 DATA (AM( 6,K,-4),K=0, 2)
42078 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
42079 DATA (AM( 7,K,-4),K=0, 2)
42080 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
42081
42082 DATA MEXVEC(-5) / 6 /
42083 DATA MLFVEC(-5) / 2 /
42084 DATA UT1VEC(-5) / 0.5562568E+01 /
42085 DATA UT2VEC(-5) / -0.1801317E+01 /
42086 DATA ALFVEC(-5) / 0.4952010E-02 /
42087 DATA QMAVEC(-5) / 0.4500000E+01 /
42088 DATA (AM( 0,K,-5),K=0, 2)
42089 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
42090 DATA (AM( 1,K,-5),K=0, 2)
42091 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
42092 DATA (AM( 2,K,-5),K=0, 2)
42093 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
42094 DATA (AM( 3,K,-5),K=0, 2)
42095 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
42096 DATA (AM( 4,K,-5),K=0, 2)
42097 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
42098 DATA (AM( 5,K,-5),K=0, 2)
42099 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
42100 DATA (AM( 6,K,-5),K=0, 2)
42101 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
42102
42103 IF(Q .LE. QMAVEC(IFL)) THEN
42104 PYCT5L = 0.D0
42105 RETURN
42106 ENDIF
42107
42108 IF(X .GE. 1.D0) THEN
42109 PYCT5L = 0.D0
42110 RETURN
42111 ENDIF
42112
42113 TMP = LOG(Q/ALFVEC(IFL))
42114 IF(TMP .LE. 0.D0) THEN
42115 PYCT5L = 0.D0
42116 RETURN
42117 ENDIF
42118
42119 SB = LOG(TMP)
42120 SB1 = SB - 1.2D0
42121 SB2 = SB1*SB1
42122
42123 DO 110 I = 0, NEX
42124 AF(I) = 0.D0
42125 SBX = 1.D0
42126 DO 100 K = 0, MLFVEC(IFL)
42127 AF(I) = AF(I) + SBX*AM(I,K,IFL)
42128 SBX = SB1*SBX
42129 100 CONTINUE
42130 110 CONTINUE
42131
42132 Y = -LOG(X)
42133 U = LOG(X/0.00001D0)
42134
42135 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
42136 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
42137 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
42138 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
42139 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
42140
42141 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
42142
42143C...Include threshold factor.
42144 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
42145
42146 RETURN
42147 END
42148
42149C*********************************************************************
42150
42151C...PYCT5M
42152C...Auxiliary function for parametrization of CTEQ5M1.
42153C...Author: J. Pumplin 9/99.
42154
42155 FUNCTION PYCT5M(IFL,X,Q)
42156
42157C...Double precision declaration.
42158 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42159 IMPLICIT INTEGER(I-N)
42160
42161 PARAMETER (NEX=8, NLF=2)
42162 DIMENSION AM(0:NEX,0:NLF,-5:2)
42163 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
42164 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
42165 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
42166 DIMENSION AF(0:NEX)
42167
42168 DATA MEXVEC( 2) / 8 /
42169 DATA MLFVEC( 2) / 2 /
42170 DATA UT1VEC( 2) / 0.5141718E+01 /
42171 DATA UT2VEC( 2) / -0.1346944E+01 /
42172 DATA ALFVEC( 2) / 0.5260555E+00 /
42173 DATA QMAVEC( 2) / 0.0000000E+00 /
42174 DATA (AM( 0,K, 2),K=0, 2)
42175 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
42176 DATA (AM( 1,K, 2),K=0, 2)
42177 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
42178 DATA (AM( 2,K, 2),K=0, 2)
42179 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
42180 DATA (AM( 3,K, 2),K=0, 2)
42181 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
42182 DATA (AM( 4,K, 2),K=0, 2)
42183 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
42184 DATA (AM( 5,K, 2),K=0, 2)
42185 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
42186 DATA (AM( 6,K, 2),K=0, 2)
42187 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
42188 DATA (AM( 7,K, 2),K=0, 2)
42189 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
42190 DATA (AM( 8,K, 2),K=0, 2)
42191 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
42192
42193 DATA MEXVEC( 1) / 8 /
42194 DATA MLFVEC( 1) / 2 /
42195 DATA UT1VEC( 1) / 0.4138426E+01 /
42196 DATA UT2VEC( 1) / -0.3221374E+01 /
42197 DATA ALFVEC( 1) / 0.4960962E+00 /
42198 DATA QMAVEC( 1) / 0.0000000E+00 /
42199 DATA (AM( 0,K, 1),K=0, 2)
42200 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
42201 DATA (AM( 1,K, 1),K=0, 2)
42202 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
42203 DATA (AM( 2,K, 1),K=0, 2)
42204 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
42205 DATA (AM( 3,K, 1),K=0, 2)
42206 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
42207 DATA (AM( 4,K, 1),K=0, 2)
42208 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
42209 DATA (AM( 5,K, 1),K=0, 2)
42210 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
42211 DATA (AM( 6,K, 1),K=0, 2)
42212 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
42213 DATA (AM( 7,K, 1),K=0, 2)
42214 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
42215 DATA (AM( 8,K, 1),K=0, 2)
42216 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
42217
42218 DATA MEXVEC( 0) / 8 /
42219 DATA MLFVEC( 0) / 2 /
42220 DATA UT1VEC( 0) / -0.1026789E+01 /
42221 DATA UT2VEC( 0) / -0.9051707E+01 /
42222 DATA ALFVEC( 0) / 0.9462977E+00 /
42223 DATA QMAVEC( 0) / 0.0000000E+00 /
42224 DATA (AM( 0,K, 0),K=0, 2)
42225 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
42226 DATA (AM( 1,K, 0),K=0, 2)
42227 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
42228 DATA (AM( 2,K, 0),K=0, 2)
42229 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
42230 DATA (AM( 3,K, 0),K=0, 2)
42231 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
42232 DATA (AM( 4,K, 0),K=0, 2)
42233 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
42234 DATA (AM( 5,K, 0),K=0, 2)
42235 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
42236 DATA (AM( 6,K, 0),K=0, 2)
42237 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
42238 DATA (AM( 7,K, 0),K=0, 2)
42239 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
42240 DATA (AM( 8,K, 0),K=0, 2)
42241 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
42242
42243 DATA MEXVEC(-1) / 8 /
42244 DATA MLFVEC(-1) / 2 /
42245 DATA UT1VEC(-1) / 0.5243571E+01 /
42246 DATA UT2VEC(-1) / -0.2870513E+01 /
42247 DATA ALFVEC(-1) / 0.6701448E+00 /
42248 DATA QMAVEC(-1) / 0.0000000E+00 /
42249 DATA (AM( 0,K,-1),K=0, 2)
42250 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
42251 DATA (AM( 1,K,-1),K=0, 2)
42252 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
42253 DATA (AM( 2,K,-1),K=0, 2)
42254 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
42255 DATA (AM( 3,K,-1),K=0, 2)
42256 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
42257 DATA (AM( 4,K,-1),K=0, 2)
42258 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
42259 DATA (AM( 5,K,-1),K=0, 2)
42260 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
42261 DATA (AM( 6,K,-1),K=0, 2)
42262 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
42263 DATA (AM( 7,K,-1),K=0, 2)
42264 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
42265 DATA (AM( 8,K,-1),K=0, 2)
42266 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
42267
42268 DATA MEXVEC(-2) / 7 /
42269 DATA MLFVEC(-2) / 2 /
42270 DATA UT1VEC(-2) / 0.4782210E+01 /
42271 DATA UT2VEC(-2) / -0.1976856E+02 /
42272 DATA ALFVEC(-2) / 0.7558374E+00 /
42273 DATA QMAVEC(-2) / 0.0000000E+00 /
42274 DATA (AM( 0,K,-2),K=0, 2)
42275 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
42276 DATA (AM( 1,K,-2),K=0, 2)
42277 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
42278 DATA (AM( 2,K,-2),K=0, 2)
42279 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
42280 DATA (AM( 3,K,-2),K=0, 2)
42281 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
42282 DATA (AM( 4,K,-2),K=0, 2)
42283 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
42284 DATA (AM( 5,K,-2),K=0, 2)
42285 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
42286 DATA (AM( 6,K,-2),K=0, 2)
42287 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
42288 DATA (AM( 7,K,-2),K=0, 2)
42289 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
42290
42291 DATA MEXVEC(-3) / 7 /
42292 DATA MLFVEC(-3) / 2 /
42293 DATA UT1VEC(-3) / 0.4518239E+01 /
42294 DATA UT2VEC(-3) / -0.2690590E+01 /
42295 DATA ALFVEC(-3) / 0.6124079E+00 /
42296 DATA QMAVEC(-3) / 0.0000000E+00 /
42297 DATA (AM( 0,K,-3),K=0, 2)
42298 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
42299 DATA (AM( 1,K,-3),K=0, 2)
42300 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
42301 DATA (AM( 2,K,-3),K=0, 2)
42302 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
42303 DATA (AM( 3,K,-3),K=0, 2)
42304 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
42305 DATA (AM( 4,K,-3),K=0, 2)
42306 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
42307 DATA (AM( 5,K,-3),K=0, 2)
42308 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
42309 DATA (AM( 6,K,-3),K=0, 2)
42310 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
42311 DATA (AM( 7,K,-3),K=0, 2)
42312 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
42313
42314 DATA MEXVEC(-4) / 7 /
42315 DATA MLFVEC(-4) / 2 /
42316 DATA UT1VEC(-4) / 0.2783230E+01 /
42317 DATA UT2VEC(-4) / -0.1746328E+01 /
42318 DATA ALFVEC(-4) / 0.1115653E+01 /
42319 DATA QMAVEC(-4) / 0.1300000E+01 /
42320 DATA (AM( 0,K,-4),K=0, 2)
42321 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
42322 DATA (AM( 1,K,-4),K=0, 2)
42323 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
42324 DATA (AM( 2,K,-4),K=0, 2)
42325 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
42326 DATA (AM( 3,K,-4),K=0, 2)
42327 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
42328 DATA (AM( 4,K,-4),K=0, 2)
42329 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
42330 DATA (AM( 5,K,-4),K=0, 2)
42331 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
42332 DATA (AM( 6,K,-4),K=0, 2)
42333 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
42334 DATA (AM( 7,K,-4),K=0, 2)
42335 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
42336
42337 DATA MEXVEC(-5) / 6 /
42338 DATA MLFVEC(-5) / 2 /
42339 DATA UT1VEC(-5) / 0.1619654E+02 /
42340 DATA UT2VEC(-5) / -0.3367346E+01 /
42341 DATA ALFVEC(-5) / 0.5109891E-02 /
42342 DATA QMAVEC(-5) / 0.4500000E+01 /
42343 DATA (AM( 0,K,-5),K=0, 2)
42344 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
42345 DATA (AM( 1,K,-5),K=0, 2)
42346 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
42347 DATA (AM( 2,K,-5),K=0, 2)
42348 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
42349 DATA (AM( 3,K,-5),K=0, 2)
42350 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
42351 DATA (AM( 4,K,-5),K=0, 2)
42352 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
42353 DATA (AM( 5,K,-5),K=0, 2)
42354 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
42355 DATA (AM( 6,K,-5),K=0, 2)
42356 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
42357
42358 IF(Q .LE. QMAVEC(IFL)) THEN
42359 PYCT5M = 0.D0
42360 RETURN
42361 ENDIF
42362
42363 IF(X .GE. 1.D0) THEN
42364 PYCT5M = 0.D0
42365 RETURN
42366 ENDIF
42367
42368 TMP = LOG(Q/ALFVEC(IFL))
42369 IF(TMP .LE. 0.D0) THEN
42370 PYCT5M = 0.D0
42371 RETURN
42372 ENDIF
42373
42374 SB = LOG(TMP)
42375 SB1 = SB - 1.2D0
42376 SB2 = SB1*SB1
42377
42378 DO 110 I = 0, NEX
42379 AF(I) = 0.D0
42380 SBX = 1.D0
42381 DO 100 K = 0, MLFVEC(IFL)
42382 AF(I) = AF(I) + SBX*AM(I,K,IFL)
42383 SBX = SB1*SBX
42384 100 CONTINUE
42385 110 CONTINUE
42386
42387 Y = -LOG(X)
42388 U = LOG(X/0.00001D0)
42389
42390 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
42391 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
42392 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
42393 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
42394 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
42395
42396 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
42397
42398C...Include threshold factor.
42399 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
42400
42401 RETURN
42402 END
42403
42404C*********************************************************************
42405
42406C...PYPDPO
42407C...Auxiliary to PYPDPR. Gives proton parton distributions according to
42408C...a few older parametrizations, now obsolete but convenient for
42409C...backwards checks.
42410
42411 SUBROUTINE PYPDPO(X,Q2,XPPR)
42412
42413C...Double precision and integer declarations.
42414 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42415 IMPLICIT INTEGER(I-N)
42416 INTEGER PYK,PYCHGE,PYCOMP
42417C...Commonblocks.
42418 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42419 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42420 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42421 COMMON/PYINT1/MINT(400),VINT(400)
42422 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
42423 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
42424 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
42425
42426
42427C...The following data lines are coefficients needed in the
42428C...Eichten, Hinchliffe, Lane, Quigg proton structure function
42429C...parametrizations, see below.
42430C...Powers of 1-x in different cases.
42431 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
42432C...Expansion coefficients for up valence quark distribution.
42433 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
42434 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
42435 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
42436 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
42437 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
42438 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
42439 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
42440 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
42441 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
42442 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
42443 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
42444 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
42445 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
42446 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
42447 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
42448 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
42449 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
42450 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
42451 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
42452 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
42453 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
42454 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
42455 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
42456 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
42457 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
42458 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
42459C...Expansion coefficients for down valence quark distribution.
42460 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
42461 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
42462 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
42463 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
42464 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
42465 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
42466 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
42467 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
42468 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
42469 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
42470 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
42471 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
42472 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
42473 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
42474 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
42475 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
42476 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
42477 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
42478 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
42479 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
42480 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
42481 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
42482 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
42483 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
42484 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
42485 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
42486C...Expansion coefficients for up and down sea quark distributions.
42487 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
42488 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
42489 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
42490 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
42491 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
42492 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
42493 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
42494 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
42495 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
42496 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
42497 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
42498 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
42499 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
42500 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
42501 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
42502 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
42503 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
42504 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
42505 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
42506 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
42507 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
42508 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
42509 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
42510 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
42511 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
42512 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
42513C...Expansion coefficients for gluon distribution.
42514 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
42515 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
42516 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
42517 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
42518 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
42519 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
42520 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
42521 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
42522 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
42523 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
42524 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
42525 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
42526 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
42527 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
42528 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
42529 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
42530 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
42531 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
42532 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
42533 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
42534 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
42535 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
42536 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
42537 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
42538 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
42539 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
42540C...Expansion coefficients for strange sea quark distribution.
42541 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
42542 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
42543 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
42544 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
42545 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
42546 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
42547 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
42548 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
42549 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
42550 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
42551 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
42552 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
42553 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
42554 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
42555 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
42556 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
42557 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
42558 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
42559 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
42560 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
42561 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
42562 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
42563 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
42564 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
42565 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
42566 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
42567C...Expansion coefficients for charm sea quark distribution.
42568 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
42569 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
42570 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
42571 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
42572 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
42573 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
42574 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
42575 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
42576 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
42577 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
42578 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
42579 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
42580 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
42581 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
42582 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
42583 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
42584 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
42585 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
42586 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
42587 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
42588 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
42589 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
42590 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
42591 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
42592 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
42593 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
42594C...Expansion coefficients for bottom sea quark distribution.
42595 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
42596 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
42597 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
42598 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
42599 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
42600 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
42601 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
42602 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
42603 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
42604 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
42605 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
42606 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
42607 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
42608 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
42609 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
42610 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
42611 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
42612 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
42613 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
42614 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
42615 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
42616 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
42617 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
42618 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
42619 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
42620 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
42621C...Expansion coefficients for top sea quark distribution.
42622 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
42623 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
42624 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
42625 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
42626 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
42627 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
42628 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
42629 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
42630 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
42631 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
42632 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
42633 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
42634 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
42635 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
42636 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
42637 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
42638 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
42639 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
42640 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
42641 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
42642 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
42643 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
42644 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
42645 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
42646 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
42647 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
42648
42649C...The following data lines are coefficients needed in the
42650C...Duke, Owens proton structure function parametrizations, see below.
42651C...Expansion coefficients for (up+down) valence quark distribution.
42652 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
42653 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42654 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42655 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
42656 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
42657 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42658 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42659 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
42660C...Expansion coefficients for down valence quark distribution.
42661 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
42662 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42663 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
42664 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
42665 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
42666 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42667 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
42668 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
42669C...Expansion coefficients for (up+down+strange) sea quark distribution.
42670 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
42671 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42672 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
42673 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
42674 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
42675 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42676 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
42677 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
42678C...Expansion coefficients for charm sea quark distribution.
42679 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
42680 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42681 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
42682 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
42683 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
42684 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42685 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
42686 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
42687C...Expansion coefficients for gluon distribution.
42688 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
42689 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
42690 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
42691 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
42692 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
42693 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
42694 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
42695 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
42696
42697C...Euler's beta function, requires ordinary Gamma function
42698 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
42699
42700C...Leading order proton parton distributions from Glueck, Reya and
42701C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
42702C...10^-5 < x < 1.
42703 IF(MSTP(51).EQ.11) THEN
42704
42705C...Determine s expansion variable and some x expressions.
42706 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
42707 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
42708 SD2=SD**2
42709 XL=-LOG(X)
42710 XS=SQRT(X)
42711
42712C...Evaluate valence, gluon and sea distributions.
42713 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
42714 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
42715 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
42716 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
42717 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
42718 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
42719 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
42720 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
42721 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
42722 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
42723 & SQRT(4.066D0*SD**1.218D0*XL)))*
42724 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
42725 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
42726 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
42727 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
42728 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
42729 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
42730 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
42731 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
42732 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
42733 IF(SD.LE.0.888D0) THEN
42734 XFCHM=0D0
42735 ELSE
42736 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
42737 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
42738 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
42739 ENDIF
42740 IF(SD.LE.1.351D0) THEN
42741 XFBOT=0D0
42742 ELSE
42743 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
42744 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
42745 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
42746 ENDIF
42747
42748C...Put into output array.
42749 XPPR(0)=XFGLU
42750 XPPR(1)=XFVDD+XFSEA
42751 XPPR(2)=XFVUD-XFVDD+XFSEA
42752 XPPR(3)=XFSTR
42753 XPPR(4)=XFCHM
42754 XPPR(5)=XFBOT
42755 XPPR(-1)=XFSEA
42756 XPPR(-2)=XFSEA
42757 XPPR(-3)=XFSTR
42758 XPPR(-4)=XFCHM
42759 XPPR(-5)=XFBOT
42760
42761C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
42762C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
42763 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
42764
42765C...Determine set, Lambda and x and t expansion variables.
42766 NSET=MSTP(51)-11
42767 IF(NSET.EQ.1) ALAM=0.2D0
42768 IF(NSET.EQ.2) ALAM=0.29D0
42769 TMIN=LOG(5D0/ALAM**2)
42770 TMAX=LOG(1D8/ALAM**2)
42771 T=LOG(MAX(1D0,Q2/ALAM**2))
42772 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42773 NX=1
42774 IF(X.LE.0.1D0) NX=2
42775 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
42776 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
42777
42778C...Chebyshev polynomials for x and t expansion.
42779 TX(1)=1D0
42780 TX(2)=VX
42781 TX(3)=2D0*VX**2-1D0
42782 TX(4)=4D0*VX**3-3D0*VX
42783 TX(5)=8D0*VX**4-8D0*VX**2+1D0
42784 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
42785 TT(1)=1D0
42786 TT(2)=VT
42787 TT(3)=2D0*VT**2-1D0
42788 TT(4)=4D0*VT**3-3D0*VT
42789 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42790 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42791
42792C...Calculate structure functions.
42793 DO 120 KFL=1,6
42794 XQSUM=0D0
42795 DO 110 IT=1,6
42796 DO 100 IX=1,6
42797 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
42798 100 CONTINUE
42799 110 CONTINUE
42800 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
42801 120 CONTINUE
42802
42803C...Put into output array.
42804 XPPR(0)=XQ(4)
42805 XPPR(1)=XQ(2)+XQ(3)
42806 XPPR(2)=XQ(1)+XQ(3)
42807 XPPR(3)=XQ(5)
42808 XPPR(4)=XQ(6)
42809 XPPR(-1)=XQ(3)
42810 XPPR(-2)=XQ(3)
42811 XPPR(-3)=XQ(5)
42812 XPPR(-4)=XQ(6)
42813
42814C...Special expansion for bottom (threshold effects).
42815 IF(MSTP(58).GE.5) THEN
42816 IF(NSET.EQ.1) TMIN=8.1905D0
42817 IF(NSET.EQ.2) TMIN=7.4474D0
42818 IF(T.GT.TMIN) THEN
42819 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42820 TT(1)=1D0
42821 TT(2)=VT
42822 TT(3)=2D0*VT**2-1D0
42823 TT(4)=4D0*VT**3-3D0*VT
42824 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42825 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42826 XQSUM=0D0
42827 DO 140 IT=1,6
42828 DO 130 IX=1,6
42829 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
42830 130 CONTINUE
42831 140 CONTINUE
42832 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
42833 XPPR(-5)=XPPR(5)
42834 ENDIF
42835 ENDIF
42836
42837C...Special expansion for top (threshold effects).
42838 IF(MSTP(58).GE.6) THEN
42839 IF(NSET.EQ.1) TMIN=11.5528D0
42840 IF(NSET.EQ.2) TMIN=10.8097D0
42841 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
42842 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
42843 IF(T.GT.TMIN) THEN
42844 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42845 TT(1)=1D0
42846 TT(2)=VT
42847 TT(3)=2D0*VT**2-1D0
42848 TT(4)=4D0*VT**3-3D0*VT
42849 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42850 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42851 XQSUM=0D0
42852 DO 160 IT=1,6
42853 DO 150 IX=1,6
42854 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
42855 150 CONTINUE
42856 160 CONTINUE
42857 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
42858 XPPR(-6)=XPPR(6)
42859 ENDIF
42860 ENDIF
42861
42862C...Proton parton distributions from Duke, Owens.
42863C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
42864 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
42865
42866C...Determine set, Lambda and s expansion parameter.
42867 NSET=MSTP(51)-13
42868 IF(NSET.EQ.1) ALAM=0.2D0
42869 IF(NSET.EQ.2) ALAM=0.4D0
42870 Q2IN=MIN(1D6,MAX(4D0,Q2))
42871 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
42872
42873C...Calculate structure functions.
42874 DO 180 KFL=1,5
42875 DO 170 IS=1,6
42876 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
42877 & CDO(3,IS,KFL,NSET)*SD**2
42878 170 CONTINUE
42879 IF(KFL.LE.2) THEN
42880 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
42881 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
42882 ELSE
42883 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
42884 & TS(5)*X**2+TS(6)*X**3)
42885 ENDIF
42886 180 CONTINUE
42887
42888C...Put into output arrays.
42889 XPPR(0)=XQ(5)
42890 XPPR(1)=XQ(2)+XQ(3)/6D0
42891 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
42892 XPPR(3)=XQ(3)/6D0
42893 XPPR(4)=XQ(4)
42894 XPPR(-1)=XQ(3)/6D0
42895 XPPR(-2)=XQ(3)/6D0
42896 XPPR(-3)=XQ(3)/6D0
42897 XPPR(-4)=XQ(4)
42898
42899 ENDIF
42900
42901 RETURN
42902 END
42903
42904C*********************************************************************
42905
42906C...PYHFTH
42907C...Gives threshold attractive/repulsive factor for heavy flavour
42908C...production.
42909
42910 FUNCTION PYHFTH(SH,SQM,FRATT)
42911
42912C...Double precision and integer declarations.
42913 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42914 IMPLICIT INTEGER(I-N)
42915 INTEGER PYK,PYCHGE,PYCOMP
42916C...Commonblocks.
42917 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42918 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42919 COMMON/PYINT1/MINT(400),VINT(400)
42920 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
42921
42922C...Value for alpha_strong.
42923 IF(MSTP(35).LE.1) THEN
42924 ALSSG=PARP(35)
42925 ELSE
42926 MST115=MSTU(115)
42927 MSTU(115)=MSTP(36)
42928 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
42929 & PARP(36)**2)))
42930 ALSSG=PYALPS(Q2BN)
42931 MSTU(115)=MST115
42932 ENDIF
42933
42934C...Evaluate attractive and repulsive factors.
42935 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42936 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
42937 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42938 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
42939 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
42940 VINT(138)=PYHFTH
42941
42942 RETURN
42943 END
42944
42945C*********************************************************************
42946
42947C...PYSPLI
42948C...Splits a hadron remnant into two (partons or hadron + parton)
42949C...in case it is more complicated than just a quark or a diquark.
42950
42951 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
42952
42953C...Double precision and integer declarations.
42954 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42955 IMPLICIT INTEGER(I-N)
42956 INTEGER PYK,PYCHGE,PYCOMP
42957C...Commonblocks. PYDAT1 temporary
42958 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42959 COMMON/PYINT1/MINT(400),VINT(400)
42960 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42961 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
42962C...Local array.
42963 DIMENSION KFL(3)
42964
42965C...Preliminaries. Parton composition.
42966 KFA=IABS(KF)
42967 KFS=ISIGN(1,KF)
42968 KFL(1)=MOD(KFA/1000,10)
42969 KFL(2)=MOD(KFA/100,10)
42970 KFL(3)=MOD(KFA/10,10)
42971 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
42972 KFL(2)=INT(1.5D0+PYR(0))
42973 IF(MINT(105).EQ.333) KFL(2)=3
42974 IF(MINT(105).EQ.443) KFL(2)=4
42975 KFL(3)=KFL(2)
42976 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
42977 KFL(2)=2
42978 KFL(3)=2
42979 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
42980 KFL(2)=1
42981 KFL(3)=1
42982 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
42983 KFL(2)=MOD(KFA/10,10)
42984 KFL(3)=MOD(KFA/100,10)
42985 ENDIF
42986 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
42987 KFLR=KFLIN*KFS
42988 ELSE
42989 KFLR=KFLIN
42990 ENDIF
42991 KFLCH=0
42992
42993C...Subdivide lepton.
42994 IF(KFA.GE.11.AND.KFA.LE.18) THEN
42995 IF(KFLR.EQ.KFA) THEN
42996 KFLSP=KFS*22
42997 ELSEIF(KFLR.EQ.22) THEN
42998 KFLSP=KFA
42999 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
43000 KFLSP=KFA+1
43001 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
43002 KFLSP=KFA-1
43003 ELSEIF(KFLR.EQ.21) THEN
43004 KFLSP=KFA
43005 KFLCH=KFS*21
43006 ELSE
43007 KFLSP=KFA
43008 KFLCH=-KFLR
43009 ENDIF
43010
43011C...Subdivide photon.
43012 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
43013 IF(KFLR.NE.21) THEN
43014 KFLSP=-KFLR
43015 ELSE
43016 RAGR=0.75D0*PYR(0)
43017 KFLSP=1
43018 IF(RAGR.GT.0.125D0) KFLSP=2
43019 IF(RAGR.GT.0.625D0) KFLSP=3
43020 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
43021 KFLCH=-KFLSP
43022 ENDIF
43023
43024C...Subdivide Reggeon or Pomeron.
43025 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
43026 IF(KFLIN.EQ.21) THEN
43027 KFLSP=KFS*21
43028 ELSE
43029 KFLSP=-KFLIN
43030 ENDIF
43031
43032C...Subdivide meson.
43033 ELSEIF(KFL(1).EQ.0) THEN
43034 KFL(2)=KFL(2)*(-1)**KFL(2)
43035 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
43036 IF(KFLR.EQ.KFL(2)) THEN
43037 KFLSP=KFL(3)
43038 ELSEIF(KFLR.EQ.KFL(3)) THEN
43039 KFLSP=KFL(2)
43040 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
43041 KFLSP=KFL(2)
43042 KFLCH=KFL(3)
43043 ELSEIF(KFLR.EQ.21) THEN
43044 KFLSP=KFL(3)
43045 KFLCH=KFL(2)
43046 ELSEIF(KFLR*KFL(2).GT.0) THEN
43047 NTRY=0
43048 100 NTRY=NTRY+1
43049 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
43050 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43051 GOTO 100
43052 ELSEIF(KFLCH.EQ.0) THEN
43053 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43054 MINT(51)=1
43055 RETURN
43056 ENDIF
43057 KFLSP=KFL(3)
43058 ELSE
43059 NTRY=0
43060 110 NTRY=NTRY+1
43061 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
43062 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43063 GOTO 110
43064 ELSEIF(KFLCH.EQ.0) THEN
43065 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43066 MINT(51)=1
43067 RETURN
43068 ENDIF
43069 KFLSP=KFL(2)
43070 ENDIF
43071
43072C...Special case for extracting photon from baryon without splitting
43073C...the latter. (Currently only used by external programs.)
43074 ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
43075 KFLSP=KFA
43076 KFLCH=0
43077
43078C...Subdivide baryon.
43079 ELSE
43080 NAGR=0
43081 DO 120 J=1,3
43082 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
43083 120 CONTINUE
43084 IF(NAGR.GE.1) THEN
43085 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
43086 IAGR=0
43087 DO 130 J=1,3
43088 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
43089 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
43090 130 CONTINUE
43091 ELSE
43092 IAGR=1.00001D0+2.99998D0*PYR(0)
43093 ENDIF
43094 ID1=1
43095 IF(IAGR.EQ.1) ID1=2
43096 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
43097 ID2=6-IAGR-ID1
43098 KSP=3
43099 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
43100 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
43101 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
43102 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
43103 ELSEIF(MOD(KFA,10).EQ.2) THEN
43104 IF(IAGR.EQ.1) KSP=1
43105 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
43106 ENDIF
43107 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
43108 IF(KFLR.EQ.21) THEN
43109 KFLCH=KFL(IAGR)
43110 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
43111 NTRY=0
43112 140 NTRY=NTRY+1
43113 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
43114 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43115 GOTO 140
43116 ELSEIF(KFLCH.EQ.0) THEN
43117 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43118 MINT(51)=1
43119 RETURN
43120 ENDIF
43121 ELSEIF(NAGR.EQ.0) THEN
43122 NTRY=0
43123 150 NTRY=NTRY+1
43124 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
43125 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43126 GOTO 150
43127 ELSEIF(KFLCH.EQ.0) THEN
43128 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43129 MINT(51)=1
43130 RETURN
43131 ENDIF
43132 KFLSP=KFL(IAGR)
43133 ENDIF
43134 ENDIF
43135
43136C...Add on correct sign for result.
43137 KFLCH=KFLCH*KFS
43138 KFLSP=KFLSP*KFS
43139
43140 RETURN
43141 END
43142
43143C*********************************************************************
43144
43145C...PYGAMM
43146C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
43147C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
43148C...(Dover, 1965) 6.1.36.
43149
43150 FUNCTION PYGAMM(X)
43151
43152C...Double precision and integer declarations.
43153 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43154 IMPLICIT INTEGER(I-N)
43155 INTEGER PYK,PYCHGE,PYCOMP
43156C...Local array and data.
43157 DIMENSION B(8)
43158 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
43159 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
43160
43161 NX=INT(X)
43162 DX=X-NX
43163
43164 PYGAMM=1D0
43165 DXP=1D0
43166 DO 100 I=1,8
43167 DXP=DXP*DX
43168 PYGAMM=PYGAMM+B(I)*DXP
43169 100 CONTINUE
43170 IF(X.LT.1D0) THEN
43171 PYGAMM=PYGAMM/X
43172 ELSE
43173 DO 110 IX=1,NX-1
43174 PYGAMM=(X-IX)*PYGAMM
43175 110 CONTINUE
43176 ENDIF
43177
43178 RETURN
43179 END
43180
43181C***********************************************************************
43182
43183C...PYWAUX
43184C...Calculates real and imaginary parts of the auxiliary functions W1
43185C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
43186C...der Bij, Nucl. Phys. B297 (1988) 221.
43187
43188 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
43189
43190C...Double precision and integer declarations.
43191 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43192 IMPLICIT INTEGER(I-N)
43193 INTEGER PYK,PYCHGE,PYCOMP
43194C...Commonblocks.
43195 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43196 SAVE /PYDAT1/
43197
43198 ASINH(X)=LOG(X+SQRT(X**2+1D0))
43199 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
43200
43201 IF(EPS.LT.0D0) THEN
43202 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
43203 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
43204 WIM=0D0
43205 ELSEIF(EPS.LT.1D0) THEN
43206 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
43207 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
43208 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
43209 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
43210 ELSE
43211 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
43212 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
43213 WIM=0D0
43214 ENDIF
43215
43216 RETURN
43217 END
43218
43219C***********************************************************************
43220
43221C...PYI3AU
43222C...Calculates real and imaginary parts of the auxiliary function I3;
43223C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
43224C...Nucl. Phys. B297 (1988) 221.
43225
43226 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
43227
43228C...Double precision and integer declarations.
43229 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43230 IMPLICIT INTEGER(I-N)
43231 INTEGER PYK,PYCHGE,PYCOMP
43232C...Commonblocks.
43233 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43234 SAVE /PYDAT1/
43235
43236 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
43237 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
43238
43239 IF(EPS.LT.0D0) THEN
43240 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43241 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
43242 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
43243 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
43244 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
43245 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
43246 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
43247 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
43248 & EPS))
43249 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
43250 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
43251 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
43252 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
43253 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
43254 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
43255 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
43256 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
43257 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43258 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
43259 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
43260 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
43261 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
43262 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
43263 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
43264 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
43265 ELSE
43266 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
43267 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
43268 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
43269 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
43270 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
43271 ENDIF
43272 F3IM=0D0
43273 ELSEIF(EPS.LT.1D0) THEN
43274 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43275 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
43276 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
43277 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
43278 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
43279 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
43280 & (0.25D0*(RAT+1D0)*EPS))
43281 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
43282 & (0.25D0*(RAT+1D0)*EPS))
43283 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
43284 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
43285 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
43286 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
43287 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
43288 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
43289 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
43290 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
43291 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43292 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
43293 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
43294 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
43295 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
43296 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
43297 & (1D0+0.25D0*RAT*EPS-GA))
43298 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
43299 & (1D0+0.25D0*RAT*EPS-GA))
43300 ELSE
43301 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
43302 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
43303 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
43304 & LOG((GA+BE-1D0)/(BE-GA))
43305 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
43306 ENDIF
43307 ELSE
43308 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
43309 RCTHE=RSQ*(1D0-2D0*BE/EPS)
43310 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
43311 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
43312 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
43313 R=SQRT(RSQ)
43314 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
43315 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
43316 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
43317 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
43318 & (PHI-THE)*(PHI+THE-PARU(1))
43319 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
43320 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
43321 ENDIF
43322
43323 Y3RE=2D0/(2D0*BE-1D0)*F3RE
43324 Y3IM=2D0/(2D0*BE-1D0)*F3IM
43325
43326 RETURN
43327 END
43328
43329C***********************************************************************
43330
43331C...PYSPEN
43332C...Calculates real and imaginary part of Spence function; see
43333C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
43334
43335 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
43336
43337C...Double precision and integer declarations.
43338 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43339 IMPLICIT INTEGER(I-N)
43340 INTEGER PYK,PYCHGE,PYCOMP
43341C...Commonblocks.
43342 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43343 SAVE /PYDAT1/
43344C...Local array and data.
43345 DIMENSION B(0:14)
43346 DATA B/
43347 &1.000000D+00, -5.000000D-01, 1.666667D-01,
43348 &0.000000D+00, -3.333333D-02, 0.000000D+00,
43349 &2.380952D-02, 0.000000D+00, -3.333333D-02,
43350 &0.000000D+00, 7.575757D-02, 0.000000D+00,
43351 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
43352
43353 XRE=XREIN
43354 XIM=XIMIN
43355 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
43356 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
43357 IF(IREIM.EQ.2) PYSPEN=0D0
43358 RETURN
43359 ENDIF
43360
43361 XMOD=SQRT(XRE**2+XIM**2)
43362 IF(XMOD.LT.1D-6) THEN
43363 IF(IREIM.EQ.1) PYSPEN=0D0
43364 IF(IREIM.EQ.2) PYSPEN=0D0
43365 RETURN
43366 ENDIF
43367
43368 XARG=SIGN(ACOS(XRE/XMOD),XIM)
43369 SP0RE=0D0
43370 SP0IM=0D0
43371 SGN=1D0
43372 IF(XMOD.GT.1D0) THEN
43373 ALGXRE=LOG(XMOD)
43374 ALGXIM=XARG-SIGN(PARU(1),XARG)
43375 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
43376 SP0IM=-ALGXRE*ALGXIM
43377 SGN=-1D0
43378 XMOD=1D0/XMOD
43379 XARG=-XARG
43380 XRE=XMOD*COS(XARG)
43381 XIM=XMOD*SIN(XARG)
43382 ENDIF
43383 IF(XRE.GT.0.5D0) THEN
43384 ALGXRE=LOG(XMOD)
43385 ALGXIM=XARG
43386 XRE=1D0-XRE
43387 XIM=-XIM
43388 XMOD=SQRT(XRE**2+XIM**2)
43389 XARG=SIGN(ACOS(XRE/XMOD),XIM)
43390 ALGYRE=LOG(XMOD)
43391 ALGYIM=XARG
43392 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
43393 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
43394 SGN=-SGN
43395 ENDIF
43396
43397 XRE=1D0-XRE
43398 XIM=-XIM
43399 XMOD=SQRT(XRE**2+XIM**2)
43400 XARG=SIGN(ACOS(XRE/XMOD),XIM)
43401 ZRE=-LOG(XMOD)
43402 ZIM=-XARG
43403
43404 SPRE=0D0
43405 SPIM=0D0
43406 SAVERE=1D0
43407 SAVEIM=0D0
43408 DO 100 I=0,14
43409 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
43410 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
43411 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
43412 SAVERE=TERMRE
43413 SAVEIM=TERMIM
43414 SPRE=SPRE+B(I)*TERMRE
43415 SPIM=SPIM+B(I)*TERMIM
43416 100 CONTINUE
43417
43418 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
43419 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
43420
43421 RETURN
43422 END
43423
43424C***********************************************************************
43425
43426C...PYQQBH
43427C...Calculates the matrix element for the processes
43428C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
43429C...REDUCE output and part of the rest courtesy Z. Kunszt, see
43430C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
43431
43432 SUBROUTINE PYQQBH(WTQQBH)
43433
43434C...Double precision and integer declarations.
43435 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43436 IMPLICIT INTEGER(I-N)
43437 INTEGER PYK,PYCHGE,PYCOMP
43438C...Commonblocks.
43439 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43440 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43441 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43442 COMMON/PYINT1/MINT(400),VINT(400)
43443 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43444 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
43445C...Local arrays and function.
43446 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
43447 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
43448 &PP(I,3)*PP(J,3)
43449
43450C...Mass parameters.
43451 WTQQBH=0D0
43452 ISUB=MINT(1)
43453 SHPR=SQRT(VINT(26))*VINT(1)
43454 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
43455 PH=SQRT(VINT(21))*VINT(1)
43456 SPQ=PQ**2
43457 SPH=PH**2
43458
43459C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
43460 DO 100 I=1,2
43461 PT=SQRT(MAX(0D0,VINT(197+5*I)))
43462 PP(I,1)=PT*COS(VINT(198+5*I))
43463 PP(I,2)=PT*SIN(VINT(198+5*I))
43464 100 CONTINUE
43465 PP(3,1)=-PP(1,1)-PP(2,1)
43466 PP(3,2)=-PP(1,2)-PP(2,2)
43467 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
43468 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
43469 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
43470 PMT3=SQRT(PMS3)
43471 PP(3,3)=PMT3*SINH(VINT(211))
43472 PP(3,4)=PMT3*COSH(VINT(211))
43473 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
43474 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
43475 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
43476 PP(2,3)=-PP(1,3)-PP(3,3)
43477 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
43478 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
43479
43480C...Set up incoming kinematics and derived momentum combinations.
43481 DO 110 I=4,5
43482 PP(I,1)=0D0
43483 PP(I,2)=0D0
43484 PP(I,3)=-0.5D0*SHPR*(-1)**I
43485 PP(I,4)=-0.5D0*SHPR
43486 110 CONTINUE
43487 DO 120 J=1,4
43488 PP(6,J)=PP(1,J)+PP(2,J)
43489 PP(7,J)=PP(1,J)+PP(3,J)
43490 PP(8,J)=PP(1,J)+PP(4,J)
43491 PP(9,J)=PP(1,J)+PP(5,J)
43492 PP(10,J)=-PP(2,J)-PP(3,J)
43493 PP(11,J)=-PP(2,J)-PP(4,J)
43494 PP(12,J)=-PP(2,J)-PP(5,J)
43495 PP(13,J)=-PP(4,J)-PP(5,J)
43496 120 CONTINUE
43497
43498C...Derived kinematics invariants.
43499 X1=DOT(1,2)
43500 X2=DOT(1,3)
43501 X3=DOT(1,4)
43502 X4=DOT(1,5)
43503 X5=DOT(2,3)
43504 X6=DOT(2,4)
43505 X7=DOT(2,5)
43506 X8=DOT(3,4)
43507 X9=DOT(3,5)
43508 X10=DOT(4,5)
43509
43510C...Propagators.
43511 SS1=DOT(7,7)-SPQ
43512 SS2=DOT(8,8)-SPQ
43513 SS3=DOT(9,9)-SPQ
43514 SS4=DOT(10,10)-SPQ
43515 SS5=DOT(11,11)-SPQ
43516 SS6=DOT(12,12)-SPQ
43517 SS7=DOT(13,13)
43518 DX(1)=SS1*SS6
43519 DX(2)=SS2*SS6
43520 DX(3)=SS2*SS4
43521 DX(4)=SS1*SS5
43522 DX(5)=SS3*SS5
43523 DX(6)=SS3*SS4
43524 DX(7)=SS7*SS1
43525 DX(8)=SS7*SS4
43526
43527C...Define colour coefficients for g + g -> Q + Qbar + H.
43528 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
43529 DO 140 I=1,3
43530 DO 130 J=1,3
43531 CLR(I,J)=16D0/3D0
43532 CLR(I+3,J+3)=16D0/3D0
43533 CLR(I,J+3)=-2D0/3D0
43534 CLR(I+3,J)=-2D0/3D0
43535 130 CONTINUE
43536 140 CONTINUE
43537 DO 160 L=1,2
43538 DO 150 I=1,3
43539 CLR(I,6+L)=-6D0
43540 CLR(I+3,6+L)=6D0
43541 CLR(6+L,I)=-6D0
43542 CLR(6+L,I+3)=6D0
43543 150 CONTINUE
43544 160 CONTINUE
43545 DO 180 K1=1,2
43546 DO 170 K2=1,2
43547 CLR(6+K1,6+K2)=12D0
43548 170 CONTINUE
43549 180 CONTINUE
43550
43551C...Evaluate matrix elements for g + g -> Q + Qbar + H.
43552 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
43553 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
43554 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
43555 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
43556 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
43557 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
43558 & X10)
43559 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
43560 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
43561 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
43562 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
43563 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
43564 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
43565 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
43566 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
43567 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
43568 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
43569 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
43570 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
43571 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
43572 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
43573 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
43574 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
43575 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
43576 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
43577 & X4*X6*X5)
43578 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
43579 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
43580 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
43581 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
43582 & +X4*X9*X5+X4*X5**2)
43583 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
43584 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
43585 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
43586 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
43587 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
43588 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
43589 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
43590 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
43591 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
43592 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
43593 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
43594 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
43595 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
43596 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
43597 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
43598 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
43599 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
43600 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
43601 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
43602 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
43603 & X6)
43604 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
43605 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
43606 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
43607 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
43608 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
43609 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
43610 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
43611 & X5+X4*X6*X5)
43612 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
43613 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
43614 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
43615 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
43616 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
43617 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
43618 & X6**2)
43619 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
43620 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
43621 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
43622 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
43623 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
43624 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
43625 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
43626 & X4*X6*X5)
43627 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
43628 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
43629 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
43630 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
43631 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
43632 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
43633 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
43634 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
43635 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
43636 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
43637 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
43638 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
43639 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
43640 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
43641 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
43642 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
43643 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
43644 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
43645 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
43646 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
43647 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
43648 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
43649 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
43650 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
43651 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
43652 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
43653 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
43654 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
43655 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
43656 & +X3*X8*X5+X3*X5**2)
43657 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
43658 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
43659 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
43660 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
43661 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
43662 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
43663 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
43664 & X5+X4*X6*X5)
43665 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
43666 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
43667 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
43668 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
43669 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
43670 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
43671 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
43672 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
43673 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
43674 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
43675 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
43676 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
43677 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
43678 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
43679 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
43680 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
43681 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
43682 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
43683 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
43684 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
43685 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
43686 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
43687 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
43688 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
43689 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
43690 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
43691 & X10)
43692 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
43693 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
43694 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
43695 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
43696 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
43697 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
43698 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
43699 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
43700 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
43701 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
43702 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
43703 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
43704 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
43705 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
43706 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
43707 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
43708 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
43709 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
43710 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
43711 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
43712 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
43713 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
43714 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
43715 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
43716 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
43717 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
43718 & X7)
43719 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
43720 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
43721 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
43722 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
43723 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
43724 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
43725 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
43726 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
43727 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
43728 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
43729 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
43730 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
43731 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
43732 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
43733 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
43734 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
43735 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
43736 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
43737 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
43738 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
43739 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
43740 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
43741 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
43742 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
43743 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
43744 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
43745 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
43746 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
43747 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
43748 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
43749 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
43750 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
43751 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
43752 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
43753 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
43754 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
43755 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
43756 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
43757 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
43758 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
43759 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
43760 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
43761 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
43762 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
43763 & *X6)
43764 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
43765 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
43766 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
43767 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
43768 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
43769 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
43770 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
43771 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
43772 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
43773 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
43774 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
43775 & X8)
43776 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43777 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
43778 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
43779 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43780 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
43781 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
43782 & X9*X5)
43783 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43784 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
43785 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
43786 & X8*X5)
43787 FM(9,10)=0.5D0*(FMXX+FM(9,10))
43788 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43789 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
43790 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
43791
43792C...Repackage matrix elements.
43793 DO 200 I=1,8
43794 DO 190 J=I,8
43795 RM(I,J)=FM(I,J)
43796 190 CONTINUE
43797 200 CONTINUE
43798 RM(7,7)=FM(7,7)-2D0*FM(9,9)
43799 RM(7,8)=FM(7,8)-2D0*FM(9,10)
43800 RM(8,8)=FM(8,8)-2D0*FM(10,10)
43801
43802C...Produce final result: matrix elements * colours * propagators.
43803 DO 220 I=1,8
43804 DO 210 J=I,8
43805 FAC=8D0
43806 IF(I.EQ.J)FAC=4D0
43807 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
43808 210 CONTINUE
43809 220 CONTINUE
43810 WTQQBH=-WTQQBH/256D0
43811
43812 ELSE
43813C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
43814 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
43815 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
43816 & *X6+X8*X7)
43817 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
43818 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
43819 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
43820 & X5)
43821 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
43822 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
43823 & *X9+X4*X8)
43824
43825C...Produce final result: matrix elements * propagators.
43826 A11=A11/DX(7)**2
43827 A12=A12/(DX(7)*DX(8))
43828 A22=A22/DX(8)**2
43829 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
43830 ENDIF
43831
43832 RETURN
43833 END
43834
43835C*********************************************************************
43836
43837C...PYSTBH (and auxiliaries)
43838C.. Evaluates the matrix elements for t + b + H production.
43839
43840 SUBROUTINE PYSTBH(WTTBH)
43841
43842C...DOUBLE PRECISION AND INTEGER DECLARATIONS
43843 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43844 IMPLICIT INTEGER(I-N)
43845 INTEGER PYK,PYCHGE,PYCOMP
43846
43847C...COMMONBLOCKS
43848 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43849 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43850 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43851 COMMON/PYINT1/MINT(400),VINT(400)
43852 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43853 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
43854 COMMON/PYINT4/MWID(500),WIDS(500,5)
43855 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
43856 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43857 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
43858 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
43859 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
43860 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
43861 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43862 DOUBLE PRECISION MW2
43863 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
43864 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
43865
43866C...LOCAL ARRAYS AND COMPLEX VARIABLES
43867 DIMENSION QQ(4,2),PP(4,3)
43868 DATA QQ/8*0D0/
43869
43870 WTTBH=0D0
43871
43872C...KINEMATIC PARAMETERS.
43873 SHPR=SQRT(VINT(26))*VINT(1)
43874 PH=SQRT(VINT(21))*VINT(1)
43875 SPH=PH**2
43876
43877C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
43878 DO 100 I=1,2
43879 PT=SQRT(MAX(0D0,VINT(197+5*I)))
43880 PP(1,I)=PT*COS(VINT(198+5*I))
43881 PP(2,I)=PT*SIN(VINT(198+5*I))
43882 100 CONTINUE
43883 PP(1,3)=-PP(1,1)-PP(1,2)
43884 PP(2,3)=-PP(2,1)-PP(2,2)
43885 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
43886 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
43887 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
43888 PMT3=SQRT(PMS3)
43889 PP(3,3)=PMT3*SINH(VINT(211))
43890 PP(4,3)=PMT3*COSH(VINT(211))
43891 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
43892 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
43893 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
43894 PP(3,2)=-PP(3,1)-PP(3,3)
43895 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
43896 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
43897
43898C...CM SYSTEM, INGOING QUARKS/GLUONS
43899 QQ(3,1) = SHPR/2.D0
43900 QQ(4,1) = QQ(3,1)
43901 QQ(3,2) = -QQ(3,1)
43902 QQ(4,2) = QQ(4,1)
43903
43904C...PARAMETERS FOR AMPLITUDE METHOD
43905 ALPHA = AEM
43906 ALPHAS = AS
43907 SW2 = PARU(102)
43908 MW2 = PMAS(24,1)**2
43909 TANB = PARU(141)
43910 VTB = VCKM(3,3)
43911 RMB=PYMRUN(5,VINT(52))
43912
43913 ISUB=MINT(1)
43914
43915 IF (ISUB.EQ.401) THEN
43916 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43917 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43918 ELSE IF (ISUB.EQ.402) THEN
43919 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43920 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43921 END IF
43922
43923 RETURN
43924 END
43925C------------------------------------------------------------------
43926 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
43927C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
43928 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43929 IMPLICIT INTEGER(I-N)
43930 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
43931 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43932 SAVE /PYCTBH/
43933
43934C TOP WIDTH CALCULATION
43935C VTB = 0.99
43936 MW=DSQRT(MW2)
43937 XB=(MB/MT)**2
43938 XW=(MW/MT)**2
43939 XH =(MHP/MT)**2
43940 GAMTBH = 0D0
43941 IF (MT .LT. (MHP+MB)) THEN
43942C T ->B W ONLY
43943 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43944 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43945 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43946 GAMT = GAMTBW
43947 ELSE
43948C T ->BW +T ->B H^+
43949 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43950 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43951 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43952C
43953 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
43954 & -4.D0*(MHP*MB/MT**2)**2 )
43955 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
43956 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
43957 GAMT = GAMTBW+GAMTBH
43958 ENDIF
43959C THUS BR IS
43960 BR=GAMTBH/GAMT
43961 RETURN
43962 END
43963
43964C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
43965C GG->TBH^+, QQBAR->TBH^+
43966C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
43967C (FOR INSTANCE WITH PYTHIA)
43968C------------------------------------------------------------
43969C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
43970C PHYS REV. D 60 (1999) 115011
43971C (THESE FILES PREPARED BY J.-L. KNEUR)
43972C------------------------------------------------------------
43973C 1) GG->TBH^+
43974 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43975C
43976C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
43977C
43978C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
43979C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
43980C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
43981C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
43982C "PHYSICAL PARAMETERS" INPUT:
43983C MT,MB TOP AND BOTTOM MASSES;
43984C MHP CHARGED HIGGS MASS
43985C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
43986C
43987C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
43988C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
43989C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
43990C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
43991C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
43992C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
43993C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
43994C
43995 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43996 IMPLICIT INTEGER(I-N)
43997 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43998 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43999 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
44000 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
44001 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
44002
44003 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
44004 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
44005C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
44006C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
44007C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
44008C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
44009C (TAN BETA) VALUES
44010C
44011C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
44012C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
44013
44014 PI = 4*DATAN(1.D0)
44015 MW = DSQRT(MW2)
44016C
44017C COLLECTING THE RELEVANT OVERALL FACTORS:
44018C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
44019 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
44020C COUPLING CONSTANT (OVERALL NORMALIZATION)
44021 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
44022C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
44023C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
44024C ALPHAS IS ALPHA_STRONG;
44025C SW2 IS SIN(THETA_W)**2.
44026C
44027C VTB=.998D0
44028C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
44029C
44030 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
44031 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
44032C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
44033C
44034C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
44035C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
44036 DO 100 KK=1,4
44037 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
44038 100 CONTINUE
44039C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
44040 S = 2*PYTBHS(Q1,Q2)
44041 P1Q1=PYTBHS(Q1,P1)
44042 P1Q2=PYTBHS(P1,Q2)
44043 P2Q1=PYTBHS(P2,Q1)
44044 P2Q2=PYTBHS(P2,Q2)
44045 P1P2=PYTBHS(P1,P2)
44046C
44047C TOP WIDTH CALCULATION
44048 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
44049C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
44050C THEN DEFINE TOP (RESONANT) PROPAGATOR:
44051 A1INV= S -2*P1Q1 -2*P1Q2
44052 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
44053C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
44054C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
44055C THE TOP WIDTH
44056 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
44057 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
44058C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
44059C NOW COMES THE AMP**2:
44060C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
44061C THE EXPRESSIONS BELOW
44062 V18=0.D0
44063 A18=0.D0
44064 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
44065 &512*A1*A2*MB*MT/3-
44066 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
44067 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
44068 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
44069 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
44070 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
44071 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
44072 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
44073 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
44074 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
44075 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
44076 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
44077 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
44078 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
44079 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
44080 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
44081 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
44082 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
44083 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
44084 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
44085 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
44086 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
44087 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
44088 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
44089 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
44090 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
44091 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
44092 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
44093 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
44094 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
44095 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
44096 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
44097 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
44098 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
44099 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
44100 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
44101 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
44102 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
44103 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
44104 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
44105 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
44106 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
44107 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
44108 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
44109 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
44110 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
44111 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
44112 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
44113 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
44114 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
44115 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
44116 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
44117 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
44118 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
44119 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
44120 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
44121 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
44122 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
44123 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
44124 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
44125 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
44126 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
44127 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
44128 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
44129 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
44130 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
44131 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
44132 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
44133 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
44134 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
44135 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
44136 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
44137 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
44138 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44139 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
44140 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44141 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
44142 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
44143 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
44144 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
44145 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
44146 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
44147 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
44148 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
44149 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
44150 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
44151 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
44152 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
44153 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
44154 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
44155 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44156 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44157 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44158 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
44159 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
44160 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
44161 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
44162 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
44163 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
44164 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
44165 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
44166 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
44167 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
44168 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
44169 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
44170 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
44171 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
44172 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
44173 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
44174 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
44175 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
44176 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
44177 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
44178 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
44179 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
44180 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
44181 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
44182 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
44183 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
44184 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
44185 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
44186 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
44187 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
44188 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
44189 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
44190 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
44191 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
44192 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
44193 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
44194 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
44195 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
44196 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
44197 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
44198 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
44199 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
44200 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
44201 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
44202 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
44203 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
44204 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
44205 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
44206 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
44207 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
44208 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
44209 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
44210 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
44211 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
44212 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
44213 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44214 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
44215 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44216 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
44217 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
44218 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44219 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44220 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44221 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
44222 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
44223 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
44224 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44225 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44226 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
44227 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
44228 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
44229 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
44230 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44231 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44232 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
44233 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
44234 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
44235 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
44236 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
44237 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
44238 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
44239 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
44240 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44241 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
44242 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44243 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44244 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44245 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
44246 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
44247 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44248 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44249 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
44250 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44251 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44252 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
44253 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
44254 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
44255 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
44256 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
44257 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
44258 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
44259 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
44260 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
44261 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
44262 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
44263 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
44264 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
44265 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
44266 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
44267 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
44268 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44269 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44270 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
44271 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
44272 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
44273 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
44274 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
44275 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44276 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44277 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
44278 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44279 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44280 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
44281 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
44282 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
44283 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
44284 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
44285 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
44286 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
44287 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
44288 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
44289 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
44290 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
44291 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
44292 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
44293 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
44294 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
44295 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
44296 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
44297 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
44298 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
44299 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
44300 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
44301 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
44302 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
44303 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
44304 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
44305 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
44306 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
44307 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
44308 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
44309 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44310 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44311 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44312 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
44313 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
44314 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
44315 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
44316 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
44317 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
44318 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
44319 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
44320 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
44321 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
44322 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
44323 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44324 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44325 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
44326 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44327 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44328 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
44329 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
44330 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
44331 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
44332 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
44333 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
44334 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
44335 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
44336 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
44337 &384*A12*MB*MT*P1Q1**2/S**2+
44338 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
44339 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
44340 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
44341 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
44342 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
44343 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
44344 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
44345 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
44346 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
44347 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
44348 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
44349 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
44350 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
44351 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
44352 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
44353 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
44354 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
44355 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
44356 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
44357 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
44358 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
44359 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
44360 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
44361 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
44362 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
44363 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
44364 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
44365 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
44366 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
44367 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
44368 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
44369 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
44370 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
44371 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
44372 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
44373 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
44374 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
44375 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
44376 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
44377 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
44378 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
44379 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
44380 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
44381 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
44382 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
44383 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
44384 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
44385 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
44386 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
44387 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
44388 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
44389 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
44390 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
44391 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
44392 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44393 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44394 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
44395 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44396 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44397 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
44398 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
44399 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
44400 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
44401 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
44402 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
44403 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
44404 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
44405 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
44406 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
44407 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
44408 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
44409 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
44410 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
44411 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
44412 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
44413 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
44414 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44415 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44416 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
44417 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
44418 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
44419 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
44420 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
44421 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
44422 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
44423 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
44424 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
44425 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
44426 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
44427 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
44428 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
44429 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
44430 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
44431 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
44432 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
44433 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
44434 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
44435 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
44436 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
44437 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
44438 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
44439 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
44440 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
44441 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
44442 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
44443 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
44444 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
44445 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
44446 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
44447 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
44448 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44449 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44450 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
44451 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
44452 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
44453 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
44454 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
44455 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
44456 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
44457 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
44458 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
44459 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44460 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44461 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44462 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44463 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44464 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44465 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
44466 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
44467 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
44468 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
44469 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
44470 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
44471 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
44472 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
44473 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
44474 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
44475 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
44476 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
44477 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
44478 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
44479 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
44480 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
44481 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
44482 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
44483 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
44484 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
44485 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
44486 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
44487 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
44488 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
44489 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
44490 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
44491 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
44492 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
44493 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
44494 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
44495 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
44496 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44497 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44498 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
44499 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
44500 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
44501 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
44502 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
44503 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
44504 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
44505 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
44506 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
44507 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
44508 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
44509 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44510 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44511 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
44512 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
44513 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
44514
44515 V18BIS=
44516 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44517 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44518 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44519 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44520 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
44521 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
44522 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
44523 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
44524 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
44525 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
44526 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
44527 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
44528 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
44529 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
44530 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
44531 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
44532 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
44533 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
44534 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
44535 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44536 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44537 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
44538 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
44539 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
44540 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
44541 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
44542 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
44543 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
44544 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
44545 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
44546 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
44547 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
44548 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
44549 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
44550 &272*A1*A2*P1Q1*S/(3*P1Q2)+
44551 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
44552 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
44553 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
44554 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
44555 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
44556 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
44557 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
44558 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
44559 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
44560 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
44561 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
44562 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
44563 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
44564 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
44565 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
44566 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
44567 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
44568 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
44569 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
44570 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
44571 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
44572 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
44573 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
44574 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
44575 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
44576 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
44577 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
44578 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44579 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
44580 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
44581 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
44582 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
44583 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
44584 &32*A12*P2Q1*S/(3*P1Q1)-
44585 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
44586 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
44587 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
44588 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
44589 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
44590 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
44591 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
44592 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
44593 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
44594 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
44595 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
44596 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
44597 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
44598 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
44599 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
44600 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
44601 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
44602 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
44603 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
44604 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
44605 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
44606 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
44607 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
44608 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
44609 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
44610 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
44611 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
44612 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
44613 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
44614 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44615 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
44616 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
44617 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
44618 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
44619 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
44620 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
44621 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
44622 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
44623 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44624 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
44625 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44626 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44627 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44628 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44629 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44630 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44631 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44632 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44633 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
44634 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
44635 &272*A1*A2*P2Q1*S/(3*P2Q2)-
44636 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
44637 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
44638 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
44639 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
44640 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
44641 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
44642 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
44643 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
44644 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
44645 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
44646 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
44647 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
44648 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
44649 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
44650 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
44651 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
44652 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
44653 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
44654 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
44655 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
44656 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
44657 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
44658 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44659C
44660
44661 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
44662 &512*A1*A2*MB*MT/3+
44663 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
44664 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
44665 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
44666 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
44667 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
44668 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
44669 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
44670 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
44671 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
44672 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
44673 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
44674 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
44675 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
44676 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
44677 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
44678 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
44679 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
44680 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
44681 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
44682 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
44683 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
44684 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
44685 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
44686 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
44687 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
44688 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
44689 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
44690 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
44691 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
44692 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
44693 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
44694 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
44695 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
44696 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
44697 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
44698 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
44699 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
44700 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
44701 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
44702 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
44703 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
44704 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
44705 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
44706 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
44707 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
44708 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
44709 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
44710 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
44711 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
44712 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
44713 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
44714 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
44715 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
44716 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
44717 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
44718 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
44719 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
44720 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
44721 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
44722 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
44723 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
44724 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
44725 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
44726 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
44727 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
44728 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
44729 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
44730 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
44731 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
44732 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
44733 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
44734 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
44735 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44736 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44737 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44738 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
44739 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
44740 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
44741 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
44742 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
44743 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
44744 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
44745 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
44746 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
44747 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
44748 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
44749 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
44750 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
44751 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
44752 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44753 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
44754 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44755 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
44756 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
44757 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
44758 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
44759 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
44760 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
44761 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
44762 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
44763 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
44764 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
44765 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
44766 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
44767 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
44768 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
44769 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
44770 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
44771 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
44772 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
44773 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
44774 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
44775 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
44776 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
44777 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
44778 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
44779 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
44780 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
44781 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
44782 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
44783 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
44784 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
44785 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
44786 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
44787 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
44788 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
44789 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
44790 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
44791 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
44792 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
44793 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
44794 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
44795 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
44796 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
44797 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
44798 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
44799 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
44800 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
44801 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
44802 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
44803 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
44804 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
44805 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
44806 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
44807 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44808 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44809 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
44810 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44811 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44812 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44813 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
44814 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
44815 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44816 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
44817 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44818 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
44819 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
44820 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
44821 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44822 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
44823 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
44824 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
44825 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
44826 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
44827 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44828 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
44829 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
44830 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
44831 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
44832 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
44833 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
44834 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
44835 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
44836 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
44837 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
44838 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44839 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44840 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44841 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44842 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
44843 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44844 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44845 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44846 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44847 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44848 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44849 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
44850 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
44851 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
44852 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
44853 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
44854 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
44855 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
44856 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
44857 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
44858 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
44859 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
44860 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
44861 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
44862 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
44863 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
44864 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
44865 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44866 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44867 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
44868 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
44869 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
44870 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
44871 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
44872 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44873 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
44874 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
44875 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44876 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44877 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
44878 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
44879 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
44880 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
44881 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
44882 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
44883 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
44884 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
44885 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
44886 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
44887 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
44888 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
44889 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
44890 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
44891 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
44892 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
44893 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
44894 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
44895 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
44896 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
44897 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
44898 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
44899 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
44900 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
44901 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
44902 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
44903 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
44904 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
44905 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
44906 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
44907 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44908 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44909 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
44910 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
44911 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
44912 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
44913 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
44914 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
44915 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
44916 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
44917 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
44918 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
44919 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
44920 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44921 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
44922 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
44923 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44924 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44925 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
44926 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
44927 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
44928 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
44929 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
44930 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
44931 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
44932 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
44933 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
44934 &384*A12*MB*MT*P1Q1**2/S**2+
44935 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
44936 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
44937 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
44938 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
44939 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
44940 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
44941 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
44942 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
44943 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
44944 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
44945 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
44946 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
44947 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
44948 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
44949 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
44950 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
44951 &384*A2**2*MB*MT*P2Q2**2/S**2+
44952 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
44953 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
44954 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
44955 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
44956 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
44957 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
44958 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
44959 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
44960 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
44961 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
44962 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
44963 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
44964 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
44965 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
44966 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
44967 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
44968 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
44969 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
44970 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
44971 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
44972 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
44973 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
44974 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
44975 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
44976 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
44977 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
44978 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
44979 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
44980 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
44981 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
44982 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
44983 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
44984 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
44985 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
44986 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
44987 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
44988 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
44989 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
44990 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44991 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
44992 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44993 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
44994 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
44995 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
44996 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
44997 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
44998 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
44999 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
45000 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
45001 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
45002 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
45003 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
45004 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
45005 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
45006 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
45007 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
45008 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
45009 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
45010 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
45011 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
45012 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
45013 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
45014 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
45015 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
45016 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
45017 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
45018 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
45019 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
45020 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
45021 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
45022 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
45023 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
45024 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
45025 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
45026 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
45027 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
45028 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
45029 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
45030 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
45031 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
45032 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
45033 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
45034 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
45035 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
45036 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
45037 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
45038 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
45039 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
45040 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
45041 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
45042 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
45043 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
45044 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
45045 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
45046 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
45047 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
45048 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
45049 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
45050 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
45051 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
45052 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
45053 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
45054 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
45055 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45056 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45057 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45058 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45059 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45060 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
45061 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
45062 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
45063 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
45064 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
45065 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
45066 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
45067 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
45068 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
45069 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
45070 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
45071 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
45072 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
45073 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
45074 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
45075 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
45076 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
45077 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
45078 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
45079 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
45080 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
45081 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
45082 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
45083 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
45084 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
45085 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
45086 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
45087 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
45088 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
45089 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
45090 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
45091 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
45092 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
45093 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
45094 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
45095 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
45096 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
45097 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
45098 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
45099 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
45100 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
45101 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
45102 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
45103 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
45104 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
45105 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
45106 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
45107 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45108 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45109 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45110 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45111 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45112 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45113 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
45114 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
45115 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
45116 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
45117 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
45118 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
45119 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
45120 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
45121 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
45122 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
45123 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
45124 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
45125 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
45126 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
45127 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
45128 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
45129 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
45130 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
45131 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
45132 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
45133 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
45134 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
45135 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
45136 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
45137 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
45138 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
45139 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
45140 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
45141 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
45142 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
45143 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
45144 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
45145
45146 A18BIS=
45147 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
45148 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
45149 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
45150 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
45151 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
45152 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
45153 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
45154 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
45155 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
45156 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
45157 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
45158 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
45159 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
45160 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
45161 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
45162 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
45163 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
45164 &12*S/(P1Q2*P2Q1)+
45165 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
45166 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
45167 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
45168 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
45169 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
45170 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
45171 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
45172 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
45173 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
45174 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
45175 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
45176 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
45177 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
45178 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
45179 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
45180 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
45181 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
45182 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
45183 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
45184 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
45185 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
45186 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
45187 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
45188 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
45189 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
45190 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
45191 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
45192 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
45193 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
45194 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
45195 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
45196 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
45197 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
45198 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
45199 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
45200 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
45201 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
45202 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
45203 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
45204 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
45205 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
45206 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
45207 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
45208 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
45209 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
45210 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
45211 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
45212 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
45213 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
45214 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
45215 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
45216 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
45217 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
45218 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
45219 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
45220 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45221 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45222 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
45223 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45224 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45225 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
45226 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
45227 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
45228 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
45229 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
45230 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
45231 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
45232 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
45233 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
45234 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
45235 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
45236 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
45237 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
45238 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
45239 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
45240 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
45241 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
45242 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
45243 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
45244 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
45245 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
45246 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
45247 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
45248 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
45249 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
45250 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
45251C
45252 V18=V18+V18BIS
45253 A18=A18+A18BIS
45254 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
45255 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
45256 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
45257 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
45258 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
45259 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
45260 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
45261 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
45262 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
45263 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
45264 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
45265 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
45266 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
45267 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
45268 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
45269 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
45270 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
45271 V910=V910+96*A1*A2*P1P2*P2Q1/S-
45272 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
45273 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
45274 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
45275 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
45276 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
45277C
45278 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
45279 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
45280 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
45281 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
45282 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
45283 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
45284 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
45285 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
45286 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
45287 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
45288 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
45289 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
45290 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
45291 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
45292 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
45293 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
45294 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
45295 A910=A910+96*A1*A2*P1P2*P2Q1/S-
45296 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
45297 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
45298 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
45299 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
45300 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
45301C
45302C FINAL RESULT;
45303C
45304 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
45305
45306 END
45307C---------------------------------------------------------
45308C 2) Q QBAR ->TBH^+
45309 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
45310C
45311C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
45312C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
45313 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45314 IMPLICIT INTEGER(I-N)
45315 DOUBLE PRECISION MW2,MT,MB,MHP,MW
45316 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
45317 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45318 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45319 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45320 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
45321 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
45322C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
45323C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
45324C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
45325C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
45326C
45327C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
45328C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
45329C
45330 DIMENSION YY(2,2)
45331
45332 PI = 4*DATAN(1.D0)
45333 MW = DSQRT(MW2)
45334
45335C COLLECTING THE RELEVANT OVERALL FACTORS:
45336C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
45337 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
45338C COUPLING CONSTANT (OVERALL NORMALIZATION)
45339 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
45340C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
45341C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
45342C ALPHAS IS ALPHA_STRONG;
45343C SW2 IS SIN(THETA_W)**2.
45344C
45345C VTB=.998D0
45346C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
45347C
45348 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
45349 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
45350C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
45351C
45352C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
45353C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
45354 DO 100 KK=1,4
45355 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
45356 100 CONTINUE
45357C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
45358 S = 2*PYTBHS(Q1,Q2)
45359 P1Q1=PYTBHS(Q1,P1)
45360 P1Q2=PYTBHS(P1,Q2)
45361 P2Q1=PYTBHS(P2,Q1)
45362 P2Q2=PYTBHS(P2,Q2)
45363 P1P2=PYTBHS(P1,P2)
45364C
45365C TOP WIDTH CALCULATION
45366 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
45367C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
45368C THEN DEFINE TOP (RESONANT) PROPAGATOR:
45369 A1INV= S -2*P1Q1 -2*P1Q2
45370 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
45371C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
45372C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
45373 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
45374 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
45375C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
45376C NOW COMES THE AMP**2:
45377C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
45378C THE EXPRESSIONS BELOW
45379 YY(1, 1) = -16*A**2*A2**2*MB*MT+
45380 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
45381 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
45382 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
45383 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
45384 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
45385 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
45386 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
45387 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
45388 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
45389 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
45390 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
45391 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
45392 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
45393 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
45394 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
45395 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
45396 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
45397 &32*A2**2*MB**2*P1P2*V**2/S+
45398 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
45399 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
45400 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
45401 YY(1, 1)=2*YY(1, 1)
45402
45403 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
45404 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
45405 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
45406 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
45407 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
45408 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
45409 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
45410 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
45411 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
45412 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
45413 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
45414 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
45415 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
45416 &64*A**2*A1*A2*MB*MT*P1P2/S+
45417 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
45418 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
45419 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
45420 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
45421 &64*A**2*A1*A2*P1Q1*P2Q1/S-
45422 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
45423 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
45424 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
45425 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
45426 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
45427 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
45428 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
45429 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
45430 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
45431 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
45432 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
45433 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
45434 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
45435 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
45436 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
45437 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
45438 &32*A1*A2*P1P2*P1Q1*V**2/S+
45439 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
45440 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
45441 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
45442 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
45443
45444
45445 YY(2, 2) =-16*A**2*A12*MB*MT+
45446 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
45447 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
45448 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
45449 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
45450 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
45451 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
45452 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
45453 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
45454 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
45455 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
45456 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
45457 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
45458 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
45459 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
45460 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
45461 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
45462 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
45463 &32*A12*MT**2*P2Q2*V**2/S-
45464 &32*A12*P1Q2*P2Q2*V**2/S
45465 YY(2, 2)=2*YY(2, 2)
45466
45467 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
45468 AMP2= FACT*PS*VTB**2*RES
45469
45470 END
45471C=====================================================================
45472C ************* FUNCTION SCALAR PRODUCTS *************************
45473 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
45474 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45475 IMPLICIT INTEGER(I-N)
45476 DIMENSION A(4),B(4)
45477 DUM=A(4)*B(4)
45478 DO 100 ID=1,3
45479 DUM=DUM-A(ID)*B(ID)
45480 100 CONTINUE
45481 PYTBHS=DUM
45482 RETURN
45483 END
45484
45485C*********************************************************************
45486
45487C...PYMSIN
45488C...Initializes supersymmetry: finds sparticle masses and
45489C...branching ratios and stores this information.
45490C...AUTHOR: STEPHEN MRENNA
45491C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
45492
45493 SUBROUTINE PYMSIN
45494
45495C...Double precision and integer declarations.
45496 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45497 IMPLICIT INTEGER(I-N)
45498 INTEGER PYK,PYCHGE,PYCOMP
45499C...Parameter statement to help give large particle numbers.
45500 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45501 &KEXCIT=4000000,KDIMEN=5000000)
45502C...Commonblocks.
45503 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45504 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45505 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45506 COMMON/PYDAT4/CHAF(500,2)
45507 CHARACTER CHAF*16
45508 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
45509 COMMON/PYINT4/MWID(500),WIDS(500,5)
45510 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45511 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
45512 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45513 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45514 COMMON/PYHTRI/HHH(7)
45515 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
45516 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
45517 &/PYMSSM/,/PYMSRV/,/PYSSMT/
45518
45519C...Local variables.
45520 DOUBLE PRECISION ALFA,BETA
45521 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
45522 INTEGER I,J,J1,I1,K1
45523 INTEGER KC,LKNT,IDLAM(400,3)
45524 DOUBLE PRECISION XLAM(0:400)
45525 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
45526 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
45527 DOUBLE PRECISION DELM,XMDIF
45528 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
45529 DOUBLE PRECISION ARG,SGNMU,R
45530 INTEGER IMSSM
45531 INTEGER IRPRTY
45532 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
45533 SAVE MWIDSU,MDCYSU
45534 DATA KFSUSY/
45535 &1000001,2000001,1000002,2000002,1000003,2000003,
45536 &1000004,2000004,1000005,2000005,1000006,2000006,
45537 &1000011,2000011,1000012,2000012,1000013,2000013,
45538 &1000014,2000014,1000015,2000015,1000016,2000016,
45539 &1000021,1000022,1000023,1000025,1000035,1000024,
45540 &1000037,1000039, 25, 35, 36, 37,
45541 & 6, 24, 45, 46,1000045, 9*0/
45542 DATA INIT/0/
45543
45544C...Automatically read QNUMBERS, MASS, and DECAY tables
45545 IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
45546 NQNUM=0
45547 CALL PYSLHA(0,0,IFAIL)
45548 CALL PYSLHA(5,0,IFAIL)
45549 ENDIF
45550 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
45551
45552C...Do nothing further if SUSY not requested
45553 IMSSM=IMSS(1)
45554 IF(IMSSM.EQ.0) RETURN
45555
45556C...Save copy of MWID(KC) and MDCY(KC,1) values before
45557C...they are set to zero for the LSP.
45558 IF(INIT.EQ.0) THEN
45559 INIT=1
45560 DO 100 I=1,36
45561 KF=KFSUSY(I)
45562 KC=PYCOMP(KF)
45563 MWIDSU(I)=MWID(KC)
45564 MDCYSU(I)=MDCY(KC,1)
45565 100 CONTINUE
45566 ENDIF
45567
45568C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
45569 DO 110 I=1,36
45570 KF=KFSUSY(I)
45571 KC=PYCOMP(KF)
45572 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
45573 MWID(KC)=MWIDSU(I)
45574 MDCY(KC,1)=MDCYSU(I)
45575 ENDIF
45576 110 CONTINUE
45577
45578C...First part of routine: set masses and couplings.
45579
45580C...Reset mixing values in sfermion sector to pure left/right.
45581 DO 120 I=1,16
45582 SFMIX(I,1)=1D0
45583 SFMIX(I,4)=1D0
45584 SFMIX(I,2)=0D0
45585 SFMIX(I,3)=0D0
45586 120 CONTINUE
45587
45588C...Add NMSSM states if NMSSM switched on, and change old names.
45589 IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
45590C... Switch on NMSSM
45591 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
45592
45593 KFN=25
45594 KCN=KFN
45595 CHAF(KCN,1)='h_10'
45596 CHAF(KCN,2)=' '
45597
45598 KFN=35
45599 KCN=KFN
45600 CHAF(KCN,1)='h_20'
45601 CHAF(KCN,2)=' '
45602
45603 KFN=45
45604 KCN=KFN
45605 CHAF(KCN,1)='h_30'
45606 CHAF(KCN,2)=' '
45607
45608 KFN=36
45609 KCN=KFN
45610 CHAF(KCN,1)='A_10'
45611 CHAF(KCN,2)=' '
45612
45613 KFN=46
45614 KCN=KFN
45615 CHAF(KCN,1)='A_20'
45616 CHAF(KCN,2)=' '
45617
45618 KFN=1000045
45619 KCN=PYCOMP(KFN)
45620 IF (KCN.EQ.0) THEN
45621 DO 123 KCT=100,MSTU(6)
45622 IF(KCHG(KCT,4).GT.100) KCN=KCT
45623 123 CONTINUE
45624 KCN=KCN+1
45625 KCHG(KCN,4)=KFN
45626 MSTU(20)=0
45627 ENDIF
45628C... Set stable for now
45629 PMAS(KCN,2)=1D-6
45630 MWID(KCN)=0
45631 MDCY(KCN,1)=0
45632 MDCY(KCN,2)=0
45633 MDCY(KCN,3)=0
45634 CHAF(KCN,1)='~chi_50'
45635 CHAF(KCN,2)=' '
45636 ENDIF
45637
45638C...Read spectrum from SLHA file.
45639 IF (IMSSM.EQ.11) THEN
45640 CALL PYSLHA(1,0,IFAIL)
45641 ENDIF
45642
45643C...Common couplings.
45644 TANB=RMSS(5)
45645 BETA=ATAN(TANB)
45646 COSB=COS(BETA)
45647 SINB=TANB*COSB
45648 COS2B=COS(2D0*BETA)
45649 ALFA=RMSS(18)
45650 XMW2=PMAS(24,1)**2
45651 XMZ2=PMAS(23,1)**2
45652 XW=PARU(102)
45653
45654C...Define sparticle masses for a general MSSM simulation.
45655 IF(IMSSM.EQ.1) THEN
45656 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
45657 DO 130 I=1,5,2
45658 KC=PYCOMP(KSUSY1+I)
45659 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
45660 KC=PYCOMP(KSUSY2+I)
45661 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
45662 KC=PYCOMP(KSUSY1+I+1)
45663 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
45664 KC=PYCOMP(KSUSY2+I+1)
45665 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
45666 130 CONTINUE
45667 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
45668 IF(XARG.LT.0D0) THEN
45669 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
45670 & ' FROM THE SUM RULE. '
45671 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
45672 RETURN
45673 ELSE
45674 XARG=SQRT(XARG)
45675 ENDIF
45676 DO 140 I=11,15,2
45677 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
45678 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
45679 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
45680 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
45681 140 CONTINUE
45682 IF(IMSS(8).EQ.1) THEN
45683 RMSS(13)=RMSS(6)
45684 RMSS(14)=RMSS(7)
45685 ENDIF
45686
45687C...Alternatively derive masses from SUGRA relations.
45688 ELSEIF(IMSSM.EQ.2) THEN
45689 RMSS(36)=RMSS(16)
45690 CALL PYAPPS
45691C...Or use ISASUSY
45692 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
45693 RMSS(36)=RMSS(16)
45694 CALL PYSUGI
45695 ALFA=RMSS(18)
45696 GOTO 170
45697 ELSE
45698 GOTO 170
45699 ENDIF
45700
45701C...Add in extra D-term contributions.
45702 IF(IMSS(7).EQ.1) THEN
45703 R=0.43D0
45704 DX=RMSS(23)
45705 DY=RMSS(24)
45706 DS=RMSS(25)
45707 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45708 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
45709 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
45710 WRITE(MSTU(11),*) 'C DX = ',DX
45711 WRITE(MSTU(11),*) 'C DY = ',DY
45712 WRITE(MSTU(11),*) 'C DS = ',DS
45713 WRITE(MSTU(11),*) 'C '
45714 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
45715 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
45716 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45717 DQ2=DY/6D0-DX/3D0-DS/3D0
45718 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
45719 DD2=DY/3D0+DX-2D0*DS/3D0
45720 DL2=-DY/2D0+DX-2D0*DS/3D0
45721 DE2=DY-DX/3D0-DS/3D0
45722 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
45723 DHD2=-DY/2D0-2D0*DX/3D0+DS
45724 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
45725 & /ABS(COS2B)
45726 DMA2 = 2D0*DMU2+DHU2+DHD2
45727 DO 150 I=1,5,2
45728 KC=PYCOMP(KSUSY1+I)
45729 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
45730 KC=PYCOMP(KSUSY2+I)
45731 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
45732 KC=PYCOMP(KSUSY1+I+1)
45733 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
45734 KC=PYCOMP(KSUSY2+I+1)
45735 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
45736 150 CONTINUE
45737 DO 160 I=11,15,2
45738 KC=PYCOMP(KSUSY1+I)
45739 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
45740 KC=PYCOMP(KSUSY2+I)
45741 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
45742 KC=PYCOMP(KSUSY1+I+1)
45743 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
45744 160 CONTINUE
45745 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
45746 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
45747 CALL PYSTOP(104)
45748 ENDIF
45749 SGNMU=SIGN(1D0,RMSS(4))
45750 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
45751 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
45752 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
45753 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
45754 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
45755 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
45756 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
45757 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
45758 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
45759 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
45760 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
45761 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
45762 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
45763 CALL PYSTOP(104)
45764 ENDIF
45765 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
45766 RMSS(6)=SQRT(RMSS(6)**2+DL2)
45767 RMSS(7)=SQRT(RMSS(7)**2+DE2)
45768 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
45769 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
45770 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
45771 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
45772 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
45773 ENDIF
45774
45775C...Fix the third generation sfermions.
45776 CALL PYTHRG
45777
45778C...Fix the neutralino--chargino--gluino sector.
45779 CALL PYINOM
45780
45781C...Fix the Higgs sector.
45782 CALL PYHGGM(ALFA)
45783
45784C...Choose the Gunion-Haber convention.
45785 ALFA=-ALFA
45786 RMSS(18)=ALFA
45787
45788C...Print information on mass parameters.
45789 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
45790 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45791 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
45792 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
45793 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
45794 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
45795 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
45796 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
45797 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
45798 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
45799 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45800 ENDIF
45801 IF(IMSS(20).EQ.1) THEN
45802 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45803 WRITE(MSTU(11),*) ' DEBUG MODE '
45804 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
45805 & UMIX(2,1),UMIX(2,2)
45806 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
45807 & UMIXI(2,1),UMIXI(2,2)
45808 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
45809 & VMIX(2,1),VMIX(2,2)
45810 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
45811 & VMIXI(2,1),VMIXI(2,2)
45812 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
45813 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
45814 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
45815 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
45816 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
45817 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
45818 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
45819 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
45820 WRITE(MSTU(11),*) ' ALFA = ',ALFA
45821 WRITE(MSTU(11),*) ' BETA = ',BETA
45822 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
45823 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
45824 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45825 ENDIF
45826
45827C...Set up the Higgs couplings - needed here since initialization
45828C...in PYINRE did not yet occur when PYWIDT is called below.
45829 170 AL=ALFA
45830 BE=BETA
45831 SINA=SIN(AL)
45832 COSA=COS(AL)
45833 COSB=COS(BE)
45834 SINB=TANB*COSB
45835 SBMA=SIN(BE-AL)
45836 SAPB=SIN(AL+BE)
45837 CAPB=COS(AL+BE)
45838 CBMA=COS(BE-AL)
45839 C2A=COS(2D0*AL)
45840 C2B=COSB**2-SINB**2
45841C...tanb (used for H+)
45842 PARU(141)=TANB
45843
45844C...Firstly: h
45845C...Coupling to d-type quarks
45846 PARU(161)=SINA/COSB
45847C...Coupling to u-type quarks
45848 PARU(162)=-COSA/SINB
45849C...Coupling to leptons
45850 PARU(163)=PARU(161)
45851C...Coupling to Z
45852 PARU(164)=SBMA
45853C...Coupling to W
45854 PARU(165)=PARU(164)
45855
45856C...Secondly: H
45857C...Coupling to d-type quarks
45858 PARU(171)=-COSA/COSB
45859C...Coupling to u-type quarks
45860 PARU(172)=-SINA/SINB
45861C...Coupling to leptons
45862 PARU(173)=PARU(171)
45863C...Coupling to Z
45864 PARU(174)=CBMA
45865C...Coupling to W
45866 PARU(175)=PARU(174)
45867C...Coupling to h
45868 IF(IMSS(4).GE.2) THEN
45869 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
45870 ELSE
45871 HHH(3)=HHH(3)+HHH(4)+HHH(5)
45872 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
45873 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
45874 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
45875 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
45876 ENDIF
45877C...Coupling to H+
45878C...Define later
45879 IF(IMSS(4).GE.2) THEN
45880 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
45881 ELSE
45882 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
45883 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
45884 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
45885 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
45886 ENDIF
45887C...Coupling to A
45888 IF(IMSS(4).GE.2) THEN
45889 PARU(177)=COS(2D0*BE)*COS(BE+AL)
45890 ELSE
45891 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
45892 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
45893 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
45894 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
45895 ENDIF
45896C...Coupling to H+
45897 IF(IMSS(4).GE.2) THEN
45898 PARU(178)=PARU(177)
45899 ELSE
45900 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
45901 ENDIF
45902C...Thirdly, A
45903C...Coupling to d-type quarks
45904 PARU(181)=TANB
45905C...Coupling to u-type quarks
45906 PARU(182)=1D0/PARU(181)
45907C...Coupling to leptons
45908 PARU(183)=PARU(181)
45909 PARU(184)=0D0
45910 PARU(185)=0D0
45911C...Coupling to Z h
45912 PARU(186)=COS(BE-AL)
45913C...Coupling to Z H
45914 PARU(187)=SIN(BE-AL)
45915 PARU(188)=0D0
45916 PARU(189)=0D0
45917 PARU(190)=0D0
45918
45919C...Finally: H+
45920C...Coupling to W h
45921 PARU(195)=COS(BE-AL)
45922
45923C...Tell that all Higgs couplings have been set.
45924 MSTP(4)=1
45925
45926C...Set R-Violating couplings.
45927C...Set lambda couplings to common value or "natural values".
45928 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
45929 VIR3=1D0/(126D0)**3
45930 DO 200 IRK=1,3
45931 DO 190 IRI=1,3
45932 DO 180 IRJ=1,3
45933 IF (IRI.NE.IRJ) THEN
45934 IF (IRI.LT.IRJ) THEN
45935 RVLAM(IRI,IRJ,IRK)=RMSS(51)
45936 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
45937 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
45938 & PMAS(9+2*IRK,1)*VIR3)
45939 ELSE
45940 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
45941 ENDIF
45942 ELSE
45943 RVLAM(IRI,IRJ,IRK)=0D0
45944 ENDIF
45945 180 CONTINUE
45946 190 CONTINUE
45947 200 CONTINUE
45948 ENDIF
45949C...Set lambda' couplings to common value or "natural values".
45950 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
45951 VIR3=1D0/(126D0)**3
45952 DO 230 IRI=1,3
45953 DO 220 IRJ=1,3
45954 DO 210 IRK=1,3
45955 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
45956 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
45957 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
45958 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
45959 210 CONTINUE
45960 220 CONTINUE
45961 230 CONTINUE
45962 ENDIF
45963C...Set lambda'' couplings to common value or "natural values".
45964 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
45965 VIR3=1D0/(126D0)**3
45966 DO 260 IRI=1,3
45967 DO 250 IRJ=1,3
45968 DO 240 IRK=1,3
45969 IF (IRJ.NE.IRK) THEN
45970 IF (IRJ.LT.IRK) THEN
45971 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
45972 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
45973 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
45974 & PMAS(2*IRK-1,1)*VIR3)
45975 ELSE
45976 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
45977 ENDIF
45978 ELSE
45979 RVLAMB(IRI,IRJ,IRK) = 0D0
45980 ENDIF
45981 240 CONTINUE
45982 250 CONTINUE
45983 260 CONTINUE
45984 ENDIF
45985
45986C...Antisymmetrize couplings set by user
45987 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
45988 DO 290 IRI=1,3
45989 DO 280 IRJ=1,3
45990 DO 270 IRK=1,3
45991 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
45992 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
45993 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
45994 ENDIF
45995 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
45996 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
45997 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
45998 ENDIF
45999 270 CONTINUE
46000 280 CONTINUE
46001 290 CONTINUE
46002 ENDIF
46003
46004C...Write spectrum to SLHA file
46005 IF (IMSS(23).NE.0) THEN
46006 IFAIL=0
46007 CALL PYSLHA(3,0,IFAIL)
46008 ENDIF
46009
46010C...Second part of routine: set decay modes and branching ratios.
46011
46012C...Allow chi10 -> gravitino + gamma or not.
46013 KC=PYCOMP(KSUSY1+39)
46014 IF( IMSS(11) .NE. 0 ) THEN
46015 PMAS(KC,1)=RMSS(21)/1D9
46016 PMAS(KC,2)=0D0
46017 IRPRTY=0
46018 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
46019 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
46020 IRPRTY=0
46021 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
46022 & ' ALLOWING SUSY LLE DECAYS'
46023 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
46024 & ' ALLOWING SUSY LQD DECAYS'
46025 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
46026 & ' ALLOWING SUSY UDD DECAYS'
46027 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
46028 & ' --- Warning: R-Violating couplings possibly',
46029 & ' incompatible with proton decay'
46030 ELSE
46031 PMAS(KC,1)=9999D0
46032 IRPRTY=1
46033 ENDIF
46034
46035C...Loop over sparticle and Higgs species.
46036 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
46037C...Find the LSP or NLSP for a gravitino LSP
46038 ILSP=0
46039 PMLSP=1D20
46040 DO 300 I=1,36
46041 KF=KFSUSY(I)
46042 IF(KF.EQ.1000039) GOTO 300
46043 KC=PYCOMP(KF)
46044 IF(PMAS(KC,1).LT.PMLSP) THEN
46045 ILSP=I
46046 PMLSP=PMAS(KC,1)
46047 ENDIF
46048 300 CONTINUE
46049 DO 370 I=1,50
46050 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
46051 KF=KFSUSY(I)
46052 IF (KF.EQ.0) GOTO 370
46053 KC=PYCOMP(KF)
46054 LKNT=0
46055
46056C...Check if there are any decays listed for this sparticle
46057C...in a file
46058 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
46059 IFAIL=0
46060 CALL PYSLHA(2,KF,IFAIL)
46061 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
46062 ELSEIF (I.GE.37) THEN
46063 GOTO 370
46064 ENDIF
46065
46066C...Sfermion decays.
46067 IF(I.LE.24) THEN
46068C...First check to see if sneutrino is lighter than chi10.
46069 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
46070 & PMAS(KC,1).LT.PMCHI1) THEN
46071 ELSE
46072 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
46073 ENDIF
46074
46075C...Gluino decays.
46076 ELSEIF(I.EQ.25) THEN
46077 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
46078 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
46079
46080C...Neutralino decays.
46081 ELSEIF(I.GE.26.AND.I.LE.29) THEN
46082 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
46083C...chi10 stable or chi10 -> gravitino + gamma.
46084 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
46085 PMAS(KC,2)=1D-6
46086 MDCY(KC,1)=0
46087 MWID(KC)=0
46088 ENDIF
46089
46090C...Chargino decays.
46091 ELSEIF(I.GE.30.AND.I.LE.31) THEN
46092 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
46093
46094C...Gravitino is stable.
46095 ELSEIF(I.EQ.32) THEN
46096 MDCY(KC,1)=0
46097 MWID(KC)=0
46098
46099C...Higgs decays.
46100 ELSEIF(I.GE.33.AND.I.LE.36) THEN
46101C...Calculate decays to non-SUSY particles.
46102 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
46103 LKNT=0
46104 DO 310 I1=0,100
46105 XLAM(I1)=0D0
46106 310 CONTINUE
46107 DO 330 I1=1,MDCY(KC,3)
46108 K1=MDCY(KC,2)+I1-1
46109 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
46110 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
46111 XLAM(I1)=WDTP(I1)
46112 XLAM(0)=XLAM(0)+XLAM(I1)
46113 DO 320 J1=1,3
46114 IDLAM(I1,J1)=KFDP(K1,J1)
46115 320 CONTINUE
46116 LKNT=LKNT+1
46117 330 CONTINUE
46118C...Add the decays to SUSY particles.
46119 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
46120 ENDIF
46121C...Zero the branching ratios for use in loop mode
46122C...thanks to K. Matchev (FNAL)
46123 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46124 BRAT(IDC)=0D0
46125 340 CONTINUE
46126
46127C...Set stable particles.
46128 IF(LKNT.EQ.0) THEN
46129 MDCY(KC,1)=0
46130 MWID(KC)=0
46131 PMAS(KC,2)=1D-6
46132 PMAS(KC,3)=1D-5
46133 PMAS(KC,4)=0D0
46134
46135C...Store branching ratios in the standard tables.
46136 ELSE
46137 IDC=MDCY(KC,2)+MDCY(KC,3)-1
46138 DELM=1D6
46139 DO 360 IL=1,LKNT
46140 IDCSV=IDC
46141 350 IDC=IDC+1
46142 BRAT(IDC)=0D0
46143 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
46144 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
46145 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
46146 BRAT(IDC)=XLAM(IL)/XLAM(0)
46147 XMDIF=PMAS(KC,1)
46148 IF(MDME(IDC,1).GE.1) THEN
46149 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
46150 & PMAS(PYCOMP(KFDP(IDC,2)),1)
46151 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
46152 & PMAS(PYCOMP(KFDP(IDC,3)),1)
46153 ENDIF
46154 IF(I.LE.32) THEN
46155 IF(XMDIF.GE.0D0) THEN
46156 DELM=MIN(DELM,XMDIF)
46157 ELSE
46158 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
46159 WRITE(MSTU(11),*) ' KF = ',KF
46160 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
46161 ENDIF
46162 ENDIF
46163 GOTO 360
46164 ELSEIF(IDC.EQ.IDCSV) THEN
46165 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
46166 & 'channel not recognized:'
46167 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
46168 GOTO 360
46169 ELSE
46170 GOTO 350
46171 ENDIF
46172 360 CONTINUE
46173
46174C...Store width, cutoff and lifetime.
46175 PMAS(KC,2)=XLAM(0)
46176 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
46177 PMAS(KC,3)=PMAS(KC,2)*10D0
46178 ELSE
46179 PMAS(KC,3)=0.95D0*DELM
46180 ENDIF
46181 IF(PMAS(KC,2).NE.0D0) THEN
46182 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
46183 ENDIF
46184C...Write decays to SLHA file
46185 IF (IMSS(24).NE.0) THEN
46186 IFAIL=0
46187 CALL PYSLHA(4,KF,IFAIL)
46188 ENDIF
46189
46190 ENDIF
46191 370 CONTINUE
46192
46193 RETURN
46194 END
46195C*********************************************************************
46196
46197C...PYSLHA
46198C...Read/write spectrum or decay data from SLHA standard file(s).
46199C...P. Skands
46200C...DECAY TABLE writeout by Nils-Erik Bomark (2010)
46201
46202C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
46203C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
46204C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
46205C... (KFORIG=0 : read all decay tables)
46206C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
46207C...MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24)
46208C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
46209C... (KFORIG=0 : read all MASS entries)
46210
46211 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
46212
46213C...Double precision and integer declarations.
46214 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46215 IMPLICIT INTEGER(I-N)
46216 INTEGER PYK,PYCHGE,PYCOMP
46217 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46218 &KEXCIT=4000000,KDIMEN=5000000)
46219C...Commonblocks.
46220 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46221 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46222 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
46223 COMMON/PYDAT4/CHAF(500,2)
46224 CHARACTER CHAF*16
46225 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
46226 CHARACTER*40 ISAVER,VISAJE
46227 COMMON/PYINT4/MWID(500),WIDS(500,5)
46228 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
46229C...SUSY blocks
46230 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46231 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46232 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46233 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
46234 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
46235
46236C...Local arrays, character variables and data.
46237 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
46238 & AU(3,3),AD(3,3),AE(3,3)
46239 COMMON/PYLH3C/CPRO(2),CVER(2)
46240C...The common block of new states (QNUMBERS / PARTICLE)
46241 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
46242C...- NQNUM : Number of QNUMBERS blocks that have been read in
46243C...- KQNUM(I,0) : KF of new state
46244C...- KQNUM(I,1) : 3 times electric charge
46245C...- KQNUM(I,2) : Number of spin states: (2S + 1)
46246C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
46247C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
46248C...- KQNUM(I,5:9) : space available for further quantum numbers
46249 DIMENSION MMOD(100),MSPC(100),KFDEC(100)
46250 SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
46251C...MMOD: flags to set for each block read in.
46252C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
46253C...MSPC: Flags to set for each block read in.
46254C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
46255C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
46256C...11: AD 12: AE 13: YU 14: YD 15: YE
46257C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
46258 CHARACTER CPRO*12,CVER*12,CHNLIN*6
46259 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
46260 CHARACTER CHINL*120,CHKF*9,CHTMP*16
46261 INTEGER VERBOS
46262 SAVE VERBOS
46263C...Date of last Change
46264 PARAMETER (DOC='10 Jun 2010')
46265C...Local arrays and initial values
46266 DIMENSION IDC(5),KFSUSY(50)
46267 SAVE KFSUSY
46268 DATA NQNUM /0/
46269 DATA NDECAY /0/
46270 DATA VERBOS /1/
46271 DATA NHELLO /0/
46272 DATA MLHEF /0/
46273 DATA MLHEFD /0/
46274 DATA KFSUSY/
46275 &1000001,1000002,1000003,1000004,1000005,1000006,
46276 &2000001,2000002,2000003,2000004,2000005,2000006,
46277 &1000011,1000012,1000013,1000014,1000015,1000016,
46278 &2000011,2000012,2000013,2000014,2000015,2000016,
46279 &1000021,1000022,1000023,1000025,1000035,1000024,
46280 &1000037,1000039, 25, 35, 36, 37,
46281 & 6, 24, 45, 46,1000045, 9*0/
46282 DATA KFDEC/100*0/
46283 RMFUN(IP)=PMAS(PYCOMP(IP),1)
46284
46285C...Shorthand for spectrum and decay table unit numbers
46286 IMSS21=IMSS(21)
46287 IMSS22=IMSS(22)
46288
46289C...Default for LHEF input: read header information
46290 IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
46291 IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
46292 IF (IMSS21.EQ.MSTP(161).AND.IMSS21.NE.0) MLHEF=1
46293 IF (IMSS22.EQ.MSTP(161).AND.IMSS22.NE.0) MLHEFD=1
46294
46295C...Hello World
46296 IF (NHELLO.EQ.0) THEN
46297 IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
46298 WRITE(MSTU(11),5000) DOC
46299 NHELLO=1
46300 ENDIF
46301 ENDIF
46302
46303C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
46304C...+MUPDA).
46305 LFN=IMSS21
46306 IF (MUPDA.EQ.2) LFN=IMSS22
46307 IF (MUPDA.EQ.3) LFN=IMSS(23)
46308 IF (MUPDA.EQ.4) LFN=IMSS(24)
46309C...Flag that we have not yet found whatever we were asked to find.
46310 IRETRN=1
46311C...Flag that we are skipping until <slha> tag found (if LHEF)
46312 ISKIP=0
46313 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) ISKIP=1
46314
46315C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
46316 IF (LFN.EQ.0) THEN
46317 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
46318 GOTO 9999
46319 ENDIF
46320
46321C...If reading LHEF header, start by rewinding file
46322 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
46323
46324C...If told to read spectrum, first zero all previous information.
46325 IF (MUPDA.EQ.1) THEN
46326C...Zero all block read flags
46327 DO 100 M=1,100
46328 MMOD(M)=0
46329 MSPC(M)=0
46330 100 CONTINUE
46331C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
46332 DO 110 ISUSY=1,36
46333 KC=PYCOMP(KFSUSY(ISUSY))
46334 PMAS(KC,1)=0D0
46335 110 CONTINUE
46336C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
46337 DO 130 J=1,4
46338 SFMIX(5,J) =0D0
46339 SFMIX(6,J) =0D0
46340 SFMIX(15,J)=0D0
46341 DO 120 L=1,4
46342 ZMIX(L,J) =0D0
46343 ZMIXI(L,J)=0D0
46344 IF (J.LE.2.AND.L.LE.2) THEN
46345 UMIX(L,J) =0D0
46346 UMIXI(L,J)=0D0
46347 VMIX(L,J) =0D0
46348 VMIXI(L,J)=0D0
46349 ENDIF
46350 120 CONTINUE
46351C...Zero signed masses.
46352 SMZ(J)=0D0
46353 IF (J.LE.2) SMW(J)=0D0
46354 130 CONTINUE
46355
46356C...If reading decays, reset PYTHIA decay counters.
46357 ELSEIF (MUPDA.EQ.2) THEN
46358C...Check if DECAY for this KF already read
46359 IF (KFORIG.NE.0) THEN
46360 DO 140 IDEC=1,NDECAY
46361 IF (KFORIG.EQ.KFDEC(IDEC)) THEN
46362 IRETRN=0
46363 RETURN
46364 ENDIF
46365 140 CONTINUE
46366 ENDIF
46367 KCC=100
46368 NDC=0
46369 BRSUM=0D0
46370 DO 150 KC=1,MSTU(6)
46371 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
46372 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
46373 150 CONTINUE
46374 ELSEIF (MUPDA.EQ.5) THEN
46375C...Zero block read flags
46376 DO 160 M=1,100
46377 MSPC(M)=0
46378 160 CONTINUE
46379 ENDIF
46380
46381C............READ
46382C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
46383 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
46384C...Initialize program and version strings
46385 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
46386 CPRO(MUPDA)=' '
46387 CVER(MUPDA)=' '
46388 ENDIF
46389
46390C...Initialize read loop
46391 MERR=0
46392 NLINE=0
46393 CHBLCK=' '
46394C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
46395 170 CHINL=' '
46396 READ(LFN,'(A120)',END=400) CHINL
46397C...Count which line number we're at.
46398 NLINE=NLINE+1
46399 WRITE(CHNLIN,'(I6)') NLINE
46400
46401C...Skip comment and empty lines without processing.
46402 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
46403
46404C...We assume all upper case below. Rewrite CHINL to all upper case.
46405 INL=0
46406 IGOOD=0
46407 180 INL=INL+1
46408 IF (CHINL(INL:INL).NE.'#') THEN
46409 DO 190 ICH=97,122
46410 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
46411 190 CONTINUE
46412C...Extra safety. Chek for sensible input on line
46413 IF (IGOOD.EQ.0) THEN
46414 DO 200 ICH=48,90
46415 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
46416 200 CONTINUE
46417 ENDIF
46418 IF (INL.LT.120) GOTO 180
46419 ENDIF
46420 IF (IGOOD.EQ.0) GOTO 170
46421
46422C...If reading from LHEF file, skip until <slha> begin tag found
46423 IF (ISKIP.NE.0) THEN
46424 DO 205 I1=1,10
46425 IF (CHINL(I1:I1+4).EQ.'<SLHA') ISKIP=0
46426 205 CONTINUE
46427 IF (ISKIP.NE.0) GOTO 170
46428 ENDIF
46429
46430C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
46431 DO 210 I1=1,10
46432 IF (CHINL(I1:I1+5).EQ.'</SLHA'
46433 & .OR.CHINL(I1:I1+5).EQ.'<EVENT'
46434 & .OR.CHINL(I1:I1+4).EQ.'<INIT') THEN
46435 REWIND(LFN)
46436 GOTO 400
46437 ENDIF
46438 210 CONTINUE
46439
46440C...Check for BLOCK begin statement (spectrum).
46441 IF (CHINL(1:5).EQ.'BLOCK') THEN
46442 MERR=0
46443 READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
46444C...Check if another of this type of block was already read.
46445C...(logarithmic interpolation not yet implemented, so duplicates always
46446C...give errors)
46447 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
46448 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
46449 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
46450 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
46451 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
46452 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
46453 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
46454 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
46455 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
46456 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
46457 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
46458 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
46459 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
46460 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
46461 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
46462 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
46463 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
46464C...Check for new particles
46465 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
46466 & THEN
46467 MSPC(19)=MSPC(19)+1
46468C...Read PDG code
46469 READ(CHBLCK(9:60),*) KFQ
46470
46471 DO 220 MQ=1,NQNUM
46472 IF (KQNUM(MQ,0).EQ.KFQ) THEN
46473 MERR=17
46474 GOTO 380
46475 ENDIF
46476 220 CONTINUE
46477 IF (NHELLO.EQ.0) THEN
46478 WRITE(MSTU(11),5000) DOC
46479 NHELLO=1
46480 ENDIF
46481 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46482 & ' * (PYSLHA:) Reading '//CHBLCK(1:8)//
46483 & ' for KF =',KFQ
46484 NQNUM=NQNUM+1
46485 KQNUM(NQNUM,0)=KFQ
46486 MSPC(19)=MSPC(19)+1
46487 KCQ=PYCOMP(KFQ)
46488C...Only read in new codes (also OK to overwrite if KF > 3000000)
46489 IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
46490 IF (KCQ.EQ.0) THEN
46491 DO 230 KCT=100,MSTU(6)
46492 IF(KCHG(KCT,4).GT.100) KCQ=KCT
46493 230 CONTINUE
46494 KCQ=KCQ+1
46495 ENDIF
46496 KCC=KCQ
46497 KCHG(KCQ,4)=KFQ
46498C...First write PDG code as name
46499 WRITE(CHTMP,*) KFQ
46500 WRITE(CHTMP,'(A)') CHTMP(2:10)
46501C...Then look for real name
46502 IBEG=9
46503 240 IBEG=IBEG+1
46504 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
46505 250 IBEG=IBEG+1
46506 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
46507 IEND=IBEG-1
46508 260 IEND=IEND+1
46509 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
46510 IF (IEND.LT.59) THEN
46511 READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
46512 IF (CHDUM.NE.' ') CHTMP=CHDUM
46513 ENDIF
46514 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
46515 MSTU(20)=0
46516C...Set stable for now
46517 PMAS(KCQ,2)=1D-6
46518 MWID(KCQ)=0
46519 MDCY(KCQ,1)=0
46520 MDCY(KCQ,2)=0
46521 MDCY(KCQ,3)=0
46522 ELSE
46523 WRITE(MSTU(11),*)
46524 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
46525 & CHAF(KCQ,1), '. Entry ignored.'
46526 MERR=7
46527 ENDIF
46528 ENDIF
46529C...Finalize this line and read next.
46530 GOTO 380
46531C...Check for DECAY begin statement (decays).
46532 ELSEIF (CHINL(1:3).EQ.'DEC') THEN
46533 MERR=0
46534 BRSUM=0D0
46535 CHBLCK='DECAY'
46536C...Read KF code and WIDTH
46537 MPSIGN=1
46538 READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
46539 IF (KF.LE.0) THEN
46540 KF=-KF
46541 MPSIGN=-1
46542 ENDIF
46543C...If this is not the KF we're looking for...
46544 IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
46545C...Set block skip flag and read next line.
46546 MERR=16
46547 GOTO 380
46548 ELSE
46549C...Check whether decay table for this particle already read in
46550 DO 280 IDECAY=1,NDECAY
46551 IF (KFDEC(IDECAY).EQ.KF) THEN
46552 WRITE(MSTU(11),'(A,A,I9,A,A6,A)')
46553 & ' * (PYSLHA:) Ignoring DECAY table ',
46554 & 'for KF =',KF,' on line ',CHNLIN,
46555 & ' (duplicate)'
46556 MERR=16
46557 GOTO 380
46558 ENDIF
46559 280 CONTINUE
46560 ENDIF
46561
46562C...Determine PYTHIA KC code of particle
46563 KCREP=0
46564 IF(KF.LE.100) THEN
46565 KCREP=KF
46566 ELSE
46567 DO 290 KCR=101,KCC
46568 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
46569 290 CONTINUE
46570 ENDIF
46571 KC=KCREP
46572 IF (KCREP.NE.0) THEN
46573C...Particle is already known. Do not overwrite low-mass SM particles,
46574C...since this could give problems at hadronization / hadron decay stage.
46575 IF (IABS(KF).LT.1000000.AND.PMAS(KC,1).LT.20D0) THEN
46576C...Set block skip flag and read next line
46577 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46578 & ' * (PYSLHA:) Ignoring DECAY table for KF =',
46579 & KF, ' (SLHA read-in not allowed)'
46580 MERR=16
46581 GOTO 380
46582 ELSEIF (IABS(KF).EQ.6.OR.IABS(KF).EQ.23.OR.IABS(KF).EQ.24)
46583 & THEN
46584C...Set block skip flag and read next line
46585 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46586 & ' * (PYSLHA:) Allowing DECAY table for KF =',
46587 & KF, ' but this is NOT recommended.'
46588 ENDIF
46589 ELSE
46590C... Add new particle. Actually, this should not happen.
46591C... New particles should be added already when reading the spectrum
46592C... information, so go under previously stable category.
46593 KCC=KCC+1
46594 KC=KCC
46595 ENDIF
46596
46597 IF (WIDTH.LE.0D0) THEN
46598C...Stable (i.e. LSP)
46599 WRITE(MSTU(11),'(A,I9,A,A)')
46600 & ' * (PYSLHA:) Reading SLHA stable particle KF =',
46601 & KF,', ',CHAF(KCREP,1)(1:16)
46602 IF (WIDTH.LT.0D0) THEN
46603 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
46604 & ' zero !')
46605 WIDTH=0D0
46606 ENDIF
46607 PMAS(KC,2)=1D-6
46608 MWID(KC)=0
46609 MDCY(KC,1)=0
46610C...Ignore any decay lines that may be present for this KF
46611 MERR=16
46612 MDCY(KC,2)=0
46613 MDCY(KC,3)=0
46614C...Return ok
46615 IRETRN=0
46616 ENDIF
46617C...Finalize and start reading in decay modes.
46618 GOTO 380
46619 ELSEIF (MOD(MERR,10).GE.6) THEN
46620C...If ignore block flag set, skip directly to next line.
46621 GOTO 170
46622 ENDIF
46623
46624C...READ SPECTRUM
46625 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
46626 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
46627 & THEN
46628 READ(CHINL,*) INDX, IVAL
46629 IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
46630 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
46631 IF (INDX.EQ.3) KCHG(KCQ,2)=0
46632 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
46633 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
46634 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
46635 IF (INDX.EQ.4) THEN
46636 KCHG(KCQ,3)=IVAL
46637 IF (IVAL.EQ.1) THEN
46638 CHTMP=CHAF(KCQ,1)
46639 IF (CHTMP.EQ.' ') THEN
46640 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
46641 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
46642 ELSE
46643 ILAST=17
46644 300 ILAST=ILAST-1
46645 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
46646 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
46647 CHTMP(ILAST:ILAST)='-'
46648 ELSE
46649 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
46650 ENDIF
46651 CHAF(KCQ,2)=CHTMP
46652 ENDIF
46653 ENDIF
46654 ENDIF
46655 ELSE
46656 MERR=8
46657 ENDIF
46658 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
46659C...MASS: Mass spectrum
46660 IF (CHBLCK(1:4).EQ.'MASS') THEN
46661 READ(CHINL,*) KF, VAL
46662 MERR=1
46663 KC=0
46664 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
46665C...Read in masses for almost anything
46666 MERR=0
46667 KC=PYCOMP(KF)
46668 IF (KC.NE.0) THEN
46669C...Don't read in masses for special code particles
46670 IF (IABS(KF).GE.80.AND.IABS(KF).LT.100) THEN
46671 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46672 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
46673 & KF, ' (KF reserved by PYTHIA)'
46674 GOTO 170
46675 ENDIF
46676C...Be careful with light SM particles / hadrons
46677 IF (PMAS(KC,1).LE.20D0) THEN
46678 IF (IABS(KF).LE.22) THEN
46679 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46680 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
46681 & KF, ' (SLHA read-in not allowed)'
46682
46683 GOTO 170
46684 ELSEIF (IABS(KF).GE.100.AND.IABS(KF).LT.1000000) THEN
46685 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46686 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
46687 & KF, ' (SLHA read-in not allowed)'
46688 GOTO 170
46689 ENDIF
46690 ENDIF
46691 MSPC(1)=MSPC(1)+1
46692 PMAS(KC,1) = ABS(VAL)
46693 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
46694 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46695 & ' * (PYSLHA:) Reading MASS entry for KF =',
46696 & KF, ', pole mass =', VAL
46697 IRETRN=0
46698 ENDIF
46699C...Check Z, W and top masses
46700 IF (KF.EQ.23.AND.ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0)
46701 & THEN
46702 WRITE(CHTMP,8500) PMAS(PYCOMP(23),1)
46703 CALL PYERRM(9,'(PYSLHA:) Note Z boson mass, M ='
46704 & //CHTMP)
46705 ENDIF
46706 IF (KF.EQ.24.AND.ABS(PMAS(PYCOMP(24),1)-80.4D0).GT.1D0)
46707 & THEN
46708 WRITE(CHTMP,8500) PMAS(PYCOMP(24),1)
46709 CALL PYERRM(9,'(PYSLHA:) Note W boson mass, M ='
46710 & //CHTMP)
46711 ENDIF
46712 IF (KF.EQ.6.AND.ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0)
46713 & THEN
46714 WRITE(CHTMP,8500) PMAS(PYCOMP(6),1)
46715 CALL PYERRM(9,'(PYSLHA:) Note top quark mass, M ='
46716 & //CHTMP//'GeV')
46717 ENDIF
46718C... Signed masses
46719 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
46720 IF (KF.EQ.1000022) SMZ(1)=VAL
46721 IF (KF.EQ.1000023) SMZ(2)=VAL
46722 IF (KF.EQ.1000025) SMZ(3)=VAL
46723 IF (KF.EQ.1000035) SMZ(4)=VAL
46724 IF (KF.EQ.1000024) SMW(1)=VAL
46725 IF (KF.EQ.1000037) SMW(2)=VAL
46726 ENDIF
46727 ELSEIF (MUPDA.EQ.5) THEN
46728 MERR=0
46729 ENDIF
46730C... MODSEL: Model selection and global switches
46731 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
46732 READ(CHINL,*) INDX, IVAL
46733 IF (INDX.LE.200.AND.INDX.GT.0) THEN
46734 IF (IMSS(1).EQ.0) IMSS(1)=11
46735 MODSEL(INDX)=IVAL
46736 MMOD(1)=MMOD(1)+1
46737 IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
46738C... Switch on NMSSM
46739 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
46740 IMSS(13)=MAX(1,IMSS(13))
46741C... Add NMSSM states if not already done
46742
46743 KFN=25
46744 KCN=KFN
46745 CHAF(KCN,1)='h_10'
46746 CHAF(KCN,2)=' '
46747
46748 KFN=35
46749 KCN=KFN
46750 CHAF(KCN,1)='h_20'
46751 CHAF(KCN,2)=' '
46752
46753 KFN=45
46754 KCN=KFN
46755 CHAF(KCN,1)='h_30'
46756 CHAF(KCN,2)=' '
46757
46758 KFN=36
46759 KCN=KFN
46760 CHAF(KCN,1)='A_10'
46761 CHAF(KCN,2)=' '
46762
46763 KFN=46
46764 KCN=KFN
46765 CHAF(KCN,1)='A_20'
46766 CHAF(KCN,2)=' '
46767
46768 KFN=1000045
46769 KCN=PYCOMP(KFN)
46770 IF (KCN.EQ.0) THEN
46771 DO 310 KCT=100,MSTU(6)
46772 IF(KCHG(KCT,4).GT.100) KCN=KCT
46773 310 CONTINUE
46774 KCN=KCN+1
46775 KCHG(KCN,4)=KFN
46776 MSTU(20)=0
46777 ENDIF
46778C... Set stable for now
46779 PMAS(KCN,2)=1D-6
46780 MWID(KCN)=0
46781 MDCY(KCN,1)=0
46782 MDCY(KCN,2)=0
46783 MDCY(KCN,3)=0
46784 CHAF(KCN,1)='~chi_50'
46785 CHAF(KCN,2)=' '
46786 ENDIF
46787 ELSE
46788 MERR=1
46789 ENDIF
46790 ELSEIF (MUPDA.EQ.5) THEN
46791C...If MUPDA = 5, skip all except MASS, return if MODSEL
46792 MERR=8
46793 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
46794 & CHBLCK(1:8).EQ.'PARTICLE') THEN
46795C...Don't print a warning for QNUMBERS when reading spectrum
46796 MERR=8
46797C...MINPAR: Minimal model parameters
46798 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
46799 READ(CHINL,*) INDX, VAL
46800 IF (INDX.LE.100.AND.INDX.GT.0) THEN
46801 PARMIN(INDX)=VAL
46802 MMOD(2)=MMOD(2)+1
46803 ELSE
46804 MERR=1
46805 ENDIF
46806 IF (MMOD(3).NE.0) THEN
46807 WRITE(MSTU(11),*)
46808 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
46809 MERR=1
46810 ENDIF
46811C...tan(beta)
46812 IF (INDX.EQ.3) RMSS(5)=VAL
46813C...EXTPAR: non-minimal model parameters.
46814 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
46815 IF (MMOD(1).NE.0) THEN
46816 READ(CHINL,*) INDX, VAL
46817 IF (INDX.LE.200.AND.INDX.GT.0) THEN
46818 PAREXT(INDX)=VAL
46819 MMOD(3)=MMOD(3)+1
46820 ELSE
46821 MERR=1
46822 ENDIF
46823 ELSE
46824 WRITE(MSTU(11),*)
46825 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
46826 MERR=1
46827 ENDIF
46828C...tan(beta)
46829 IF (INDX.EQ.25) RMSS(5)=VAL
46830 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
46831 READ(CHINL,*) INDX, VAL
46832 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
46833 MERR=1
46834 ELSEIF (INDX.EQ.4) THEN
46835 PMAS(PYCOMP(23),1)=VAL
46836 ELSEIF (INDX.EQ.6) THEN
46837 PMAS(PYCOMP(6),1)=VAL
46838 ENDIF
46839 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
46840 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
46841 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
46842 $ THEN
46843C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
46844 IM=0
46845 IF (CHBLCK(5:6).EQ.'IM') IM=1
46846 320 READ(CHINL,*) INDX1, INDX2, VAL
46847 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
46848 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
46849 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
46850 MSPC(2)=MSPC(2)+1
46851 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
46852 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
46853 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
46854 MSPC(3)=MSPC(3)+1
46855 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
46856 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
46857 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
46858 MSPC(4)=MSPC(4)+1
46859 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
46860 $ .CHBLCK(1:4).EQ.'STAU') THEN
46861 IF (CHBLCK(1:4).EQ.'STOP') THEN
46862 KFSM=6
46863 ISPC=6
46864 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
46865 KFSM=5
46866 ISPC=5
46867 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
46868 KFSM=15
46869 ISPC=7
46870 ENDIF
46871C...Set SFMIX element
46872 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
46873 MSPC(ISPC)=MSPC(ISPC)+1
46874 ENDIF
46875C...Running parameters
46876 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
46877 READ(CHBLCK(8:25),*,ERR=620) Q
46878 READ(CHINL,*) INDX, VAL
46879 MSPC(8)=MSPC(8)+1
46880 IF (INDX.EQ.1) THEN
46881 RMSS(4) = VAL
46882 ELSE
46883 MERR=1
46884 MSPC(8)=MSPC(8)-1
46885 ENDIF
46886 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
46887 READ(CHINL,*,ERR=630) VAL
46888 RMSS(18)= VAL
46889 MSPC(17)=MSPC(17)+1
46890C...Higgs parameters set manually or with FeynHiggs.
46891 IMSS(4)=MAX(2,IMSS(4))
46892 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
46893 & .CHBLCK(1:2).EQ.'AE') THEN
46894 READ(CHBLCK(9:26),*,ERR=620) Q
46895 READ(CHINL,*) INDX1, INDX2, VAL
46896 IF (CHBLCK(2:2).EQ.'U') THEN
46897 AU(INDX1,INDX2)=VAL
46898 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
46899 MSPC(11)=MSPC(11)+1
46900 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
46901 AD(INDX1,INDX2)=VAL
46902 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
46903 MSPC(10)=MSPC(10)+1
46904 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
46905 AE(INDX1,INDX2)=VAL
46906 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
46907 MSPC(12)=MSPC(12)+1
46908 ELSE
46909 MERR=1
46910 ENDIF
46911 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
46912 IF (MSPC(18).EQ.0) THEN
46913 READ(CHBLCK(9:25),*,ERR=620) Q
46914 RMSOFT(0)=Q
46915 ENDIF
46916 READ(CHINL,*) INDX, VAL
46917 RMSOFT(INDX)=VAL
46918 MSPC(18)=MSPC(18)+1
46919 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
46920 MERR=8
46921 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
46922 & .CHBLCK(1:2).EQ.'YE') THEN
46923 MERR=8
46924 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
46925 READ(CHINL(1:6),*) INDX
46926 IT=0
46927 MIRD=0
46928 330 IT=IT+1
46929 IF (CHINL(IT:IT).EQ.' ') GOTO 330
46930C...Don't read index
46931 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
46932 MIRD=1
46933 GOTO 330
46934 ENDIF
46935 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
46936 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
46937 ELSE
46938C... Set unrecognized block flag.
46939 MERR=6
46940 ENDIF
46941
46942C...DECAY TABLES
46943C...Read in decay information
46944 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
46945C...Read new decay chanel
46946 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
46947 NDC=NDC+1
46948C...Read in branching ratio and number of daughters for this mode.
46949 READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
46950 READ(CHINL(4:50),*,ERR=600) DUM, NDA
46951 IF (NDA.LE.5) THEN
46952 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
46953 & '(PYSLHA:) Decay data arrays full by KF = '
46954 $ //CHAF(KC,1))
46955C...If first decay channel, set decays start point in decay table
46956 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
46957 IF (KFORIG.EQ.0) WRITE(MSTU(11),'(1x,A,I9,A,A16)')
46958 & '* (PYSLHA:) Reading DECAY table for '//
46959 & 'KF =',KF,', ',CHAF(KCREP,1)(1:16)
46960C...Set particle parameters (mass set when reading BLOCK MASS above)
46961 PMAS(KC,2)=WIDTH
46962 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
46963 WRITE(MSTU(11),'(1x,A)')
46964 & '* Note: the Pythia gg->h/H/A cross section'//
46965 & ' is proportional to the h/H/A->gg width'
46966 ELSEIF (KF.EQ.23.OR.KF.EQ.24.OR.KF.EQ.6.OR.KF.EQ.32
46967 & .OR.KF.EQ.33.OR.KF.EQ.34) THEN
46968 WRITE(MSTU(11),'(1x,A,A16)')
46969 & '* Warning: will use DECAY table (fixed-width,'//
46970 & ' flat PS) for ',CHAF(KC,1)(1:16)
46971 ENDIF
46972 PMAS(KC,3)=0D0
46973 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
46974 MWID(KC)=2
46975 MDCY(KC,1)=1
46976 MDCY(KC,2)=NDC
46977 MDCY(KC,3)=0
46978C...Add to list of DECAY blocks currently read
46979 NDECAY=NDECAY+1
46980 KFDEC(NDECAY)=KF
46981C...Return ok
46982 IRETRN=0
46983 ENDIF
46984C... Count up number of decay modes for this particle
46985 MDCY(KC,3)=MDCY(KC,3)+1
46986C... Read in decay daughters.
46987 READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
46988C... Flip sign if reading antiparticle decays (if antipartner exists)
46989 DO 340 IDA=1,NDA
46990 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
46991 & IDC(IDA)=MPSIGN*IDC(IDA)
46992 340 CONTINUE
46993C...Switch on decay channel, with products ordered in decreasing ABS(KF)
46994 MDME(NDC,1)=1
46995 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
46996 BRSUM=BRSUM+ABS(BRAT(NDC))
46997 BRAT(NDC)=ABS(BRAT(NDC))
46998 350 IFLIP=0
46999 DO 360 IDA=1,NDA-1
47000 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
47001 ITMP=IDC(IDA)
47002 IDC(IDA)=IDC(IDA+1)
47003 IDC(IDA+1)=ITMP
47004 IFLIP=IFLIP+1
47005 ENDIF
47006 360 CONTINUE
47007 IF (IFLIP.GT.0) GOTO 350
47008C...Treat as ordinary decay, no fancy stuff.
47009 MDME(NDC,2)=0
47010 DO 370 IDA=1,5
47011 IF (IDA.LE.NDA) THEN
47012 KFDP(NDC,IDA)=IDC(IDA)
47013 ELSE
47014 KFDP(NDC,IDA)=0
47015 ENDIF
47016 370 CONTINUE
47017C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
47018C & (KFDP(NDC,J),J=1,NDA)
47019 ELSE
47020 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '//
47021 & CHNLIN)
47022 MERR=11
47023 NDC=NDC-1
47024 ENDIF
47025 ELSEIF(CHINL(1:1).EQ.'+') THEN
47026 MERR=11
47027 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
47028 MERR=16
47029 ELSE
47030 MERR=16
47031 ENDIF
47032 ENDIF
47033C... Error check.
47034 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
47035 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
47036 & //CHINL(1:40)
47037 MERR=0
47038 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
47039 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
47040 & CHBLCK(1:MIN(INL,40))//'... on line '//CHNLIN
47041 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
47042 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
47043 & //CHBLCK(1:INL)//'... on line'//CHNLIN
47044 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
47045 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
47046 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
47047 & //'... on line'//CHNLIN
47048 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
47049 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
47050 & /CHBLCK(1:INL)//'... on line'//CHNLIN
47051 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
47052 WRITE (CHTMP,*) KF
47053 WRITE(MSTU(11),*)
47054 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
47055 & CHTMP(1:9)//' on line'//CHNLIN
47056 ENDIF
47057C...Iterate read loop
47058 GOTO 170
47059C...Error catching
47060 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
47061 & ', ignoring subsequent lines.'
47062 WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
47063 CHBLCK=' '
47064 GOTO 170
47065C...End of read loop
47066 400 CONTINUE
47067C...Set flag that KC codes have been rearranged.
47068 MSTU(20)=0
47069 VERBOS=0
47070
47071C...Perform possible tests that new information is consistent.
47072 IF (MUPDA.EQ.1) THEN
47073 MSTU23=MSTU(23)
47074 MSTU27=MSTU(27)
47075C...Check masses
47076 DO 410 ISUSY=1,37
47077 KF=KFSUSY(ISUSY)
47078C...Don't complain about right-handed neutrinos
47079 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
47080 & +16) GOTO 410
47081C...Only check gravitino in GMSB scenarios
47082 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
47083 KC=PYCOMP(KF)
47084 IF (PMAS(KC,1).EQ.0D0) THEN
47085 WRITE(CHTMP,*) KF
47086 CALL PYERRM(9
47087 & ,'(PYSLHA:) No mass information found for KF ='
47088 & //CHTMP)
47089 ENDIF
47090 410 CONTINUE
47091C...Check mixing matrices (MSSM only)
47092 IF (IMSS(13).EQ.0) THEN
47093 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
47094 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
47095 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
47096 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
47097 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
47098 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
47099 IF (MSPC(5).NE.4) CALL PYERRM(9
47100 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
47101 IF (MSPC(6).NE.4) CALL PYERRM(9
47102 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
47103 IF (MSPC(7).NE.4) CALL PYERRM(9
47104 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
47105 IF (MSPC(8).LT.1) CALL PYERRM(9
47106 & ,'(PYSLHA:) Too few elements in HMIX')
47107 IF (MSPC(10).EQ.0) CALL PYERRM(9
47108 & ,'(PYSLHA:) Missing A_b trilinear coupling')
47109 IF (MSPC(11).EQ.0) CALL PYERRM(9
47110 & ,'(PYSLHA:) Missing A_t trilinear coupling')
47111 IF (MSPC(12).EQ.0) CALL PYERRM(9
47112 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
47113 IF (MSPC(17).LT.1) CALL PYERRM(9
47114 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
47115 ENDIF
47116C...Check wavefunction normalizations.
47117C...Sfermions
47118 DO 420 ISPC=5,7
47119 IF (MSPC(ISPC).EQ.4) THEN
47120 KFSM=ISPC
47121 IF (ISPC.EQ.7) KFSM=15
47122 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
47123 & *SFMIX(KFSM,3))
47124 IF (ABS(1D0-CHECK).GT.1D-3) THEN
47125 KCSM=PYCOMP(KFSM)
47126 CALL PYERRM(17
47127 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
47128 & //CHAF(KCSM,1))
47129 ENDIF
47130C...Bug fix 30/09 2008: PS
47131C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
47132 IF (SFMIX(KFSM,1)*SFMIX(KFSM,4).LT.0D0) THEN
47133 SFMIX(KFSM,3) = -SFMIX(KFSM,3)
47134 SFMIX(KFSM,4) = -SFMIX(KFSM,4)
47135 ENDIF
47136 ENDIF
47137 420 CONTINUE
47138C...Neutralinos + charginos
47139 DO 440 J=1,4
47140 CN1=0D0
47141 CN2=0D0
47142 CU1=0D0
47143 CU2=0D0
47144 CV1=0D0
47145 CV2=0D0
47146 DO 430 L=1,4
47147 CN1=CN1+ZMIX(J,L)**2
47148 CN2=CN2+ZMIX(L,J)**2
47149 IF (J.LE.2.AND.L.LE.2) THEN
47150 CU1=CU1+UMIX(J,L)**2
47151 CU2=CU2+UMIX(L,J)**2
47152 CV1=CV1+VMIX(J,L)**2
47153 CV2=CV2+VMIX(L,J)**2
47154 ENDIF
47155 430 CONTINUE
47156C...NMIX normalization
47157 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
47158 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
47159 CALL PYERRM(19,
47160 & '(PYSLHA:) NMIX: Inconsistent normalization.')
47161 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
47162 ENDIF
47163C...UMIX, VMIX normalizations
47164 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
47165 IF (J.LE.2) THEN
47166 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
47167 CALL PYERRM(19
47168 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
47169 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
47170 & CU2
47171 ENDIF
47172 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
47173 CALL PYERRM(19,
47174 & '(PYSLHA:) VMIX: Inconsistent normalization.')
47175 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
47176 & CV2
47177 ENDIF
47178 ENDIF
47179 ENDIF
47180 440 CONTINUE
47181 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
47182 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
47183 & '* (PYSLHA:) No spectrum inconsistencies were found.'
47184 ELSE
47185 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
47186 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
47187 & ,' Warning: one or more (serious)'//
47188 & ' inconsistencies were found in the spectrum !'
47189 & ,' Read the error messages above and check your'//
47190 & ' input file.'
47191 ENDIF
47192C...Increase precision in Higgs sector using FeynHiggs
47193 IF (IMSS(4).EQ.3) THEN
47194C...FeynHiggs needs MSOFT.
47195 IERR=0
47196 IF (MSPC(18).EQ.0) THEN
47197 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
47198 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
47199 & ' Cannot call FeynHiggs.'
47200 IERR=-1
47201 ELSE
47202 WRITE(MSTU(11),'(1x,/1x,A/)')
47203 & '* (PYSLHA:) Now calling FeynHiggs.'
47204 CALL PYFEYN(IERR)
47205 IF (IERR.NE.0) IMSS(4)=2
47206 ENDIF
47207 ENDIF
47208 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
47209 IBEG=1
47210 IF (KFORIG.NE.0) IBEG=NDECAY
47211 DO 490 IDECAY=IBEG,NDECAY
47212 KF = KFDEC(IDECAY)
47213 KC = PYCOMP(KF)
47214 WRITE(CHKF,8300) KF
47215 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
47216 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
47217 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
47218 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
47219 $ //CHKF)
47220 BRSUM=0D0
47221 BROPN=0D0
47222 DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47223 IF(MDME(IDA,2).GT.80) GOTO 460
47224 KQ=KCHG(KC,1)
47225 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
47226 MERR=0
47227 DO 450 J=1,5
47228 KP=KFDP(IDA,J)
47229 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
47230 IF(KP.EQ.81) KQ=0
47231 ELSEIF(PYCOMP(KP).EQ.0) THEN
47232 MERR=3
47233 ELSE
47234 KQ=KQ-PYCHGE(KP)
47235 KPC=PYCOMP(KP)
47236 PMS=PMS-PMAS(KPC,1)
47237 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
47238 & PMAS(KPC,3))
47239 ENDIF
47240 450 CONTINUE
47241 IF(KQ.NE.0) MERR=MAX(2,MERR)
47242 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
47243 & MERR=MAX(1,MERR)
47244 IF(MERR.EQ.3) CALL PYERRM(17,
47245 & '(PYSLHA:) Unknown particle code in decay of KF ='
47246 $ //CHKF)
47247 IF(MERR.EQ.2) CALL PYERRM(17,
47248 & '(PYSLHA:) Charge not conserved in decay of KF ='
47249 $ //CHKF)
47250 IF(MERR.EQ.1) CALL PYERRM(7,
47251 & '(PYSLHA:) Kinematically unallowed decay of KF ='
47252 $ //CHKF)
47253 BRSUM=BRSUM+BRAT(IDA)
47254 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
47255 460 CONTINUE
47256C...Check branching ratio sum.
47257 IF (BROPN.LE.0D0) THEN
47258C...If zero, set stable.
47259 WRITE(CHTMP,8500) BROPN
47260 CALL PYERRM(7
47261 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
47262 & CHTMP(9:16)//'. Changed to stable.')
47263 PMAS(KC,2)=1D-6
47264 MWID(KC)=0
47265C...If BR's > 1, rescale.
47266 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
47267 WRITE(CHTMP,8500) BRSUM
47268 IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
47269 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
47270 & ' ; sum was'//CHTMP(9:16)//'.')
47271 FAC=1D0/BRSUM
47272 DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47273 IF(MDME(IDA,2).GT.80) GOTO 470
47274 BRAT(IDA)=FAC*BRAT(IDA)
47275 470 CONTINUE
47276 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
47277C...If BR's < 1, insert dummy mode for proper cross section rescaling.
47278 WRITE(CHTMP,8500) BRSUM
47279 IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
47280 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
47281 & CHTMP(9:16)//'. Dummy mode will be inserted.')
47282C...Move table and insert dummy mode
47283 DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47284 NDC=NDC+1
47285 BRAT(NDC)=BRAT(IDA)
47286 KFDP(NDC,1)=KFDP(IDA,1)
47287 KFDP(NDC,2)=KFDP(IDA,2)
47288 KFDP(NDC,3)=KFDP(IDA,3)
47289 KFDP(NDC,4)=KFDP(IDA,4)
47290 KFDP(NDC,5)=KFDP(IDA,5)
47291 MDME(NDC,1)=MDME(IDA,1)
47292 480 CONTINUE
47293 NDC=NDC+1
47294 BRAT(NDC)=1D0-BRSUM
47295 KFDP(NDC,1)=0
47296 KFDP(NDC,2)=0
47297 KFDP(NDC,3)=0
47298 KFDP(NDC,4)=0
47299 KFDP(NDC,5)=0
47300 MDME(NDC,1)=0
47301 BRSUM=1D0
47302C...Update MDCY
47303 MDCY(KC,3)=MDCY(KC,3)+1
47304 MDCY(KC,2)=NDC-MDCY(KC,3)+1
47305 ENDIF
47306 490 CONTINUE
47307 ENDIF
47308
47309
47310C...WRITE SPECTRUM ON SLHA FILE
47311 ELSEIF(MUPDA.EQ.3) THEN
47312C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
47313 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
47314 MODSEL(1)=1
47315 PARMIN(1)=RMSS(8)
47316 PARMIN(2)=RMSS(1)
47317 PARMIN(3)=RMSS(5)
47318 PARMIN(4)=SIGN(1D0,RMSS(4))
47319 PARMIN(5)=RMSS(36)
47320 ENDIF
47321C...Write spectrum
47322 WRITE(LFN,7000) 'SLHA MSSM spectrum'
47323 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
47324 & // ' P. Skands.'
47325 WRITE(LFN,7010) 'MODSEL', 'Model selection'
47326 WRITE(LFN,7110) 1, MODSEL(1)
47327 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
47328 IF (MODSEL(1).EQ.1) THEN
47329 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
47330 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
47331 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
47332 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
47333 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
47334 ELSEIF(MODSEL(2).EQ.2) THEN
47335 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
47336 WRITE(LFN,7210) 2, PARMIN(2), 'M'
47337 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
47338 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
47339 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
47340 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
47341 ENDIF
47342 WRITE(LFN,7000) ' '
47343 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
47344 DO 500 I=1,36
47345 KF=KFSUSY(I)
47346 KC=PYCOMP(KF)
47347 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
47348 KFSM=KF-KSUSY1
47349 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
47350 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
47351 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
47352 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
47353 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
47354 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
47355 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
47356 ELSE
47357 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
47358 ENDIF
47359 500 CONTINUE
47360C...SUSY scale
47361 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
47362 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
47363 WRITE(LFN,7210) 1, RMSS(4),'mu'
47364 WRITE(LFN,7010) 'ALPHA',' '
47365C WRITE(LFN,7210) 1, RMSS(18), 'alpha'
47366 WRITE(LFN,7200) RMSS(18), 'alpha'
47367 WRITE(LFN,7020) 'AU',RMSUSY
47368 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
47369 WRITE(LFN,7020) 'AD',RMSUSY
47370 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
47371 WRITE(LFN,7020) 'AE',RMSUSY
47372 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
47373 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
47374 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
47375 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
47376 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
47377 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
47378 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
47379 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
47380 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
47381 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
47382 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
47383 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
47384 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
47385 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
47386 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
47387 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
47388 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
47389 DO 520 I1=1,4
47390 DO 510 I2=1,4
47391 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
47392 510 CONTINUE
47393 520 CONTINUE
47394 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
47395 DO 540 I1=1,2
47396 DO 530 I2=1,2
47397 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
47398 530 CONTINUE
47399 540 CONTINUE
47400 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
47401 DO 560 I1=1,2
47402 DO 550 I2=1,2
47403 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
47404 550 CONTINUE
47405 560 CONTINUE
47406 WRITE(LFN,7010) 'SPINFO'
47407 IF (IMSS(1).EQ.2) THEN
47408 CPRO(1)='PYTHIA'
47409 CVER(1)='6.4'
47410 ELSEIF (IMSS(1).EQ.12) THEN
47411 ISAVER=VISAJE()
47412 CPRO(1)='ISASUSY'
47413 CVER(1)=ISAVER(1:12)
47414 ENDIF
47415 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
47416 WRITE(LFN,7310) 2, CVER(1), 'Version number'
47417 ENDIF
47418
47419C...Print user information about spectrum
47420 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
47421 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
47422 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
47423 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
47424 IF (MUPDA.EQ.1) THEN
47425 WRITE(MSTU(11),5020) LFN
47426 ELSE
47427 WRITE(MSTU(11),5010) LFN
47428 ENDIF
47429
47430 WRITE(MSTU(11),5400)
47431 WRITE(MSTU(11),5500) 'Pole masses'
47432 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
47433 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
47434 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
47435 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
47436 IF (IMSS(13).EQ.0) THEN
47437 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
47438 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
47439 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
47440 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
47441 & CHAF(37,1), ' ', ' ',' ',' ',
47442 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
47443 ELSEIF (IMSS(13).EQ.1) THEN
47444 KF1=KSUSY1+21
47445 KF2=KSUSY1+22
47446 KF3=KSUSY1+23
47447 KF4=KSUSY1+25
47448 KF5=KSUSY1+35
47449 KF6=KSUSY1+45
47450 KF7=KSUSY1+24
47451 KF8=KSUSY1+37
47452 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
47453 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
47454 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
47455 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
47456 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
47457 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
47458 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
47459 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
47460 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
47461 & RMFUN(37)
47462 ENDIF
47463 WRITE(MSTU(11),5400)
47464 WRITE(MSTU(11),5500) 'Mixing structure'
47465 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
47466 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
47467 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
47468 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
47469 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
47470 & ),(SFMIX(15,J),J=3,4)
47471 WRITE(MSTU(11),5400)
47472 WRITE(MSTU(11),5500) 'Couplings'
47473 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
47474 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
47475 WRITE(MSTU(11),5400)
47476 WRITE(MSTU(11),6500)
47477
47478C...DECAY TABLES writeout
47479C...Write decay information by Nils-Erik Bomark 3/29/2010
47480 ELSEIF (MUPDA.EQ.4) THEN
47481 KF = KFORIG
47482 KC = PYCOMP(KF)
47483 IF (KC.NE.0) THEN
47484 WRITE(LFN,7000) ''
47485 WRITE(LFN,7000) ' PDG Width'
47486 WRITE(LFN,7500) KF,PMAS(KC,2), CHAF(KC,1)
47487 WRITE(LFN,7000)
47488 & ' BR NDA ID1 ID2 ID3'
47489 DO 575 I=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47490 NDA = 0
47491 DO 570 J=1,5
47492 IF (KFDP(I,J).NE.0) NDA = NDA+1
47493 570 CONTINUE
47494 IF (NDA.EQ.2)
47495 & WRITE(LFN,7512) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47496 & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47497 & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47498 IF (NDA.EQ.3)
47499 & WRITE(LFN,7513) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47500 & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47501 & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47502 IF (NDA.EQ.4)
47503 & WRITE(LFN,7514) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47504 & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47505 & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47506 IF (NDA.EQ.5)
47507 & WRITE(LFN,7515) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47508 & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47509 & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47510 575 CONTINUE
47511 ENDIF
47512C....End of DECAY TABLES writeout
47513
47514 ENDIF
47515
47516C...Only rewind when reading
47517 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
47518
47519 9999 RETURN
47520
47521C...Serious error catching
47522 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
47523 write(*,*) CHINL(1:80)
47524 CALL PYSTOP(106)
47525 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
47526 WRITE(*,*) CHINL(1:72)
47527 CALL PYSTOP(106)
47528 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
47529 WRITE(*,*) CHINL(1:80)
47530 CALL PYSTOP(106)
47531 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
47532 WRITE(*,*) CHINL(1:80)
47533 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
47534 CALL PYSTOP(106)
47535 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
47536 WRITE(*,*) CHINL(1:80)
47537 CALL PYSTOP(106)
47538
47539 8300 FORMAT(I9)
47540 8500 FORMAT(F16.5)
47541
47542C...Formats for user information printout.
47543 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.14: SUSY/BSM SPECTRUM '
47544 & ,'INTERFACE',1x,17('*')/1x,'*',1x
47545 & ,'(PYSLHA:) Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
47546 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
47547 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
47548 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
47549 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
47550 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
47551 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
47552 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
47553 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
47554 & ,'----------------')
47555 5400 FORMAT(1x,'*',1x,A)
47556 5500 FORMAT(1x,'*',1x,A,':')
47557 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
47558 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
47559 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
47560 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
47561 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
47562 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
47563 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
47564 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
47565 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
47566 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
47567 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
47568 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
47569 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
47570 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
47571 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
47572 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
47573 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
47574 & ,1x,F6.3,1x),'|')
47575 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
47576 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
47577 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
47578 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
47579 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
47580 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
47581 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
47582 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
47583 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
47584 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
47585 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
47586 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
47587 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
47588 & ,'A_tau = ',F8.2)
47589 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
47590 & ,' mu = ',F8.2)
47591 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
47592
47593C...Format to use for comments
47594 7000 FORMAT('# ',A)
47595C...Format to use for block statements
47596 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
47597 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
47598C...Indexed Int
47599 7110 FORMAT(1x,I4,1x,I4,3x,'#')
47600C...Non-Indexed Double
47601 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
47602C...Indexed Double
47603 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
47604C...Long Indexed Double (PDG + double)
47605 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
47606C...Indexed Char(12)
47607 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
47608C...Single matrix
47609 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
47610C...Double Matrix
47611 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
47612C...Write Decay Table
47613 7500 FORMAT('Decay',1x,I9,1x,1P,E16.8,0P,3x,'#',1x,A)
47614 7510 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),3x,'#',1x,A)
47615 7512 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,2(1x,I9),13x,
47616 & '#',1x,'BR(',A10,1x,'->',2(1x,A10),')')
47617 7513 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,3(1x,I9),3x,
47618 & '#',1x,'BR(',A10,1x,'->',3(1x,A10),')')
47619 7514 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,4(1x,I9),3x,
47620 & '#',1x,'BR(',A10,1x,'->',4(1x,A10),')')
47621 7515 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,5(1x,I9),3x,
47622 & '#',1x,'BR(',A10,1x,'->',5(1x,A10),')')
47623
47624 END
47625
47626
47627C*********************************************************************
47628
47629C...PYAPPS
47630C...Uses approximate analytical formulae to determine the full set of
47631C...MSSM parameters from SUGRA input.
47632C...See M. Drees and S.P. Martin, hep-ph/9504124
47633
47634 SUBROUTINE PYAPPS
47635
47636C...Double precision and integer declarations.
47637 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47638 IMPLICIT INTEGER(I-N)
47639 INTEGER PYK,PYCHGE,PYCOMP
47640C...Parameter statement to help give large particle numbers.
47641 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47642 &KEXCIT=4000000,KDIMEN=5000000)
47643C...Commonblocks.
47644 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47645 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47646 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47647 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
47648
47649 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
47650 &' not intended for serious physics studies'
47651 IMSS(5)=0
47652 IMSS(8)=0
47653 XMT=PMAS(6,1)
47654 XMZ2=PMAS(23,1)**2
47655 XMW2=PMAS(24,1)**2
47656 TANB=RMSS(5)
47657 BETA=ATAN(TANB)
47658 XW=PARU(102)
47659 XMG=RMSS(1)
47660 XMG2=XMG*XMG
47661 XM0=RMSS(8)
47662 XM02=XM0*XM0
47663C...Temporary sign change for AT. Others unchanged.
47664 AT=-RMSS(16)
47665 RMSS(15)=RMSS(16)
47666 RMSS(17)=RMSS(16)
47667 SINB=TANB/SQRT(TANB**2+1D0)
47668 COSB=SINB/TANB
47669
47670 DTERM=XMZ2*COS(2D0*BETA)
47671 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
47672 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
47673 RMSS(6)=XMEL
47674 RMSS(7)=XMER
47675 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
47676 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
47677 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
47678 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
47679 DO 100 I=1,5,2
47680 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
47681 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
47682 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
47683 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
47684 100 CONTINUE
47685 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
47686 IF(XARG.LT.0D0) THEN
47687 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
47688 & ' FROM THE SUM RULE. '
47689 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
47690 RETURN
47691 ELSE
47692 XARG=SQRT(XARG)
47693 ENDIF
47694 DO 110 I=11,15,2
47695 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
47696 PMAS(PYCOMP(KSUSY2+I),1)=XMER
47697 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
47698 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
47699 110 CONTINUE
47700 RMT=PYMRUN(6,PMAS(6,1)**2)
47701 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
47702 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
47703 RMB=PYMRUN(5,PMAS(6,1)**2)
47704 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
47705 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
47706 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
47707 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
47708 &SINB)**2)
47709 RMSS(16)=-ATP
47710 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
47711 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
47712 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
47713 XMU=SIGN(SQRT(XMU2),RMSS(4))
47714 RMSS(4)=XMU
47715 IF(XMA2.GT.0D0) THEN
47716 RMSS(19)=SQRT(XMA2)
47717 ELSE
47718 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
47719 CALL PYSTOP(102)
47720 ENDIF
47721 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
47722 IF(ARG.GT.0D0) THEN
47723 RMSS(14)=SQRT(ARG)
47724 ELSE
47725 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
47726 CALL PYSTOP(102)
47727 ENDIF
47728 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
47729 IF(ARG.GT.0D0) THEN
47730 RMSS(13)=SQRT(ARG)
47731 ELSE
47732 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
47733 CALL PYSTOP(102)
47734 ENDIF
47735 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
47736 IF(ARG.GT.0D0) THEN
47737 RMSS(10)=SQRT(ARG)
47738 ELSE
47739 RMSS(10)=-SQRT(-ARG)
47740 ENDIF
47741 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
47742 IF(ARG.GT.0D0) THEN
47743 RMSS(12)=SQRT(ARG)
47744 ELSE
47745 RMSS(12)=-SQRT(-ARG)
47746 ENDIF
47747 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
47748 IF(ARG.GT.0D0) THEN
47749 RMSS(11)=SQRT(ARG)
47750 ELSE
47751 RMSS(11)=-SQRT(-ARG)
47752 ENDIF
47753
47754 RETURN
47755 END
47756
47757C*********************************************************************
47758
47759C...PYSUGI
47760C...Interface to ISASUSY version 7.71.
47761C...Warning: this interface should not be used with earlier versions
47762C...of ISASUSY, since common block incompatibilities may then arise.
47763C...Calls SUGRA (in ISAJET) to perform RGE evolution.
47764C...Then converts to Gunion-Haber conventions.
47765
47766 SUBROUTINE PYSUGI
47767 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47768
47769 INTEGER PYK,PYCHGE,PYCOMP
47770 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47771 &KEXCIT=4000000,KDIMEN=5000000)
47772
47773C...Date of Change
47774 CHARACTER DOC*11
47775 PARAMETER (DOC='01 May 2006')
47776
47777C...ISASUGRA Input:
47778 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
47779C...XISAIN contains the MSSMi inputs in natural order.
47780 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
47781 $XAMIN(7)
47782 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
47783 SAVE /SUGXIN/
47784C...ISASUGRA Output
47785 CHARACTER*40 ISAVER,VISAJE
47786 REAL SUPER
47787 COMMON /SSPAR/ SUPER(72)
47788 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
47789 $FBGUT,FTAGUT,FNGUT
47790 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
47791 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
47792 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
47793 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
47794 $VUMT,VDMT,ASMTP,ASMSS,M3Q
47795 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
47796 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
47797 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
47798 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
47799 INTEGER IALLOW
47800 SAVE /SUGMG/,/SSPAR/
47801C SUPER: Filled by ISASUGRA.
47802C SUPER(1) = mass of ~g
47803C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
47804C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
47805C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
47806C ,~tau_2
47807C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
47808C SUPER(29) = Higgsino mass = - mu
47809C SUPER(30) = ratio v2/v1 of vev's
47810C SUPER(31:34) = Signed neutralino masses
47811C SUPER(35:50) = Neutralino mixing matrix
47812C SUPER(51:52) = Signed chargino masses
47813C SUPER(53:54) = Chargino left, right mixing angles
47814C SUPER(55:58) = mass of h0, H0, A0, H+
47815C SUPER(59) = Higgs mixing angle alpha
47816C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
47817C SUPER(66) = Gravitino mass
47818C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
47819C SUPER(70) = b-Yukawa at mA scale (not used)
47820C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
47821C GSS: Filled by ISASUGRA
47822C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
47823C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
47824C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
47825C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
47826C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
47827C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
47828C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
47829C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
47830C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
47831C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
47832C GSS(31) = log(vuq)
47833C MSS: Filled by ISASUGRA
47834C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
47835C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
47836C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
47837C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
47838C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
47839C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
47840C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
47841C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
47842C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
47843C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
47844C MSS(31) = ha0 MSS(32) = h+
47845C Unification, filled by ISASUGRA if applicable.
47846C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
47847
47848C...SPYTHIA Input/Output
47849 INTEGER IMSS
47850 DOUBLE PRECISION RMSS
47851 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47852 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47853 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47854C...SLHA Input/Output
47855 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47856 & AU(3,3),AD(3,3),AE(3,3)
47857C...PYTHIA common blocks
47858 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47859 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47860 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47861
47862 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
47863CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47864 INTEGER IMODEL
47865 REAL M0,MHF,A0,MT
47866 CHARACTER*20 CHMOD(5)
47867 CHARACTER*32 FNAME
47868
47869 COMMON /SUGNU/ XNUSUG(18)
47870 REAL XNUSUG
47871 SAVE /SUGNU/
47872
47873 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
47874 & 'truly unified SUGRA', 'non-minimal GMSB'/
47875
47876C...Start by checking for incompatibilities/inconsistencies:
47877 DO 100 ICHK=2,9
47878 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
47879 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
47880 & ,' option not used by PYSUGI'
47881 ENDIF
47882 100 CONTINUE
47883C...ISAJET works with REAL numbers.
47884 MZERO=REAL(RMSS(8))
47885 MHLF=REAL(RMSS(1))
47886 AZERO=REAL(RMSS(16))
47887 TANB=REAL(RMSS(5))
47888 SGNMU=REAL(RMSS(4))
47889 MTOP=REAL(PMAS(6,1))
47890 IMODEL=0
47891 IF (IMSS(1).EQ.12) THEN
47892 IMODEL=1
47893 GOTO 130
47894 ELSEIF(IMSS(1).EQ.13) THEN
47895C...Read from isajet par file in IMSS(20)
47896 LFN=IMSS(20)
47897C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
47898 IF (LFN.EQ.0) THEN
47899 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
47900 GOTO 9999
47901 ENDIF
47902 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
47903CMrenna change to allow any susy model
47904 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
47905 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
47906 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
47907 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
47908 & ' gauge couplings:'
47909 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
47910 READ(LFN,*) IMODEL
47911 IF (IMODEL.EQ.4) THEN
47912 IAL3UN=1
47913 IMODEL=1
47914 ENDIF
47915 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
47916 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
47917 & //' sgn(mu), M_t:'
47918 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
47919 IF (IMODEL.EQ.3) THEN
47920 IMODEL=1
47921 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
47922 & //' 0 to continue:'
47923 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
47924 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
47925 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
47926 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
47927 & //' generation masses'
47928 WRITE(MSTU(11),*)
47929 & ' NUSUG5 = GUT scale 3rd generation masses'
47930 READ(LFN,*) INUSUG
47931 IF (INUSUG.EQ.0) THEN
47932 GOTO 120
47933 ELSEIF (INUSUG.EQ.1) THEN
47934 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
47935 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
47936 IF (XNUSUG(3).LE.0.) THEN
47937 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
47938 CALL PYSTOP(109)
47939 END IF
47940 ELSEIF (INUSUG.EQ.2) THEN
47941 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
47942 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
47943 ELSEIF (INUSUG.EQ.3) THEN
47944 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
47945 READ(LFN,*) XNUSUG(7),XNUSUG(8)
47946 ELSEIF (INUSUG.EQ.4) THEN
47947 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
47948 & //' M(ur), M(el), M(er):'
47949 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
47950 & XNUSUG(10),XNUSUG(9)
47951 ELSEIF (INUSUG.EQ.5) THEN
47952 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
47953 & //' M(Ll), M(Lr):'
47954 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
47955 & XNUSUG(15),XNUSUG(14)
47956 ENDIF
47957 GOTO 110
47958 ENDIF
47959 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
47960 IMSS(11)=1
47961 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
47962 & ,' sgn(mu), M_t, C_gv:'
47963 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
47964 XGMIN(7)=XCMGV
47965 XGMIN(8)=1.
47966C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
47967 AMPL=2.4D18
47968 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
47969 IF (IMODEL.EQ.5) THEN
47970 IMODEL=2
47971 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
47972 & ,' masses at M_mes'
47973 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
47974 & ,' shifts at M_mes'
47975 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
47976 & ' Y at M_mes'
47977 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
47978 & ,'SU(2),SU(3)'
47979 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
47980 & ,' n5_2, n5_3'
47981 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
47982 $ XGMIN(13),XGMIN(14)
47983 ENDIF
47984 ELSE
47985 WRITE(MSTU(11),*) 'Invalid model choice.'
47986 GOTO 9999
47987 ENDIF
47988 ENDIF
47989
47990 120 MZERO=M0
47991 MHLF=MHF
47992 AZERO=A0
47993C TANB=REAL(RMSS(5))
47994C SGNMU=REAL(RMSS(4))
47995 MTOP=MT
47996
47997C...Initialize MSSM parameter array
47998 130 DO 140 IPAR=1,72
47999 SUPER(IPAR)=0.0
48000 140 CONTINUE
48001C...Call ISASUGRA
48002 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
48003C...Check whether ISASUSY thought the model was OK.
48004 IF (NOGOOD.NE.0) THEN
48005 IF (NOGOOD.EQ.1) CALL PYERRM(26
48006 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
48007 IF (NOGOOD.EQ.2) CALL PYERRM(26
48008 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
48009 IF (NOGOOD.EQ.3) CALL PYERRM(26
48010 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
48011 IF (NOGOOD.EQ.4) CALL PYERRM(26
48012 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
48013 IF (NOGOOD.EQ.7) CALL PYERRM(26
48014 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
48015 IF (NOGOOD.EQ.8) CALL PYERRM(26
48016 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
48017C...Give warning, but don't stop, if LSP not ~chi_10.
48018 IF (NOGOOD.EQ.5) CALL PYERRM(16
48019 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
48020 ENDIF
48021C...Warn about possible GUT scale tachyons.
48022 IF (ITACHY.NE.0) CALL PYERRM(16,
48023 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
48024C...Finalize spectrum (last iteration)
48025C...(Thanks to A. Raklev for pointing this out.)
48026C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
48027 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
48028 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
48029 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
48030 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
48031 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
48032 $ MTOP,IALLOW,1)
48033
48034C...M1, M2, M3.
48035 RMSS(1)=dble(GSS(7))
48036 RMSS(2)=dble(GSS(8))
48037 RMSS(3)=dble(GSS(9))
48038 RMSOFT(1)=dble(GSS(7))
48039 RMSOFT(2)=dble(GSS(8))
48040 RMSOFT(3)=dble(GSS(9))
48041C...Mu = - Higgsino mass.
48042 RMSS(4)=-SUPER(29)
48043 RMSS(5)=TANB
48044C...Slepton and squark masses. 2 first generations.
48045 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
48046 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
48047 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
48048 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
48049C...Third generation.
48050 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
48051 RMSS(11)=SUPER(11)
48052 RMSS(12)=SUPER(15)
48053 RMSS(13)=SUPER(22)
48054 RMSS(14)=SUPER(23)
48055C...SLHA: store exact soft spectrum in RMSOFT
48056 RMSOFT(31)=SUPER(18)
48057 RMSOFT(32)=SUPER(20)
48058 RMSOFT(33)=SUPER(22)
48059 RMSOFT(34)=SUPER(19)
48060 RMSOFT(35)=SUPER(21)
48061 RMSOFT(36)=SUPER(23)
48062 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
48063 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
48064 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
48065 RMSOFT(44)=SUPER(3)
48066 RMSOFT(45)=SUPER(9)
48067 RMSOFT(46)=SUPER(15)
48068 RMSOFT(47)=SUPER(5)
48069 RMSOFT(48)=SUPER(7)
48070 RMSOFT(49)=SUPER(11)
48071
48072C...~b, ~t, and ~tau trilinear couplings and mixing angles.
48073 RMSS(15)=SUPER(62)
48074 RMSS(16)=SUPER(60)
48075 RMSS(17)=SUPER(64)
48076 RMSS(26)=SUPER(63)
48077 RMSS(27)=SUPER(61)
48078 RMSS(28)=SUPER(65)
48079C...SLHA trilinears
48080 DO 142 K1=1,3
48081 DO 141 K2=1,3
48082 AE(K1,K2)=0D0
48083 AU(K1,K2)=0D0
48084 AD(K1,K2)=0D0
48085 141 CONTINUE
48086 142 CONTINUE
48087 AE(3,3)=SUPER(64)
48088 AU(3,3)=SUPER(60)
48089 AD(3,3)=SUPER(62)
48090C...Higgs mixing angle alpha (Gunion-Haber convention).
48091 RMSS(18)=-SUPER(59)
48092C...A0 mass.
48093 RMSS(19)=SUPER(57)
48094C...GUT scale coupling
48095 RMSS(20)=AGUTSS
48096C...Gravitino mass (for future compatibility)
48097 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
48098
48099C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
48100C...Higgs sector.
48101 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
48102 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
48103 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
48104 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
48105C...Gluino.
48106 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
48107C...Squarks and Sleptons.
48108 DO 150 ILR=1,2
48109 ILRM=ILR-1
48110 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
48111 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
48112 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
48113 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
48114 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
48115 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
48116 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
48117 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
48118 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
48119 150 CONTINUE
48120 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
48121 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
48122 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
48123C...Neutralinos.
48124 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
48125 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
48126 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
48127 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
48128C...Signed masses (extra minus from going to G-H convention).
48129 SMZ(1)=-SUPER(31)
48130 SMZ(2)=-SUPER(32)
48131 SMZ(3)=-SUPER(33)
48132 SMZ(4)=-SUPER(34)
48133C...Charginos
48134 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
48135 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
48136C...Signed masses (extra minus from going to G-H convention).
48137 SMW(1)=-SUPER(51)
48138 SMW(2)=-SUPER(52)
48139
48140C... Neutralino Mixing.
48141 DO 160 IN=1,4
48142 ZMIX(IN,1)= SUPER(38+4*(IN-1))
48143 ZMIX(IN,2)= SUPER(37+4*(IN-1))
48144 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
48145 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
48146 160 CONTINUE
48147C...Chargino Mixing (PYTHIA same angle as HERWIG).
48148 THX=1D0
48149 THY=1D0
48150 IF (SUPER(53).GT.0) THX=-1D0
48151 IF (SUPER(54).GT.0) THY=-1D0
48152 UMIX(1,1) = -SIN(SUPER(53))
48153 UMIX(1,2) = -COS(SUPER(53))
48154 UMIX(2,1) = -THX*COS(SUPER(53))
48155 UMIX(2,2) = THX*SIN(SUPER(53))
48156 VMIX(1,1) = -SIN(SUPER(54))
48157 VMIX(1,2) = -COS(SUPER(54))
48158 VMIX(2,1) = -THY*COS(SUPER(54))
48159 VMIX(2,2) = THY*SIN(SUPER(54))
48160C...Sfermion mixing (PYTHIA same angle as ISAJET)
48161 SFMIX(5,1)=COS(SUPER(63))
48162 SFMIX(5,2)=SIN(SUPER(63))
48163 SFMIX(5,3)=-SIN(SUPER(63))
48164 SFMIX(5,4)=COS(SUPER(63))
48165 SFMIX(6,1)=COS(SUPER(61))
48166 SFMIX(6,2)=SIN(SUPER(61))
48167 SFMIX(6,3)=-SIN(SUPER(61))
48168 SFMIX(6,4)=COS(SUPER(61))
48169 SFMIX(15,1)=COS(SUPER(65))
48170 SFMIX(15,2)=SIN(SUPER(65))
48171 SFMIX(15,3)=-SIN(SUPER(65))
48172 SFMIX(15,4)=COS(SUPER(65))
48173
48174 IF (MSTP(122).NE.0) THEN
48175C...Print a few lines to make the user know what's happening
48176 ISAVER=VISAJE()
48177 WRITE(MSTU(11),5000) DOC, ISAVER
48178 WRITE(MSTU(11),5100)
48179 IF (IMODEL.EQ.1) THEN
48180 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
48181 & MTOP
48182 WRITE(MSTU(11),5300)
48183 ENDIF
48184 WRITE(MSTU(11),5500) 'Pole masses'
48185 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
48186 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
48187 & ,(SUPER(IP),IP=19,25,2)
48188 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
48189 & ,IP=1,2)
48190 WRITE(MSTU(11),5400)
48191 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
48192 WRITE(MSTU(11),5400)
48193 WRITE(MSTU(11),5500) 'EW scale mixing structure'
48194 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
48195 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
48196 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
48197 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
48198 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
48199 & ),(SFMIX(15,J),J=3,4)
48200 WRITE(MSTU(11),5400)
48201 WRITE(MSTU(11),6450) RMSS(18)
48202 WRITE(MSTU(11),5400)
48203 WRITE(MSTU(11),5500) 'Couplings'
48204 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
48205 WRITE(MSTU(11),5400)
48206 ENDIF
48207
48208C...Call FeynHiggs to improve Higgs sector if requested
48209 IF (IMSS(4).EQ.3) THEN
48210 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
48211 & ' (PYSUGI:) Now calling FeynHiggs.'
48212 CALL PYFEYN(IERR)
48213 IF (IERR.EQ.0) THEN
48214 IMSS(4)=2
48215 IF (MSTP(122).NE.0) THEN
48216 WRITE(MSTU(11),5400)
48217 WRITE(MSTU(11),5500)
48218 & 'Corrected Higgs masses and mixing'
48219 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
48220 & PMAS(37,1)
48221 WRITE(MSTU(11),6450) RMSS(18)
48222 WRITE(MSTU(11),5400)
48223 ENDIF
48224 ENDIF
48225 ENDIF
48226
48227 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
48228
48229C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
48230C...output by ISASUSY.
48231 IMSS(4)=MAX(2,IMSS(4))
48232
48233 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
48234 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
48235 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
48236 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
48237 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
48238 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
48239 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
48240 & ,'----------------')
48241 5400 FORMAT(1x,'*',1x,A)
48242 5500 FORMAT(1x,'*',1x,A,':')
48243 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
48244 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
48245 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
48246 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
48247 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
48248 & ,1x))
48249 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
48250 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
48251 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
48252 & .2,1x))
48253 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
48254 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
48255 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
48256 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
48257 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
48258 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
48259 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
48260 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
48261 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
48262 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
48263 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
48264 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
48265 & ,1x,F6.3,1x),'|')
48266 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
48267 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
48268 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
48269 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
48270 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
48271 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
48272 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
48273 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
48274 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
48275 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
48276 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
48277 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
48278 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
48279 & ,4x,'Alpha_GUT = ',F8.2)
48280 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
48281 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
48282
48283 9999 RETURN
48284 END
48285
48286C*********************************************************************
48287
48288C...PYFEYN
48289C...Interface to FeynHiggs for MSSM Higgs sector.
48290C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
48291C...P. Skands
48292
48293 SUBROUTINE PYFEYN(IERR)
48294
48295C...Double precision and integer declarations.
48296 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48297 IMPLICIT INTEGER(I-N)
48298 INTEGER PYK,PYCHGE,PYCOMP
48299C...Commonblocks.
48300 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48301 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48302C...SUSY blocks
48303 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48304C...FeynHiggs variables
48305 DOUBLE PRECISION RMHIGG(4)
48306 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
48307 DOUBLE COMPLEX DMU,
48308 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
48309 & DM1, DM2, DM3
48310C...SLHA Common Block
48311 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
48312 & AU(3,3),AD(3,3),AE(3,3)
48313 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
48314
48315 IERR=0
48316 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
48317 IF (IERR.NE.0) THEN
48318 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
48319 & //'Will not use FeynHiggs for this run.')
48320 RETURN
48321 ENDIF
48322 Q=RMSOFT(0)
48323 DMB=PMAS(5,1)
48324 DMT=PMAS(6,1)
48325 DMZ=PMAS(23,1)
48326 DMW=PMAS(24,1)
48327 DMA=PMAS(36,1)
48328 DM1=RMSOFT(1)
48329 DM2=RMSOFT(2)
48330 DM3=RMSOFT(3)
48331 DTANB=RMSS(5)
48332 DMU=RMSS(4)
48333 DM3SL=RMSOFT(33)
48334 DM3SE=RMSOFT(36)
48335 DM3SQ=RMSOFT(43)
48336 DM3SU=RMSOFT(46)
48337 DM3SD=RMSOFT(49)
48338 DM2SL=RMSOFT(32)
48339 DM2SE=RMSOFT(35)
48340 DM2SQ=RMSOFT(42)
48341 DM2SU=RMSOFT(45)
48342 DM2SD=RMSOFT(48)
48343 DM1SL=RMSOFT(31)
48344 DM1SE=RMSOFT(34)
48345 DM1SQ=RMSOFT(41)
48346 DM1SU=RMSOFT(44)
48347 DM1SD=RMSOFT(47)
48348 AE33=AE(3,3)
48349 AE22=AE(2,2)
48350 AE11=AE(1,1)
48351 AU33=AU(3,3)
48352 AU22=AU(2,2)
48353 AU11=AU(1,1)
48354 AD33=AD(3,3)
48355 AD22=AD(2,2)
48356 AD11=AD(1,1)
48357 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
48358 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
48359 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
48360 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
48361 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
48362 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
48363 IF (IERR.NE.0) THEN
48364 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
48365 & //' Will not use FeynHiggs for this run.')
48366 RETURN
48367 ENDIF
48368C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
48369 SAEFF=0D0
48370 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
48371 IF (IERR.NE.0) THEN
48372 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
48373 & 'GSCORR. Will not use FeynHiggs for this run.')
48374 RETURN
48375 ENDIF
48376 ALPHA = ASIN(DBLE(SAEFF))
48377 R=RMSS(18)/ALPHA
48378 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
48379 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
48380 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
48381 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
48382 ENDIF
48383 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
48384 & 1.15D0*PMAS(25,1)) THEN
48385 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
48386 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
48387 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
48388 ENDIF
48389 RMSS(18)=ALPHA
48390 PMAS(25,1)=RMHIGG(1)
48391 PMAS(35,1)=RMHIGG(2)
48392 PMAS(36,1)=RMHIGG(3)
48393 PMAS(37,1)=RMHIGG(4)
48394
48395 RETURN
48396 END
48397
48398C*********************************************************************
48399
48400C...PYRNMQ
48401C...Determines the running mass of Squarks.
48402
48403 FUNCTION PYRNMQ(ID,DTERM)
48404
48405C...Double precision and integer declarations.
48406 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48407 IMPLICIT INTEGER(I-N)
48408 INTEGER PYK,PYCHGE,PYCOMP
48409C...Commonblock.
48410 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48411 SAVE /PYMSSM/
48412
48413C...Local variables.
48414 DOUBLE PRECISION PI,R
48415 DOUBLE PRECISION TOL
48416 DOUBLE PRECISION CI(3)
48417 EXTERNAL PYALPS
48418 DOUBLE PRECISION PYALPS
48419 DATA TOL/0.001D0/
48420 DATA PI,R/3.141592654D0,.61803399D0/
48421 DATA CI/0.47D0,0.07D0,0.02D0/
48422
48423 C=1D0-R
48424 CA=CI(ID)
48425 AG=(0.71D0)**2/4D0/PI
48426 AG=RMSS(20)
48427 XM0=RMSS(8)
48428 XMG=RMSS(1)
48429 XM02=XM0*XM0
48430 XMG2=XMG*XMG
48431
48432 AS=PYALPS(XM02+6D0*XMG2)
48433 CG=8D0/9D0*((AS/AG)**2-1D0)
48434 BX=XM02+(CA+CG)*XMG2+DTERM
48435 AX=MIN(50D0**2,0.5D0*BX)
48436 CX=MAX(2000D0**2,2D0*BX)
48437
48438 X0=AX
48439 X3=CX
48440 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
48441 X1=BX
48442 X2=BX+C*(CX-BX)
48443 ELSE
48444 X2=BX
48445 X1=BX-C*(BX-AX)
48446 ENDIF
48447 AS1=PYALPS(X1)
48448 CG=8D0/9D0*((AS1/AG)**2-1D0)
48449 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
48450 AS2=PYALPS(X2)
48451 CG=8D0/9D0*((AS2/AG)**2-1D0)
48452 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
48453 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
48454 IF(F2.LT.F1) THEN
48455 X0=X1
48456 X1=X2
48457 X2=R*X1+C*X3
48458 F1=F2
48459 AS2=PYALPS(X2)
48460 CG=8D0/9D0*((AS2/AG)**2-1D0)
48461 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
48462 ELSE
48463 X3=X2
48464 X2=X1
48465 X1=R*X2+C*X0
48466 F2=F1
48467 AS1=PYALPS(X1)
48468 CG=8D0/9D0*((AS1/AG)**2-1D0)
48469 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
48470 ENDIF
48471 GOTO 100
48472 ENDIF
48473 IF(F1.LT.F2) THEN
48474 PYRNMQ=X1
48475 XMIN=X1
48476 ELSE
48477 PYRNMQ=X2
48478 XMIN=X2
48479 ENDIF
48480
48481 RETURN
48482 END
48483
48484C*********************************************************************
48485
48486C...PYTHRG
48487C...Calculates the mass eigenstates of the third generation sfermions.
48488C...Created: 5-31-96
48489
48490 SUBROUTINE PYTHRG
48491
48492C...Double precision and integer declarations.
48493 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48494 IMPLICIT INTEGER(I-N)
48495 INTEGER PYK,PYCHGE,PYCOMP
48496C...Parameter statement to help give large particle numbers.
48497 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48498 &KEXCIT=4000000,KDIMEN=5000000)
48499C...Commonblocks.
48500 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48501 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48502 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48503 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48504 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48505 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
48506
48507C...Local variables.
48508 DOUBLE PRECISION BETA
48509 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
48510 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
48511 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
48512 DOUBLE PRECISION ATR,AMQR,AMQL
48513 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
48514 INTEGER IF,I,J,II,JJ,IT,L
48515 LOGICAL DTERM
48516 DATA SMALL/1D-3/
48517 DATA ID1/10,10,13/
48518 DATA ID2/5,6,15/
48519 DATA ID3/15,16,17/
48520 DATA ID4/11,12,14/
48521 DATA DTERM/.TRUE./
48522
48523 XMZ2=PMAS(23,1)**2
48524 XMW2=PMAS(24,1)**2
48525 TANB=RMSS(5)
48526 XMU=-RMSS(4)
48527 BETA=ATAN(TANB)
48528 COS2B=COS(2D0*BETA)
48529
48530C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
48531
48532 IOPT=IMSS(5)
48533 IF(IOPT.EQ.1) THEN
48534 CTT=DCOS(RMSS(27))
48535 CTT2=CTT**2
48536 STT=DSIN(RMSS(27))
48537 STT2=STT**2
48538 XM12=RMSS(10)**2
48539 XM22=RMSS(12)**2
48540 XMQL2=CTT2*XM12+STT2*XM22
48541 XMQR2=STT2*XM12+CTT2*XM22
48542 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
48543 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
48544 RMSS(16)=ATOP
48545C......SUBTRACT OUT D-TERM AND FERMION MASS
48546 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
48547 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
48548 IF(XMQL2.GE.0D0) THEN
48549 RMSS(10)=SQRT(XMQL2)
48550 ELSE
48551 RMSS(10)=-SQRT(-XMQL2)
48552 ENDIF
48553 IF(XMQR2.GE.0D0) THEN
48554 RMSS(12)=SQRT(XMQR2)
48555 ELSE
48556 RMSS(12)=-SQRT(-XMQR2)
48557 ENDIF
48558
48559C SAME FOR BOTTOM SQUARK
48560 CTT=DCOS(RMSS(26))
48561 CTT2=CTT**2
48562 STT=DSIN(RMSS(26))
48563 STT2=STT**2
48564 XM22=RMSS(11)**2
48565 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
48566 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
48567 IF(ABS(CTT).GE..9999D0) THEN
48568 ABOT=-XMU*TANB
48569 XMQR2=RMSS(11)**2
48570 ELSEIF(ABS(CTT).LE.1D-4) THEN
48571 ABOT=-XMU*TANB
48572 XMQR2=RMSS(11)**2
48573 ELSE
48574 XM12=(XMQL2-STT2*XM22)/CTT2
48575 XMQR2=STT2*XM12+CTT2*XM22
48576 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
48577 ENDIF
48578 RMSS(15)=ABOT
48579C......SUBTRACT OUT D-TERM AND FERMION MASS
48580 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
48581 IF(XMQR2.GE.0D0) THEN
48582 RMSS(11)=SQRT(XMQR2)
48583 ELSE
48584 RMSS(11)=-SQRT(-XMQR2)
48585 ENDIF
48586C SAME FOR TAU SLEPTON
48587 CTT=DCOS(RMSS(28))
48588 CTT2=CTT**2
48589 STT=DSIN(RMSS(28))
48590 STT2=STT**2
48591 XM12=RMSS(13)**2
48592 XM22=RMSS(14)**2
48593 XMQL2=CTT2*XM12+STT2*XM22
48594 XMQR2=STT2*XM12+CTT2*XM22
48595 XMFR=PMAS(15,1)
48596 XMF2=XMFR**2
48597 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
48598 RMSS(17)=ATAU
48599C......SUBTRACT OUT D-TERM AND FERMION MASS
48600 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
48601 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
48602 IF(XMQL2.GE.0D0) THEN
48603 RMSS(13)=SQRT(XMQL2)
48604 ELSE
48605 RMSS(13)=-SQRT(-XMQL2)
48606 ENDIF
48607 IF(XMQR2.GE.0D0) THEN
48608 RMSS(14)=SQRT(XMQR2)
48609 ELSE
48610 RMSS(14)=-SQRT(-XMQR2)
48611 ENDIF
48612 ENDIF
48613 DO 170 L=1,3
48614 AMQL=RMSS(ID1(L))
48615 IF(AMQL.LT.0D0) THEN
48616 XMQL2=-AMQL**2
48617 ELSE
48618 XMQL2=AMQL**2
48619 ENDIF
48620 ATR=RMSS(ID3(L))
48621 AMQR=RMSS(ID4(L))
48622 IF(AMQR.LT.0D0) THEN
48623 XMQR2=-AMQR**2
48624 ELSE
48625 XMQR2=AMQR**2
48626 ENDIF
48627 IF=ID2(L)
48628 XMF=PYMRUN(IF,PMAS(6,1)**2)
48629 XMF2=XMF**2
48630 AM2(1,1)=XMQL2+XMF2
48631 AM2(2,2)=XMQR2+XMF2
48632 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
48633 IF(DTERM) THEN
48634 IF(L.EQ.1) THEN
48635 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
48636 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
48637 AM2(1,2)=XMF*(ATR+XMU*TANB)
48638 ELSEIF(L.EQ.2) THEN
48639 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
48640 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
48641 AM2(1,2)=XMF*(ATR+XMU/TANB)
48642 ELSEIF(L.EQ.3) THEN
48643 IF(IMSS(8).EQ.1) THEN
48644 AM2(1,1)=RMSS(6)**2
48645 AM2(2,2)=RMSS(7)**2
48646 AM2(1,2)=0D0
48647 RMSS(13)=RMSS(6)
48648 RMSS(14)=RMSS(7)
48649 ELSE
48650 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
48651 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
48652 AM2(1,2)=XMF*(ATR+XMU*TANB)
48653 ENDIF
48654 ENDIF
48655 ENDIF
48656 AM2(2,1)=AM2(1,2)
48657 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
48658 IF(DETM.LT.0D0) THEN
48659 WRITE(MSTU(11),*) ID2(L),DETM,AM2
48660 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
48661 ENDIF
48662 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
48663 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
48664 XMF12=SAME-DIFF
48665 XMF22=SAME+DIFF
48666 IT=0
48667 IF(XMF22-XMF12.GT.0D0) THEN
48668 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
48669 RT(2,2) = RT(1,1)
48670 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
48671 & AM2(1,2)/(XMF22-XMF12))
48672 RT(2,1) = -RT(1,2)
48673 ELSE
48674 RT(1,1) = 1D0
48675 RT(2,2) = RT(1,1)
48676 RT(1,2) = 0D0
48677 RT(2,1) = -RT(1,2)
48678 ENDIF
48679 100 CONTINUE
48680 IT=IT+1
48681
48682 DO 140 I=1,2
48683 DO 130 JJ=1,2
48684 DI(I,JJ)=0D0
48685 DO 120 II=1,2
48686 DO 110 J=1,2
48687 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
48688 110 CONTINUE
48689 120 CONTINUE
48690 130 CONTINUE
48691 140 CONTINUE
48692
48693 IF(DI(1,1).GT.DI(2,2)) THEN
48694 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
48695 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
48696 WRITE(MSTU(11),*) AM2
48697 WRITE(MSTU(11),*) DI
48698 WRITE(MSTU(11),*) RT
48699 DI(1,1)=-RT(2,1)
48700 DI(2,2)=RT(1,2)
48701 DI(1,2)=-RT(2,2)
48702 DI(2,1)=RT(1,1)
48703 DO 160 I=1,2
48704 DO 150 J=1,2
48705 RT(I,J)=DI(I,J)
48706 150 CONTINUE
48707 160 CONTINUE
48708 GOTO 100
48709 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
48710 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
48711 & ' OFF DIAGONAL ELEMENTS '
48712 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
48713 WRITE(MSTU(11),*) DI
48714 WRITE(MSTU(11),*) ' ROTATION = ',RT
48715C...STOP
48716 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
48717 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
48718 & ' NEGATIVE MASSES '
48719 CALL PYSTOP(111)
48720 ENDIF
48721 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
48722 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
48723 SFMIX(IF,1)=RT(1,1)
48724 SFMIX(IF,2)=RT(1,2)
48725 SFMIX(IF,3)=RT(2,1)
48726 SFMIX(IF,4)=RT(2,2)
48727 170 CONTINUE
48728
48729C.....TAU SNEUTRINO MASS...L=3
48730
48731 XARG=AM2(1,1)+XMW2*COS2B
48732 IF(XARG.LT.0D0) THEN
48733 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
48734 & ' FROM THE SUM RULE. '
48735 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
48736 RETURN
48737 ELSE
48738 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
48739 ENDIF
48740
48741 RETURN
48742 END
48743C*********************************************************************
48744
48745C...PYINOM
48746C...Finds the mass eigenstates and mixing matrices for neutralinos
48747C...and charginos.
48748
48749 SUBROUTINE PYINOM
48750
48751C...Double precision and integer declarations.
48752 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48753 IMPLICIT INTEGER(I-N)
48754 INTEGER PYCOMP
48755C...Parameter statement to help give large particle numbers.
48756 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48757 &KEXCIT=4000000,KDIMEN=5000000)
48758C...Commonblocks.
48759 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48760 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48761 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48762 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48763 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48764 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
48765
48766C...Local variables.
48767 DOUBLE PRECISION XMW,XMZ,XM(4)
48768 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
48769 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
48770 DOUBLE PRECISION COSW,SINW
48771 DOUBLE PRECISION XMU
48772 DOUBLE PRECISION TANB,COSB,SINB
48773 DOUBLE PRECISION XM1,XM2,XM3,BETA
48774 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
48775 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
48776 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
48777 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
48778 DOUBLE PRECISION PYALPS,PYALEM
48779 DOUBLE PRECISION PYRNM3
48780 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
48781 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
48782 DATA KFNCHI/1000022,1000023,1000025,1000035/
48783
48784 IOPT=IMSS(2)
48785 IF(IMSS(1).EQ.2) THEN
48786 IOPT=1
48787 ENDIF
48788C...M1, M2, AND M3 ARE INDEPENDENT
48789 IF(IOPT.EQ.0) THEN
48790 XM1=RMSS(1)
48791 XM2=RMSS(2)
48792 XM3=RMSS(3)
48793 ELSEIF(IOPT.GE.1) THEN
48794 Q2=PMAS(23,1)**2
48795 AEM=PYALEM(Q2)
48796 A2=AEM/PARU(102)
48797 A1=AEM/(1D0-PARU(102))
48798 XM1=RMSS(1)
48799 XM2=RMSS(2)
48800 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
48801 IF(IOPT.EQ.1) THEN
48802 XM2=XM1*A2/A1*3D0/5D0
48803 RMSS(2)=XM2
48804 ELSEIF(IOPT.EQ.3) THEN
48805 XM1=XM2*5D0/3D0*A1/A2
48806 RMSS(1)=XM1
48807 ENDIF
48808 XM3=PYRNM3(XM2/A2)
48809 RMSS(3)=XM3
48810 IF(XM3.LE.0D0) THEN
48811 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
48812 CALL PYSTOP(105)
48813 ENDIF
48814 ENDIF
48815
48816C...GLUINO MASS
48817 IF(IMSS(3).EQ.1) THEN
48818 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
48819 ELSE
48820 AQ=0D0
48821 DO 110 I=1,4
48822 DO 100 ILR=1,2
48823 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48824 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
48825 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
48826 100 CONTINUE
48827 110 CONTINUE
48828
48829 DO 130 I=5,6
48830 DO 120 ILR=1,2
48831 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48832 RM2=PMAS(I,1)**2/XM3**2
48833 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
48834 IF(ARG.GE.0D0) THEN
48835 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
48836 AX0=ABS(X0)
48837 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
48838 AX1=ABS(X1)
48839 IF(X0.EQ.1D0) THEN
48840 AT=-1D0
48841 BT=0.25D0
48842 ELSEIF(X0.EQ.0D0) THEN
48843 AT=0D0
48844 BT=-0.25D0
48845 ELSE
48846 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
48847 & 0.5D0*X0**2*LOG(AX0)
48848 BT=(-1D0-2D0*X0)/4D0
48849 ENDIF
48850 IF(X1.EQ.1D0) THEN
48851 AT=-1D0+AT
48852 BT=0.25D0+BT
48853 ELSEIF(X1.EQ.0D0) THEN
48854 AT=0D0+AT
48855 BT=-0.25D0+BT
48856 ELSE
48857 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
48858 & X1**2*LOG(AX1)+AT
48859 BT=(-1D0-2D0*X1)/4D0+BT
48860 ENDIF
48861 AQ=AQ+AT+BT
48862 ELSE
48863 X0=0.5D0*(1D0+RM2-RM1)
48864 Y0=-0.5D0*SQRT(-ARG)
48865 AMGX0=SQRT(X0**2+Y0**2)
48866 AM1X0=SQRT((1D0-X0)**2+Y0**2)
48867 ARGX0=ATAN2(-X0,-Y0)
48868 AR1X0=ATAN2(1D0-X0,Y0)
48869 X1=X0
48870 Y1=-Y0
48871 AMGX1=AMGX0
48872 AM1X1=AM1X0
48873 ARGX1=ATAN2(-X1,-Y1)
48874 AR1X1=ATAN2(1D0-X1,Y1)
48875 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
48876 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
48877 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
48878 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
48879 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
48880 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
48881 AQ=AQ+AT+BT
48882 ENDIF
48883 120 CONTINUE
48884 130 CONTINUE
48885 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
48886 & /(2D0*PARU(2))*(15D0+AQ))
48887 ENDIF
48888
48889C...NEUTRALINO MASSES
48890 DO 150 I=1,4
48891 DO 140 J=1,4
48892 AI(I,J)=0D0
48893 140 CONTINUE
48894 150 CONTINUE
48895 XMZ=PMAS(23,1)/100D0
48896 XMW=PMAS(24,1)/100D0
48897 XMU=RMSS(4)/100D0
48898 SINW=SQRT(PARU(102))
48899 COSW=SQRT(1D0-PARU(102))
48900 TANB=RMSS(5)
48901 BETA=ATAN(TANB)
48902 COSB=COS(BETA)
48903 SINB=TANB*COSB
48904
48905 XM2=XM2/100D0
48906 XM1=XM1/100D0
48907
48908
48909C... Definitions:
48910C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
48911C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
48912 AR(1,1) = XM1*COS(RMSS(30))
48913 AI(1,1) = XM1*SIN(RMSS(30))
48914 AR(2,2) = XM2*COS(RMSS(31))
48915 AI(2,2) = XM2*SIN(RMSS(31))
48916 AR(3,3) = 0D0
48917 AR(4,4) = 0D0
48918 AR(1,2) = 0D0
48919 AR(2,1) = 0D0
48920 AR(1,3) = -XMZ*SINW*COSB
48921 AR(3,1) = AR(1,3)
48922 AR(1,4) = XMZ*SINW*SINB
48923 AR(4,1) = AR(1,4)
48924 AR(2,3) = XMZ*COSW*COSB
48925 AR(3,2) = AR(2,3)
48926 AR(2,4) = -XMZ*COSW*SINB
48927 AR(4,2) = AR(2,4)
48928 AR(3,4) = -XMU*COS(RMSS(33))
48929 AI(3,4) = -XMU*SIN(RMSS(33))
48930 AR(4,3) = -XMU*COS(RMSS(33))
48931 AI(4,3) = -XMU*SIN(RMSS(33))
48932C CALL PYEIG4(AR,WR,ZR)
48933 CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48934 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48935 & 'PROBLEM WITH PYEICG IN PYINOM ')
48936 DO 160 I=1,4
48937 INDEX(I)=I
48938 XM(I)=ABS(WR(I))
48939 160 CONTINUE
48940 DO 180 I=2,4
48941 K=I
48942 DO 170 J=I-1,1,-1
48943 IF(XM(K).LT.XM(J)) THEN
48944 ITMP=INDEX(J)
48945 XTMP=XM(J)
48946 INDEX(J)=INDEX(K)
48947 XM(J)=XM(K)
48948 INDEX(K)=ITMP
48949 XM(K)=XTMP
48950 K=K-1
48951 ELSE
48952 GOTO 180
48953 ENDIF
48954 170 CONTINUE
48955 180 CONTINUE
48956
48957
48958 DO 210 I=1,4
48959 K=INDEX(I)
48960 SMZ(I)=WR(K)*100D0
48961 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
48962 S=0D0
48963 DO 190 J=1,4
48964 S=S+ZR(J,K)**2+ZI(J,K)**2
48965 190 CONTINUE
48966 DO 200 J=1,4
48967 ZMIX(I,J)=ZR(J,K)/SQRT(S)
48968 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
48969 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
48970 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
48971 200 CONTINUE
48972 210 CONTINUE
48973
48974C...CHARGINO MASSES
48975C.....Find eigenvectors of X X^*
48976 DO I=1,4
48977 DO J=1,4
48978 AR(I,J)=0D0
48979 AI(I,J)=0D0
48980 ENDDO
48981 ENDDO
48982 AI(1,1) = 0D0
48983 AI(2,2) = 0D0
48984 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
48985 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
48986 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48987 &XMU*COS(RMSS(33))*SINB)
48988 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
48989 &XMU*SIN(RMSS(33))*SINB)
48990 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48991 &XMU*COS(RMSS(33))*SINB)
48992 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
48993 &XMU*SIN(RMSS(33))*SINB)
48994 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48995 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48996 & 'PROBLEM WITH PYEICG IN PYINOM ')
48997 INDEX(1)=1
48998 INDEX(2)=2
48999 IF(WR(2).LT.WR(1)) THEN
49000 INDEX(1)=2
49001 INDEX(2)=1
49002 ENDIF
49003
49004
49005 DO 240 I=1,2
49006 K=INDEX(I)
49007 SMW(I)=SQRT(WR(K))*100D0
49008 S=0D0
49009 DO 220 J=1,2
49010 S=S+ZR(J,K)**2+ZI(J,K)**2
49011 220 CONTINUE
49012 DO 230 J=1,2
49013 UMIX(I,J)=ZR(J,K)/SQRT(S)
49014 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
49015 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
49016 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
49017 230 CONTINUE
49018 240 CONTINUE
49019C...Force chargino mass > neutralino mass
49020 IFRC=0
49021 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
49022 CALL PYERRM(8,'(PYINOM:) '//
49023 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
49024 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
49025 IFRC=1
49026 ENDIF
49027 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
49028 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
49029
49030C.....Find eigenvectors of X^* X
49031 DO I=1,4
49032 DO J=1,4
49033 AR(I,J)=0D0
49034 AI(I,J)=0D0
49035 ZR(I,J)=0D0
49036 ZI(I,J)=0D0
49037 ENDDO
49038 ENDDO
49039 AI(1,1) = 0D0
49040 AI(2,2) = 0D0
49041 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
49042 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
49043 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
49044 &XMU*COS(RMSS(33))*COSB)
49045 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
49046 &XMU*SIN(RMSS(33))*COSB)
49047 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
49048 &XMU*COS(RMSS(33))*COSB)
49049 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
49050 &XMU*SIN(RMSS(33))*COSB)
49051 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
49052 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
49053 & 'PROBLEM WITH PYEICG IN PYINOM ')
49054 INDEX(1)=1
49055 INDEX(2)=2
49056 IF(WR(2).LT.WR(1)) THEN
49057 INDEX(1)=2
49058 INDEX(2)=1
49059 ENDIF
49060
49061 SIMAG=0D0
49062 DO 270 I=1,2
49063 K=INDEX(I)
49064 S=0D0
49065 DO 250 J=1,2
49066 S=S+ZR(J,K)**2+ZI(J,K)**2
49067 SIMAG=SIMAG+ZI(J,K)**2
49068 250 CONTINUE
49069 DO 260 J=1,2
49070 VMIX(I,J)=ZR(J,K)/SQRT(S)
49071 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
49072 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
49073 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
49074 260 CONTINUE
49075 270 CONTINUE
49076
49077C.....Simplify if no phases
49078 IF(SIMAG.LT.1D-6) THEN
49079 AR(1,1) = XM2*COS(RMSS(31))
49080 AR(2,2) = XMU*COS(RMSS(33))
49081 AR(1,2) = SQRT(2D0)*XMW*SINB
49082 AR(2,1) = SQRT(2D0)*XMW*COSB
49083 IKNT=0
49084 300 CONTINUE
49085 DO I=1,2
49086 DO J=1,2
49087 ZR(I,J)=0D0
49088 ENDDO
49089 ENDDO
49090
49091 DO I=1,2
49092 DO J=1,2
49093 DO K=1,2
49094 DO L=1,2
49095 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
49096 ENDDO
49097 ENDDO
49098 ENDDO
49099 ENDDO
49100 VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
49101 VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
49102 VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
49103 VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
49104 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
49105 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
49106 ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
49107 IKNT=IKNT+1
49108 GOTO 300
49109 ENDIF
49110C.....Must deal with phases
49111 ELSE
49112 CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
49113 CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
49114 CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
49115 CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
49116
49117 IKNT=0
49118 310 CONTINUE
49119 DO I=1,2
49120 DO J=1,2
49121 CAI(I,J)=CMPLX(0D0,0D0)
49122 ENDDO
49123 ENDDO
49124
49125 DO I=1,2
49126 DO J=1,2
49127 DO K=1,2
49128 DO L=1,2
49129 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
49130 & CMPLX(VMIX(J,L),VMIXI(J,L))
49131 ENDDO
49132 ENDDO
49133 ENDDO
49134 ENDDO
49135
49136 CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
49137 CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
49138 TEMPR=VMIX(1,1)
49139 TEMPI=VMIXI(1,1)
49140 VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
49141 VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
49142 TEMPR=VMIX(1,2)
49143 TEMPI=VMIXI(1,2)
49144 VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
49145 VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
49146 TEMPR=VMIX(2,1)
49147 TEMPI=VMIXI(2,1)
49148 VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
49149 VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
49150 TEMPR=VMIX(2,2)
49151 TEMPI=VMIXI(2,2)
49152 VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
49153 VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
49154 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
49155 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
49156 ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
49157 & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
49158 IKNT=IKNT+1
49159 GOTO 310
49160 ENDIF
49161 ENDIF
49162 RETURN
49163 END
49164
49165C*********************************************************************
49166
49167C...PYRNM3
49168C...Calculates the running of M3, the SU(3) gluino mass parameter.
49169
49170 FUNCTION PYRNM3(RGUT)
49171
49172C...Double precision and integer declarations.
49173 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49174 IMPLICIT INTEGER(I-N)
49175 INTEGER PYK,PYCHGE,PYCOMP
49176
49177C...Local variables.
49178 DOUBLE PRECISION R
49179 DOUBLE PRECISION TOL
49180 EXTERNAL PYALPS
49181 DOUBLE PRECISION PYALPS
49182 DATA TOL/0.001D0/
49183 DATA R/0.61803399D0/
49184
49185 C=1D0-R
49186
49187 BX=RGUT*PYALPS(RGUT**2)
49188 AX=MIN(50D0,BX*0.5D0)
49189 CX=MAX(2000D0,2D0*BX)
49190
49191 X0=AX
49192 X3=CX
49193 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
49194 X1=BX
49195 X2=BX+C*(CX-BX)
49196 ELSE
49197 X2=BX
49198 X1=BX-C*(BX-AX)
49199 ENDIF
49200 AS1=PYALPS(X1**2)
49201 F1=ABS(X1-RGUT*AS1)
49202 AS2=PYALPS(X2**2)
49203 F2=ABS(X2-RGUT*AS2)
49204 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
49205 IF(F2.LT.F1) THEN
49206 X0=X1
49207 X1=X2
49208 X2=R*X1+C*X3
49209 F1=F2
49210 AS2=PYALPS(X2**2)
49211 F2=ABS(X2-RGUT*AS2)
49212 ELSE
49213 X3=X2
49214 X2=X1
49215 X1=R*X2+C*X0
49216 F2=F1
49217 AS1=PYALPS(X1**2)
49218 F1=ABS(X1-RGUT*AS1)
49219 ENDIF
49220 GOTO 100
49221 ENDIF
49222 IF(F1.LT.F2) THEN
49223 PYRNM3=X1
49224 XMIN=X1
49225 ELSE
49226 PYRNM3=X2
49227 XMIN=X2
49228 ENDIF
49229
49230 RETURN
49231 END
49232
49233C*********************************************************************
49234
49235C...PYEIG4
49236C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
49237C...Specific application: mixing in neutralino sector.
49238
49239 SUBROUTINE PYEIG4(A,W,Z)
49240
49241C...Double precision and integer declarations.
49242 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49243 IMPLICIT INTEGER(I-N)
49244 INTEGER PYK,PYCHGE,PYCOMP
49245
49246C...Arrays: in call and local.
49247 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
49248
49249C...Coefficients of fourth-degree equation from matrix.
49250C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
49251 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
49252 B2=0D0
49253 DO 110 I=1,3
49254 DO 100 J=I+1,4
49255 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
49256 100 CONTINUE
49257 110 CONTINUE
49258 B1=0D0
49259 B0=0D0
49260 DO 120 I=1,4
49261 I1=MOD(I,4)+1
49262 I2=MOD(I+1,4)+1
49263 I3=MOD(I+2,4)+1
49264 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
49265 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
49266 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
49267 B0=B0+(-1D0)**(I+1)*A(1,I)*(
49268 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
49269 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
49270 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
49271 120 CONTINUE
49272
49273C...Coefficients of third-degree equation needed for
49274C...separation into two second-degree equations.
49275C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
49276 C2=-B2
49277 C1=B1*B3-4D0*B0
49278 C0=-B1**2-B0*B3**2+4D0*B0*B2
49279 CQ=C1/3D0-C2**2/9D0
49280 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
49281 CQR=CQ**3+CR**2
49282
49283C...Cases with one or three real roots.
49284 IF(CQR.GE.0D0) THEN
49285 S1=(CR+SQRT(CQR))**(1D0/3D0)
49286 S2=(CR-SQRT(CQR))**(1D0/3D0)
49287 U=S1+S2-C2/3D0
49288 ELSE
49289 SABS=SQRT(-CQ)
49290 THE=ACOS(CR/SABS**3)/3D0
49291 SRE=SABS*COS(THE)
49292 U=2D0*SRE-C2/3D0
49293 ENDIF
49294
49295C...Find and solve two second-degree equations.
49296 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
49297 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
49298 Q1=U/2D0+SQRT(U**2/4D0-B0)
49299 Q2=U/2D0-SQRT(U**2/4D0-B0)
49300 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
49301 QSAV=Q1
49302 Q1=Q2
49303 Q2=QSAV
49304 ENDIF
49305 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
49306 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
49307 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
49308 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
49309
49310C...Order eigenvalues in asceding mass.
49311 W(1)=X(1)
49312 DO 150 I1=2,4
49313 DO 130 I2=I1-1,1,-1
49314 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
49315 W(I2+1)=W(I2)
49316 130 CONTINUE
49317 140 W(I2+1)=X(I1)
49318 150 CONTINUE
49319
49320C...Find equation system for eigenvectors.
49321 DO 250 I=1,4
49322 DO 170 J1=1,4
49323 D(J1,J1)=A(J1,J1)-W(I)
49324 DO 160 J2=J1+1,4
49325 D(J1,J2)=A(J1,J2)
49326 D(J2,J1)=A(J2,J1)
49327 160 CONTINUE
49328 170 CONTINUE
49329
49330C...Find largest element in matrix.
49331 DAMAX=0D0
49332 DO 190 J1=1,4
49333 DO 180 J2=1,4
49334 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
49335 JA=J1
49336 JB=J2
49337 DAMAX=ABS(D(J1,J2))
49338 180 CONTINUE
49339 190 CONTINUE
49340
49341C...Subtract others by multiple of row selected above.
49342 DAMAX=0D0
49343 DO 210 J3=JA+1,JA+3
49344 J1=J3-4*((J3-1)/4)
49345 RL=D(J1,JB)/D(JA,JB)
49346 DO 200 J2=1,4
49347 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
49348 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
49349 JC=J1
49350 JD=J2
49351 DAMAX=ABS(D(J1,J2))
49352 200 CONTINUE
49353 210 CONTINUE
49354
49355C...Do one more subtraction of a row.
49356 DAMAX=0D0
49357 DO 230 J3=JC+1,JC+3
49358 J1=J3-4*((J3-1)/4)
49359 IF(J1.EQ.JA) GOTO 230
49360 RL=D(J1,JD)/D(JC,JD)
49361 DO 220 J2=1,4
49362 IF(J2.EQ.JB) GOTO 220
49363 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
49364 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
49365 JE=J1
49366 DAMAX=ABS(D(J1,J2))
49367 220 CONTINUE
49368 230 CONTINUE
49369
49370C...Construct unnormalized eigenvector.
49371 JF1=JD+1-4*(JD/4)
49372 JF2=JD+2-4*((JD+1)/4)
49373 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
49374 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
49375 E(JF1)=-D(JE,JF2)
49376 E(JF2)=D(JE,JF1)
49377 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
49378 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
49379 & D(JA,JB)
49380
49381C...Normalize and fill in final array.
49382 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
49383 SGN=(-1D0)**INT(PYR(0)+0.5D0)
49384 DO 240 J=1,4
49385 Z(I,J)=SGN*E(J)/EA
49386 240 CONTINUE
49387 250 CONTINUE
49388
49389 RETURN
49390 END
49391
49392C*********************************************************************
49393
49394C...PYHGGM
49395C...Determines the Higgs boson mass spectrum using several inputs.
49396
49397 SUBROUTINE PYHGGM(ALPHA)
49398
49399C...Double precision and integer declarations.
49400 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49401 IMPLICIT INTEGER(I-N)
49402 INTEGER PYK,PYCHGE,PYCOMP
49403C...Parameter statement to help give large particle numbers.
49404 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49405 &KEXCIT=4000000,KDIMEN=5000000)
49406C...Commonblocks.
49407 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49408 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49409 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
49410 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49411 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
49412
49413C...Local variables.
49414 DOUBLE PRECISION AT,AB,XMU,TANB
49415 DOUBLE PRECISION ALPHA
49416 INTEGER IHOPT
49417 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
49418 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
49419 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
49420 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
49421
49422 IHOPT=IMSS(4)
49423 IF(IHOPT.EQ.2) THEN
49424 ALPHA=RMSS(18)
49425 RETURN
49426 ENDIF
49427 AT=RMSS(16)
49428 AB=RMSS(15)
49429 DMGL=RMSS(3)
49430 XMU=RMSS(4)
49431 TANB=RMSS(5)
49432
49433 DMA=RMSS(19)
49434 DTANB=TANB
49435 DMQ=RMSS(10)
49436 DMUR=RMSS(12)
49437 DMDR=RMSS(11)
49438 DMTOP=PMAS(6,1)
49439 DMC=PMAS(PYCOMP(KSUSY1+37),1)
49440 DAU=AT
49441 DAD=AB
49442 DMU=XMU
49443 RMSS(40)=0D0
49444 RMSS(41)=0D0
49445
49446 IF(IHOPT.EQ.0) THEN
49447 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
49448 & DMHCH,DSA,DCA,DTANBA)
49449 ELSEIF(IHOPT.EQ.1) THEN
49450 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
49451 & DMHCH,DSA,DCA,DTANBA)
49452 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
49453 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
49454 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
49455 RMSS(40)=DDT
49456 RMSS(41)=DDB
49457 DMH=DMHP
49458 DHM=DHMP
49459 DMA=DAMP
49460 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
49461 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
49462 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
49463 & PMAS(PYCOMP(1000006),1),DSTOP2
49464 ENDIF
49465 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
49466 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
49467 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
49468 & PMAS(PYCOMP(2000006),1),DSTOP1
49469 ENDIF
49470 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
49471 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
49472 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
49473 & PMAS(PYCOMP(1000005),1),DSBOT2
49474 ENDIF
49475 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
49476 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
49477 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
49478 & PMAS(PYCOMP(2000005),1),DSBOT1
49479 ENDIF
49480
49481 ELSEIF (IHOPT.EQ.3) THEN
49482c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
49483C...Currently only available for SLHA spectrum read-in.
49484 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
49485 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
49486 & //' spectrum, change IMSS(1) or IMSS(4) option.')
49487 ENDIF
49488 ALPHA=RMSS(18)
49489 RETURN
49490 ENDIF
49491
49492 ALPHA=ACOS(DCA)
49493
49494 PMAS(25,1)=DMH
49495 PMAS(35,1)=DHM
49496 PMAS(36,1)=DMA
49497 PMAS(37,1)=DMHCH
49498
49499 RETURN
49500 END
49501
49502C*********************************************************************
49503
49504C...PYSUBH
49505C...This routine computes the renormalization group improved
49506C...values of Higgs masses and couplings in the MSSM.
49507
49508C...Program based on the work by M. Carena, J.R. Espinosa,
49509c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
49510
49511C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
49512C...All masses in GeV units. MA is the CP-odd Higgs mass,
49513C...MTOP is the physical top mass, MQ and MUR are the soft
49514C...supersymmetry breaking mass parameters of left handed
49515C...and right handed stops respectively, AU and AD are the
49516C...stop and sbottom trilinear soft breaking terms,
49517C...respectively, and MU is the supersymmetric
49518C...Higgs mass parameter. We use the conventions from
49519C...the physics report of Haber and Kane: left right
49520C...stop mixing term proportional to (AU - MU/TANB)
49521C...We use as input TANB defined at the scale MTOP
49522
49523C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
49524C...where MH and HM are the lightest and heaviest CP-even
49525C...Higgs masses, MHCH is the charged Higgs mass and
49526C...ALPHA is the Higgs mixing angle
49527C...TANBA is the angle TANB at the CP-odd Higgs mass scale
49528
49529C...Range of validity:
49530C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
49531C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
49532C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
49533C...are the sbottom mass eigenvalues, respectively. This
49534C...range automatically excludes the existence of tachyons.
49535C...For the charged Higgs mass computation, the method is
49536C...valid if
49537C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
49538C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
49539C...where M_SUSY**2 is the average of the squared stop mass
49540C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
49541C...masses have been assumed to be of order of the stop ones
49542C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
49543
49544 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
49545 &XMHCH,SA,CA,TANBA)
49546
49547C...Double precision and integer declarations.
49548 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49549 IMPLICIT INTEGER(I-N)
49550 INTEGER PYK,PYCHGE,PYCOMP
49551C...Parameter statement to help give large particle numbers.
49552 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49553 &KEXCIT=4000000,KDIMEN=5000000)
49554C...Commonblocks.
49555 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49556 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49557 COMMON/PYHTRI/HHH(7)
49558 SAVE /PYDAT1/,/PYDAT2/
49559
49560C...Local variables.
49561 DOUBLE PRECISION PYALEM,PYALPS
49562 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
49563 DOUBLE PRECISION XMHCH,SA,CA
49564 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
49565 DOUBLE PRECISION Q02
49566 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
49567 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
49568 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
49569 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
49570 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
49571 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
49572 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
49573 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
49574
49575 XMZ = PMAS(23,1)
49576 Q02=XMZ**2
49577 AEM=PYALEM(Q02)
49578 ALP1=AEM/(1D0-PARU(102))
49579 ALP2=AEM/PARU(102)
49580 ALPH3Z=PYALPS(Q02)
49581
49582 ALP1 = 0.0101D0
49583 ALP2 = 0.0337D0
49584 ALPH3Z = 0.12D0
49585
49586 V = 174.1D0
49587 PI = PARU(1)
49588 TANBA = TANB
49589 TANBT = TANB
49590
49591C...MBOTTOM(MTOP) = 3. GEV
49592 XMB = PYMRUN(5,XMTOP**2)
49593 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
49594 &LOG(XMTOP**2/XMZ**2))
49595
49596C...RMTOP= RUNNING TOP QUARK MASS
49597 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
49598 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
49599 T = LOG(XMS**2/XMTOP**2)
49600 SINB = TANB/((1D0 + TANB**2)**0.5D0)
49601 COSB = SINB/TANB
49602C...IF(MA.LE.XMTOP) TANBA = TANBT
49603 IF(XMA.GT.XMTOP)
49604 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
49605 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
49606 &LOG(XMA**2/XMTOP**2))
49607
49608 SINBT = TANBT/SQRT(1D0 + TANBT**2)
49609 COSBT = 1D0/SQRT(1D0 + TANBT**2)
49610C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
49611 G1 = SQRT(ALP1*4D0*PI)
49612 G2 = SQRT(ALP2*4D0*PI)
49613 G3 = SQRT(ALP3*4D0*PI)
49614 HU = RMTOP/V/SINBT
49615 HD = XMB/V/COSBT
49616 HU2=HU*HU
49617 HD2=HD*HD
49618 HU4=HU2*HU2
49619 HD4=HD2*HD2
49620 AU2=AU**2
49621 AD2=AD**2
49622 XMS2=XMS**2
49623 XMS3=XMS**3
49624 XMS4=XMS2*XMS2
49625 XMU2=XMU*XMU
49626 PI2=PI*PI
49627
49628 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
49629 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
49630 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
49631 &+ 3D0*(AU + AD)**2/XMS2)/6D0
49632 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
49633 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
49634 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
49635 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
49636 &- 16D0*G3**2) *T/16D0/PI2)
49637 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
49638 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
49639 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
49640 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
49641 &- 16D0*G3**2) *T/16D0/PI2)
49642 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
49643 &(HU2 + HD2)*T/16D0/PI2)
49644 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
49645 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
49646 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
49647 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
49648 &- 16D0*G3**2) *T/16D0/PI2)
49649 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
49650 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
49651 &- 16D0*G3**2) *T/16D0/PI2)
49652 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(HU2 + HD2)*T/16D0/PI2)
49653 &-(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
49654 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
49655 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
49656 &XMS4)*
49657 &(1+ (6D0*HU2 -2D0* HD2
49658 &- 16D0*G3**2) *T/16D0/PI2)
49659 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
49660 &XMS4)*
49661 &(1+ (6D0*HD2 -2D0* HU2/2D0
49662 &- 16D0*G3**2) *T/16D0/PI2)
49663 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
49664 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
49665 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
49666 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
49667 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
49668 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49669 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
49670 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49671 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
49672 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49673 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
49674 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49675 HHH(1)=XLAM1
49676 HHH(2)=XLAM2
49677 HHH(3)=XLAM3
49678 HHH(4)=XLAM4
49679 HHH(5)=XLAM5
49680 HHH(6)=XLAM6
49681 HHH(7)=XLAM7
49682 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
49683 &2D0* XLAM6*SINBT*COSBT
49684 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
49685 &+ XLAM5*COSBT**2)
49686 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
49687 &XLAM6*COSBT**2
49688 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
49689 &2D0* XLAM6* COSBT*SINBT
49690 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
49691 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
49692 &((XLAM1* COSBT**2 +2D0*
49693 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
49694 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
49695 &*SINBT**2
49696 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
49697 &+ XLAM4) + XLAM6*COSBT**2
49698 &+ XLAM7* SINBT**2))
49699
49700 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
49701 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
49702 XHM = SQRT(XHM2)
49703 XMH = SQRT(XMH2)
49704 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
49705 XMHCH = SQRT(XMHCH2)
49706
49707 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
49708 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
49709 &XLAM6* COSBT*SINBT
49710 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
49711 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
49712 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
49713 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
49714
49715 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
49716 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
49717 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
49718 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
49719 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
49720 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
49721 &XLAM6* COSBT*SINBT
49722 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
49723 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
49724 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
49725
49726 SA = -SINALP
49727 CA = -COSALP
49728
49729 100 CONTINUE
49730
49731 RETURN
49732 END
49733
49734C*********************************************************************
49735
49736C...PYPOLE
49737C...This subroutine computes the CP-even higgs and CP-odd pole
49738c...Higgs masses and mixing angles.
49739
49740C...Program based on the work by M. Carena, M. Quiros
49741C...and C.E.M. Wagner, "Effective potential methods and
49742C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
49743
49744C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
49745C...AT,AB,MU
49746C...where MCHI is the largest chargino mass, MA is the running
49747C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
49748C...expectaion values at the scale MTOP, MQ is the third generation
49749C...left handed squark mass parameter, MUR is the third generation
49750C...right handed stop mass parameter, MDR is the third generation
49751C...right handed sbottom mass parameter, MTOP is the pole top quark
49752C...mass; AT,AB are the soft supersymmetry breaking trilinear
49753C...couplings of the stop and sbottoms, respectively, and MU is the
49754C...supersymmetric mass parameter
49755
49756C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
49757C...Higgses whose pole mass is computed. If IHIGGS=0 only running
49758C...masses are given, what makes the running of the program
49759c...much faster and it is quite generally a good approximation
49760c...(for a theoretical discussion see ref. above). If IHIGGS=1,
49761C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
49762c...and if IHIGGS=3, then h,H,A polarizations are computed
49763
49764C...Output: MH and MHP which are the lightest CP-even Higgs running
49765C...and pole masses, respectively; HM and HMP are the heaviest CP-even
49766C...Higgs running and pole masses, repectively; SA and CA are the
49767C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
49768C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
49769C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
49770C...the value of TANB at the CP-odd Higgs mass scale
49771
49772C...This subroutine makes use of CERN library subroutine
49773C...integration package, which makes the computation of the
49774C...pole Higgs masses somewhat faster. We thank P. Janot for this
49775C...improvement. Those who are not able to call the CERN
49776C...libraries, please use the subroutine SUBHPOLE2.F, which
49777C...although somewhat slower, gives identical results
49778
49779 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
49780 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
49781
49782C...Double precision and integer declarations.
49783 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49784 IMPLICIT INTEGER(I-N)
49785
49786C...Parameters.
49787 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49788 SAVE /PYDAT1/
49789 INTEGER PYK,PYCHGE,PYCOMP
49790
49791C...Local variables.
49792 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
49793 &SSBOT2(2),B(2,2),COUPB(2,2),
49794 &HCOUPT(2,2),HCOUPB(2,2),
49795 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
49796
49797 DELTA(1,1) = 1D0
49798 DELTA(2,2) = 1D0
49799 DELTA(1,2) = 0D0
49800 DELTA(2,1) = 0D0
49801 V = 174.1D0
49802 XMZ=91.18D0
49803 PI=PARU(1)
49804 RXMT=PYMRUN(6,XMT**2)
49805 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
49806 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
49807
49808 SINB = TANB/(TANB**2+1D0)**0.5D0
49809 COSB = 1D0/(TANB**2+1D0)**0.5D0
49810 COS2B = SINB**2 - COSB**2
49811 SINBPA = SINB*CA + COSB*SA
49812 COSBPA = COSB*CA - SINB*SA
49813 RMBOT = PYMRUN(5,XMT**2)
49814 XMQ2 = XMQ**2
49815 XMUR2 = XMUR**2
49816 IF(XMUR.LT.0D0) XMUR2=-XMUR2
49817 XMDR2 = XMDR**2
49818 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
49819 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
49820 IF(XMST11.LT.0D0) GOTO 500
49821 IF(XMST22.LT.0D0) GOTO 500
49822 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
49823 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
49824 IF(XMSB11.LT.0D0) GOTO 500
49825 IF(XMSB22.LT.0D0) GOTO 500
49826C WMST11 = RXMT**2 + XMQ2
49827C WMST22 = RXMT**2 + XMUR2
49828 XMST12 = RXMT*(AT - XMU/TANB)
49829 XMSB12 = RMBOT*(AB - XMU*TANB)
49830
49831CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49832C...STOP EIGENVALUES CALCULATION
49833CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49834
49835 STOP12 = 0.5D0*(XMST11+XMST22) +
49836 &0.5D0*((XMST11+XMST22)**2 -
49837 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
49838 STOP22 = 0.5D0*(XMST11+XMST22) -
49839 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
49840 &XMST12**2))**0.5D0
49841
49842 IF(STOP22.LT.0D0) GOTO 500
49843 SSTOP2(1) = STOP12
49844 SSTOP2(2) = STOP22
49845 STOP1 = STOP12**0.5D0
49846 STOP2 = STOP22**0.5D0
49847C STOP1W = STOP1
49848C STOP2W = STOP2
49849
49850 IF(XMST12.EQ.0D0) XST11 = 1D0
49851 IF(XMST12.EQ.0D0) XST12 = 0D0
49852 IF(XMST12.EQ.0D0) XST21 = 0D0
49853 IF(XMST12.EQ.0D0) XST22 = 1D0
49854
49855 IF(XMST12.EQ.0D0) GOTO 110
49856
49857 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49858 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49859 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49860 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49861
49862 110 T(1,1) = XST11
49863 T(2,2) = XST22
49864 T(1,2) = XST12
49865 T(2,1) = XST21
49866
49867 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
49868 &0.5D0*((XMSB11+XMSB22)**2 -
49869 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
49870 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
49871 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
49872 &XMSB12**2))**0.5D0
49873 IF(SBOT22.LT.0D0) GOTO 500
49874 SBOT1 = SBOT12**0.5D0
49875 SBOT2 = SBOT22**0.5D0
49876
49877 SSBOT2(1) = SBOT12
49878 SSBOT2(2) = SBOT22
49879
49880 IF(XMSB12.EQ.0D0) XSB11 = 1D0
49881 IF(XMSB12.EQ.0D0) XSB12 = 0D0
49882 IF(XMSB12.EQ.0D0) XSB21 = 0D0
49883 IF(XMSB12.EQ.0D0) XSB22 = 1D0
49884
49885 IF(XMSB12.EQ.0D0) GOTO 130
49886
49887 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49888 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49889 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49890 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49891
49892 130 B(1,1) = XSB11
49893 B(2,2) = XSB22
49894 B(1,2) = XSB12
49895 B(2,1) = XSB21
49896
49897
49898 SINT = 0.2320D0
49899 SQR = DSQRT(2D0)
49900 VP = 174.1D0*SQR
49901
49902CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49903C...STARTING OF LIGHT HIGGS
49904CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49905
49906 IF(IHIGGS.EQ.0) GOTO 490
49907
49908 DO 150 I = 1,2
49909 DO 140 J = 1,2
49910 COUPT(I,J) =
49911 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
49912 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49913 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
49914 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
49915 & T(1,J)*T(2,I))
49916 140 CONTINUE
49917 150 CONTINUE
49918
49919
49920 DO 170 I = 1,2
49921 DO 160 J = 1,2
49922 COUPB(I,J) =
49923 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
49924 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49925 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
49926 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
49927 & B(1,J)*B(2,I))
49928 160 CONTINUE
49929 170 CONTINUE
49930
49931 PRUN = XMH
49932 EPS = 1D-4*PRUN
49933 ITER = 0
49934 180 ITER = ITER + 1
49935 DO 230 I3 = 1,3
49936
49937 PR(I3)=PRUN+(I3-2)*EPS/2
49938 P2=PR(I3)**2
49939 POLT = 0D0
49940 DO 200 I = 1,2
49941 DO 190 J = 1,2
49942 POLT = POLT + COUPT(I,J)**2*3D0*
49943 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49944 190 CONTINUE
49945 200 CONTINUE
49946
49947 POLB = 0D0
49948 DO 220 I = 1,2
49949 DO 210 J = 1,2
49950 POLB = POLB + COUPB(I,J)**2*3D0*
49951 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49952 210 CONTINUE
49953 220 CONTINUE
49954C RXMT2 = RXMT**2
49955 XMT2=XMT**2
49956
49957 POLTT =
49958 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49959 & CA**2/SINB**2 *
49960 & (-2D0*XMT**2+0.5D0*P2)*
49961 & PYFINT(P2,XMT2,XMT2)
49962
49963 POL = POLT + POLB + POLTT
49964 POLAR(I3) = P2 - XMH**2 - POL
49965 230 CONTINUE
49966 DERIV = (POLAR(3)-POLAR(1))/EPS
49967 DRUN = - POLAR(2)/DERIV
49968 PRUN = PRUN + DRUN
49969 P2 = PRUN**2
49970 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
49971 GOTO 180
49972 240 CONTINUE
49973
49974 XMHP = DSQRT(P2)
49975
49976CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49977C...END OF LIGHT HIGGS
49978CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49979
49980 250 IF(IHIGGS.EQ.1) GOTO 490
49981
49982CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49983C... STARTING OF HEAVY HIGGS
49984CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49985
49986 DO 270 I = 1,2
49987 DO 260 J = 1,2
49988 HCOUPT(I,J) =
49989 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
49990 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49991 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
49992 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
49993 & T(1,J)*T(2,I))
49994 260 CONTINUE
49995 270 CONTINUE
49996
49997 DO 290 I = 1,2
49998 DO 280 J = 1,2
49999 HCOUPB(I,J) =
50000 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
50001 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
50002 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
50003 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
50004 & B(1,J)*B(2,I))
50005 HCOUPB(I,J)=0D0
50006 280 CONTINUE
50007 290 CONTINUE
50008
50009 PRUN = HM
50010 EPS = 1D-4*PRUN
50011 ITER = 0
50012 300 ITER = ITER + 1
50013 DO 350 I3 = 1,3
50014 PR(I3)=PRUN+(I3-2)*EPS/2
50015 HP2=PR(I3)**2
50016
50017 HPOLT = 0D0
50018 DO 320 I = 1,2
50019 DO 310 J = 1,2
50020 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
50021 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
50022 310 CONTINUE
50023 320 CONTINUE
50024
50025 HPOLB = 0D0
50026 DO 340 I = 1,2
50027 DO 330 J = 1,2
50028 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
50029 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
50030 330 CONTINUE
50031 340 CONTINUE
50032
50033C RXMT2 = RXMT**2
50034 XMT2 = XMT**2
50035
50036 HPOLTT =
50037 & 3D0*RXMT**2/8D0/PI**2/ V **2*
50038 & SA**2/SINB**2 *
50039 & (-2D0*XMT**2+0.5D0*HP2)*
50040 & PYFINT(HP2,XMT2,XMT2)
50041
50042 HPOL = HPOLT + HPOLB + HPOLTT
50043 POLAR(I3) =HP2-HM**2-HPOL
50044 350 CONTINUE
50045 DERIV = (POLAR(3)-POLAR(1))/EPS
50046 DRUN = - POLAR(2)/DERIV
50047 PRUN = PRUN + DRUN
50048 HP2 = PRUN**2
50049 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
50050 GOTO 300
50051 360 CONTINUE
50052
50053
50054 370 CONTINUE
50055 HMP = HP2**0.5D0
50056
50057CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50058C... END OF HEAVY HIGGS
50059CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50060
50061 IF(IHIGGS.EQ.2) GOTO 490
50062
50063CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50064C...BEGINNING OF PSEUDOSCALAR HIGGS
50065CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50066
50067 DO 390 I = 1,2
50068 DO 380 J = 1,2
50069 ACOUPT(I,J) =
50070 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
50071 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
50072 380 CONTINUE
50073 390 CONTINUE
50074 DO 410 I = 1,2
50075 DO 400 J = 1,2
50076 ACOUPB(I,J) =
50077 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
50078 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
50079 400 CONTINUE
50080 410 CONTINUE
50081
50082 PRUN = XMA
50083 EPS = 1D-4*PRUN
50084 ITER = 0
50085 420 ITER = ITER + 1
50086 DO 470 I3 = 1,3
50087 PR(I3)=PRUN+(I3-2)*EPS/2
50088 AP2=PR(I3)**2
50089 APOLT = 0D0
50090 DO 440 I = 1,2
50091 DO 430 J = 1,2
50092 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
50093 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
50094 430 CONTINUE
50095 440 CONTINUE
50096 APOLB = 0D0
50097 DO 460 I = 1,2
50098 DO 450 J = 1,2
50099 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
50100 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
50101 450 CONTINUE
50102 460 CONTINUE
50103C RXMT2 = RXMT**2
50104 XMT2=XMT**2
50105 APOLTT =
50106 & 3D0*RXMT**2/8D0/PI**2/ V **2*
50107 & COSB**2/SINB**2 *
50108 & (-0.5D0*AP2)*
50109 & PYFINT(AP2,XMT2,XMT2)
50110 APOL = APOLT + APOLB + APOLTT
50111 POLAR(I3) = AP2 - XMA**2 -APOL
50112 470 CONTINUE
50113 DERIV = (POLAR(3)-POLAR(1))/EPS
50114 DRUN = - POLAR(2)/DERIV
50115 PRUN = PRUN + DRUN
50116 AP2 = PRUN**2
50117 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
50118 GOTO 420
50119 480 CONTINUE
50120
50121 AMP = DSQRT(AP2)
50122
50123CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50124C...END OF PSEUDOSCALAR HIGGS
50125CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50126
50127 IF(IHIGGS.EQ.3) GOTO 490
50128
50129 490 CONTINUE
50130 RETURN
50131 500 CONTINUE
50132 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
50133 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
50134 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
50135 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
50136 CALL PYSTOP(107)
50137 END
50138
50139C*********************************************************************
50140
50141C...PYRGHM
50142C...Auxiliary to PYPOLE.
50143
50144 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
50145 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
50146 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
50147 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
50148C...Parameters.
50149 INTEGER MSTU,MSTJ
50150 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50151 SAVE /PYDAT1/
50152
50153 MZ = 91.18D0
50154 PI = PARU(1)
50155 V = 174.1D0
50156 ALPHA1 = 0.0101D0
50157 ALPHA2 = 0.0337D0
50158 ALPHA3Z = 0.12D0
50159 TANBA = TANB
50160 TANBT = TANB
50161C MBOTTOM(MTOP) = 3. GEV
50162 MB = PYMRUN(5,MTOP**2)
50163 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
50164 *LOG(MTOP**2/MZ**2))
50165C RMTOP= RUNNING TOP QUARK MASS
50166 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
50167 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
50168 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
50169 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
50170CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50171C
50172C NEW DEFINITION, TGLU.
50173C
50174CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50175 TGLU = LOG(MGLU**2/MTOP**2)
50176 SINB = TANB/DSQRT(1D0 + TANB**2)
50177 COSB = SINB/TANB
50178 IF(MA.GT.MTOP)
50179 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
50180 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
50181 *LOG(MA**2/MTOP**2))
50182 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
50183 SINB = TANBT/SQRT(1D0 + TANBT**2)
50184 COSB = 1D0/DSQRT(1D0 + TANBT**2)
50185 G1 = SQRT(ALPHA1*4D0*PI)
50186 G2 = SQRT(ALPHA2*4D0*PI)
50187 G3 = SQRT(ALPHA3*4D0*PI)
50188 HU = RMTOP/V/SINB
50189 HD = MB/V/COSB
50190 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
50191 *SBOT1,SBOT2,DELTAMT,DELTAMB)
50192 IF(MQ.GT.MUR) TP = TQ - TU
50193 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
50194 IF(MQ.GT.MUR) TDP = TU
50195 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
50196 IF(MQ.GT.MD) TPD = TQ - TD
50197 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
50198 IF(MQ.GT.MD) TDPD = TD
50199 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
50200
50201 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
50202 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
50203 * HD**2*(G1**2/3D0+G2**2)*TPD
50204
50205 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
50206 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
50207 * HU**2*(-G1**2/3D0+G2**2)*TP
50208
50209CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50210C
50211C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
50212C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
50213C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
50214C TWO STOPS.
50215C
50216C
50217CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50218
50219 DLAMBDAP2 = 0D0
50220 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
50221 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
50222 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
50223 ENDIF
50224
50225 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
50226 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
50227 ENDIF
50228
50229 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
50230 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
50231 ENDIF
50232
50233 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
50234 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
50235 ENDIF
50236
50237 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
50238 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
50239 ENDIF
50240
50241 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
50242 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
50243 ENDIF
50244 ENDIF
50245 DLAMBDA3 = 0D0
50246 DLAMBDA4 = 0D0
50247 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
50248 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
50249 *(G2**2-G1**2/3D0)*TPD
50250 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
50251 *1D0/16D0/PI**2*G1**2*HU**2*TP
50252 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
50253 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
50254 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
50255 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
50256 *HD**2*TPD
50257 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
50258 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
50259 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
50260 *+ (3D0*HD**2/2D0 + HU**2/2D0
50261 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
50262 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
50263 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
50264 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
50265 *(TP + TDP)/8D0/PI**2)
50266 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
50267 *+ (3D0*HU**2/2D0 + HD**2/2D0
50268 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
50269 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
50270 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
50271 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
50272 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
50273 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
50274 LAMBDA4 = (- G2**2/2D0)*(1D0
50275 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
50276 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
50277
50278 LAMBDA5 = 0D0
50279 LAMBDA6 = 0D0
50280 LAMBDA7 = 0D0
50281
50282 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
50283 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
50284
50285 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
50286 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
50287 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
50288 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
50289
50290 M2(2,1) = M2(1,2)
50291CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50292CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
50293CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50294
50295 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
50296
50297 IF(MCHI.GT.MSSUSY) GOTO 100
50298 IF(MCHI.LT.MTOP) MCHI=MTOP
50299
50300 TCHAR=LOG(MSSUSY**2/MCHI**2)
50301
50302 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
50303 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
50304 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
50305
50306 DELTAM112=2D0*DELTAL12*V**2*COSB**2
50307 DELTAM222=2D0*DELTAL12*V**2*SINB**2
50308 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
50309
50310 M2(1,1)=M2(1,1)+DELTAM112
50311 M2(2,2)=M2(2,2)+DELTAM222
50312 M2(1,2)=M2(1,2)+DELTAM122
50313 M2(2,1)=M2(2,1)+DELTAM122
50314
50315 100 CONTINUE
50316
50317CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50318CCC END OF CHARGINOS/NEUTRALINOS
50319CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50320
50321 DO 120 I = 1,2
50322 DO 110 J = 1,2
50323 M2P(I,J) = M2(I,J) + VH(I,J)
50324 110 CONTINUE
50325 120 CONTINUE
50326 TRM2P = M2P(1,1) + M2P(2,2)
50327 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
50328 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
50329 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
50330 HMP = DSQRT(HM2P)
50331 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
50332 MCH=DSQRT(MCH2)
50333 IF(MH2P.LT.0.) GOTO 130
50334 MHP = SQRT(MH2P)
50335 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
50336 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
50337 IF(COS2ALPHA.GE.0.) THEN
50338 ALPHA = ASIN(SIN2ALPHA)/2D0
50339 ELSE
50340 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
50341 ENDIF
50342 SA = SIN(ALPHA)
50343 CA = COS(ALPHA)
50344CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50345C
50346C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
50347C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
50348C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
50349C
50350C
50351CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50352 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
50353 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
50354 130 CONTINUE
50355 RETURN
50356 END
50357
50358C*********************************************************************
50359
50360C...PYGFXX
50361C...Auxiliary to PYRGHM.
50362
50363 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
50364 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
50365 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
50366 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
50367C...Commonblocks.
50368 INTEGER MSTU,MSTJ,KCHG
50369 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50370 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50371 SAVE /PYDAT1/,/PYDAT2/
50372
50373 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
50374
50375 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
50376 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
50377
50378 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
50379 MQ2 = MQ**2
50380 MUR2 = MUR**2
50381 MD2 = MD**2
50382 TANBA = TANB
50383 SINBA = TANBA/DSQRT(TANBA**2+1D0)
50384 COSBA = SINBA/TANBA
50385
50386 SINB = TANB/DSQRT(TANB**2+1D0)
50387 COSB = SINB/TANB
50388
50389 PI = PARU(1)
50390 MZ = PMAS(23,1)
50391 MW = PMAS(24,1)
50392 SW = 1D0-MW**2/MZ**2
50393 V = 174.1D0
50394
50395 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
50396 G2 = DSQRT(0.0336D0*4D0*PI)
50397 G1 = DSQRT(0.0101D0*4D0*PI)
50398
50399 IF(MQ.GT.MUR) MST = MQ
50400 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
50401
50402 MSUSYT = DSQRT(MST**2 + MTOP**2)
50403
50404 IF(MQ.GT.MD) MSB = MQ
50405 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
50406
50407 MB = PYMRUN(5,MSB**2)
50408 MSUSYB = DSQRT(MSB**2 + MB**2)
50409 TT = LOG(MSUSYT**2/MTOP**2)
50410 TB = LOG(MSUSYB**2/MTOP**2)
50411
50412 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
50413 HT = RMTOP/(V*SINB)
50414 HTST = RMTOP/V
50415 HB = MB/V/COSB
50416 G32 = ALPHA3*4D0*PI
50417 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
50418 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
50419 AL2 = 3D0/8D0/PI**2*HT**2
50420C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
50421C ALST = 3./8./PI**2*HTST**2
50422 AL1 = 3D0/8D0/PI**2*HB**2
50423
50424 AL(1,1) = AL1
50425 AL(1,2) = (AL2+AL1)/2D0
50426 AL(2,1) = (AL2+AL1)/2D0
50427 AL(2,2) = AL2
50428
50429 IF(MA.GT.MTOP) THEN
50430 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
50431 * LOG(MTOP**2/MA**2))
50432 H1I = VI* COSBA
50433 H2I = VI*SINBA
50434 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
50435 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
50436 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
50437 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
50438 ELSE
50439 VI = V
50440 H1I = VI*COSB
50441 H2I = VI*SINB
50442 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
50443 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
50444 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
50445 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
50446 ENDIF
50447
50448 TANBST = H2T/H1T
50449 SINBT = TANBST/DSQRT(1D0+TANBST**2)
50450
50451 TANBSB = H2B/H1B
50452 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
50453 COSBB = SINBB/TANBSB
50454
50455 DELTAMT = 0D0
50456 DELTAMB = 0D0
50457
50458 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
50459 MTOP2 = DSQRT(MTOP4)
50460 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
50461 * /(1D0+DELTAMB)**4
50462 MBOT2 = DSQRT(MBOT4)
50463
50464 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
50465 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50466 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50467 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
50468 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
50469 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50470 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50471 * MQ2 - MUR2)**2*0.25D0
50472 * + MTOP2*(AT-XMU/TANBST)**2)
50473 IF(STOP22.LT.0.) GOTO 120
50474 SBOT12 = (MQ2 + MD2)*.5D0
50475 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50476 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50477 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50478 SBOT22 = (MQ2 + MD2)*.5D0
50479 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50480 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50481 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50482 IF(SBOT22.LT.0.) SBOT22 = 10000D0
50483
50484 STOP1 = DSQRT(STOP12)
50485 STOP2 = DSQRT(STOP22)
50486 SBOT1 = DSQRT(SBOT12)
50487 SBOT2 = DSQRT(SBOT22)
50488
50489CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50490C
50491C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
50492C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
50493C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
50494C INDUCED CORRECTIONS.
50495C
50496CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50497
50498 X=SBOT1
50499 Y=SBOT2
50500 Z=XMGL
50501 IF(X.EQ.Y) X = X - 0.00001D0
50502 IF(X.EQ.Z) X = X - 0.00002D0
50503 IF(Y.EQ.Z) Y = Y - 0.00003D0
50504
50505 T1=T(X,Y,Z)
50506 X=STOP1
50507 Y=STOP2
50508 Z=XMU
50509 IF(X.EQ.Y) X = X - 0.00001D0
50510 IF(X.EQ.Z) X = X - 0.00002D0
50511 IF(Y.EQ.Z) Y = Y - 0.00003D0
50512 T2=T(X,Y,Z)
50513 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
50514 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
50515 X=STOP1
50516 Y=STOP2
50517 Z=XMGL
50518 IF(X.EQ.Y) X = X - 0.00001D0
50519 IF(X.EQ.Z) X = X - 0.00002D0
50520 IF(Y.EQ.Z) Y = Y - 0.00003D0
50521 T3=T(X,Y,Z)
50522 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
50523
50524CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50525C
50526C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
50527C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
50528C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
50529C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
50530C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
50531C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
50532C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
50533C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
50534C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
50535C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
50536C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
50537C
50538C
50539CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50540
50541 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
50542 MTOP2 = DSQRT(MTOP4)
50543 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
50544 * /(1D0+DELTAMB)**4
50545 MBOT2 = DSQRT(MBOT4)
50546
50547 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
50548 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50549 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50550 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
50551 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
50552 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50553 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50554 * MQ2 - MUR2)**2*0.25D0
50555 * + MTOP2*(AT-XMU/TANBST)**2)
50556
50557 IF(STOP22.LT.0.) GOTO 120
50558 SBOT12 = (MQ2 + MD2)*.5D0
50559 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50560 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50561 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50562 SBOT22 = (MQ2 + MD2)*.5D0
50563 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50564 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50565 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50566 IF(SBOT22.LT.0.) GOTO 120
50567
50568
50569 STOP1 = DSQRT(STOP12)
50570 STOP2 = DSQRT(STOP22)
50571 SBOT1 = DSQRT(SBOT12)
50572 SBOT2 = DSQRT(SBOT22)
50573
50574CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50575CCC D-TERMS
50576CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50577 STW=SW
50578
50579 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
50580 * LOG(STOP1/STOP2)
50581 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
50582 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
50583
50584 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
50585 * LOG(SBOT1/SBOT2)
50586 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
50587 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
50588
50589 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
50590 * (-.5D0*LOG(STOP12/STOP22)
50591 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
50592 * G(STOP12,STOP22))
50593
50594 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
50595 * (.5D0*LOG(SBOT12/SBOT22)
50596 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
50597 * G(SBOT12,SBOT22))
50598
50599 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
50600 * (MQ2+MBOT2)/(MD2+MBOT2))
50601 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
50602 * LOG(SBOT1**2/SBOT2**2)) +
50603 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
50604 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
50605
50606 VH3T(1,1) =
50607 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
50608 * -STOP2**2))**2*G(STOP12,STOP22)
50609
50610 VH3B(1,1)=VH3B(1,1)+
50611 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
50612
50613 VH3T(1,1) = VH3T(1,1) +
50614 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
50615
50616 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
50617 * (MQ2+MTOP2)/(MUR2+MTOP2))
50618 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
50619 * LOG(STOP1**2/STOP2**2)) +
50620 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
50621 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
50622
50623 VH3B(2,2) =
50624 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
50625 * -SBOT2**2))**2*G(SBOT12,SBOT22)
50626
50627 VH3T(2,2)=VH3T(2,2)+
50628 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
50629 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
50630 VH3T(1,2) = -
50631 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
50632 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
50633 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
50634
50635 VH3B(1,2) =
50636 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
50637 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
50638 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
50639
50640
50641 VH3T(1,2)=VH3T(1,2) +
50642 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
50643
50644 VH3B(1,2)=VH3B(1,2) +
50645 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
50646
50647 VH3T(2,1) = VH3T(1,2)
50648 VH3B(2,1) = VH3B(1,2)
50649
50650C TQ = LOG((MQ2 + MTOP2)/MTOP2)
50651C TU = LOG((MUR2+MTOP2)/MTOP2)
50652C TQD = LOG((MQ2 + MB**2)/MB**2)
50653C TD = LOG((MD2+MB**2)/MB**2)
50654
50655 DO 110 I = 1,2
50656 DO 100 J = 1,2
50657 VH(I,J) =
50658 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
50659 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
50660 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
50661 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
50662 100 CONTINUE
50663 110 CONTINUE
50664
50665 GOTO 150
50666 120 DO 140 I =1,2
50667 DO 130 J = 1,2
50668 VH(I,J) = -1D15
50669 130 CONTINUE
50670 140 CONTINUE
50671
50672
50673 150 RETURN
50674 END
50675
50676
50677
50678
50679
50680C*********************************************************************
50681
50682C...PYFINT
50683C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
50684
50685 FUNCTION PYFINT(A,B,C)
50686
50687C...Double precision and integer declarations.
50688 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50689 IMPLICIT INTEGER(I-N)
50690 INTEGER PYK,PYCHGE,PYCOMP
50691C...Commonblock.
50692 COMMON/PYINTS/XXM(20)
50693 SAVE/PYINTS/
50694
50695C...Local variables.
50696 EXTERNAL PYFISB
50697 DOUBLE PRECISION PYFISB
50698
50699 XXM(1)=A
50700 XXM(2)=B
50701 XXM(3)=C
50702 XLO=0D0
50703 XHI=1D0
50704 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
50705
50706 RETURN
50707 END
50708
50709C*********************************************************************
50710
50711C...PYFISB
50712C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
50713
50714 FUNCTION PYFISB(X)
50715
50716C...Double precision and integer declarations.
50717 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50718 IMPLICIT INTEGER(I-N)
50719 INTEGER PYK,PYCHGE,PYCOMP
50720C...Commonblock.
50721 COMMON/PYINTS/XXM(20)
50722 SAVE/PYINTS/
50723
50724 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
50725 &(X*(XXM(2)-XXM(3))+XXM(3)))
50726
50727 RETURN
50728 END
50729
50730C*********************************************************************
50731
50732C...PYSFDC
50733C...Calculates decays of sfermions.
50734
50735 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
50736
50737C...Double precision and integer declarations.
50738 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50739 IMPLICIT INTEGER(I-N)
50740 INTEGER PYK,PYCHGE,PYCOMP
50741C...Parameter statement to help give large particle numbers.
50742 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50743 &KEXCIT=4000000,KDIMEN=5000000)
50744C...Commonblocks.
50745 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50746 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50747 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50748 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50749 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50750 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50751
50752C...Local variables.
50753 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
50754 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
50755 INTEGER KFIN,KCIN
50756 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
50757 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
50758 DOUBLE PRECISION PYLAMF,XL
50759 DOUBLE PRECISION TANW,XW,AEM,C1,AS
50760 DOUBLE PRECISION AL,AR,BL,BR
50761 DOUBLE PRECISION CH1,CH2,CH3,CH4
50762 DOUBLE PRECISION XMBOT,XMTOP
50763 DOUBLE PRECISION XLAM(0:400)
50764 INTEGER IDLAM(400,3)
50765 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
50766 DOUBLE PRECISION SR2
50767 DOUBLE PRECISION CBETA,SBETA
50768 DOUBLE PRECISION CW
50769 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
50770 DOUBLE PRECISION COSA,SINA,TANB
50771 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
50772 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
50773 INTEGER IG,KF1,KF2
50774 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
50775 DATA IGG/23,25,35,36/
50776 DATA PI/3.141592654D0/
50777 DATA SR2/1.4142136D0/
50778 DATA KFNCHI/1000022,1000023,1000025,1000035/
50779 DATA KFCCHI/1000024,1000037/
50780
50781C...COUNT THE NUMBER OF DECAY MODES
50782 LKNT=0
50783
50784C...NO NU_R DECAYS
50785 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
50786 &KFIN.EQ.KSUSY2+16) RETURN
50787
50788 XMW=PMAS(24,1)
50789 XMW2=XMW**2
50790 XMZ=PMAS(23,1)
50791 XW=PARU(102)
50792 TANW = SQRT(XW/(1D0-XW))
50793 CW=SQRT(1D0-XW)
50794
50795 DO 110 I=1,4
50796 DO 100 J=1,4
50797 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
50798 100 CONTINUE
50799 110 CONTINUE
50800 DO 130 I=1,2
50801 DO 120 J=1,2
50802 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
50803 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
50804 120 CONTINUE
50805 130 CONTINUE
50806
50807C...KCIN
50808 KCIN=PYCOMP(KFIN)
50809C...ILR is 1 for left and 2 for right.
50810 ILR=KFIN/KSUSY1
50811C...IFL is matching non-SUSY flavour.
50812 IFL=MOD(KFIN,KSUSY1)
50813C...IDU is weak isospin, 1 for down and 2 for up.
50814 IDU=2-MOD(IFL,2)
50815
50816 XMI=PMAS(KCIN,1)
50817 XMI2=XMI**2
50818 AEM=PYALEM(XMI2)
50819 AS =PYALPS(XMI2)
50820 C1=AEM/XW
50821 XMI3=XMI**3
50822 EI=KCHG(IFL,1)/3D0
50823
50824 XMBOT=PYMRUN(5,XMI2)
50825 XMTOP=PYMRUN(6,XMI2)
50826
50827 TANB=RMSS(5)
50828 BETA=ATAN(TANB)
50829 ALFA=RMSS(18)
50830 CBETA=COS(BETA)
50831 SBETA=TANB*CBETA
50832 SINA=SIN(ALFA)
50833 COSA=COS(ALFA)
50834 XMU=-RMSS(4)
50835 ATRIT=RMSS(16)
50836 ATRIB=RMSS(15)
50837 ATRIL=RMSS(17)
50838
50839C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
50840
50841 IF(IMSS(11).EQ.1) THEN
50842 XMP=RMSS(29)
50843 IDG=39+KSUSY1
50844 XMGR=PMAS(PYCOMP(IDG),1)
50845 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
50846 IF(IFL.EQ.5) THEN
50847 XMF=XMBOT
50848 ELSEIF(IFL.EQ.6) THEN
50849 XMF=XMTOP
50850 ELSE
50851 XMF=PMAS(IFL,1)
50852 ENDIF
50853 IF(XMI.GT.XMGR+XMF) THEN
50854 LKNT=LKNT+1
50855 IDLAM(LKNT,1)=IDG
50856 IDLAM(LKNT,2)=IFL
50857 IDLAM(LKNT,3)=0
50858 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
50859 ENDIF
50860 ENDIF
50861
50862C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
50863
50864C...CHARGED DECAYS:
50865 DO 140 IX=1,2
50866C...DI -> U CHI1-,CHI2-
50867 IF(IDU.EQ.1) THEN
50868 XMFP=PMAS(IFL+1,1)
50869 XMF =PMAS(IFL,1)
50870C...UI -> D CHI1+,CHI2+
50871 ELSE
50872 XMFP=PMAS(IFL-1,1)
50873 XMF =PMAS(IFL,1)
50874 ENDIF
50875 XMJ=SMW(IX)
50876 AXMJ=ABS(XMJ)
50877 IF(XMI.GE.AXMJ+XMFP) THEN
50878 XMA2=XMJ**2
50879 XMB2=XMFP**2
50880 IF(IDU.EQ.2) THEN
50881 IF(IFL.EQ.6) THEN
50882 XMFP=XMBOT
50883 XMF =XMTOP
50884 ELSEIF(IFL.LT.6) THEN
50885 XMF=0D0
50886 XMFP=0D0
50887 ENDIF
50888 CBL=VMIXC(IX,1)
50889 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
50890 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
50891 CAR=0D0
50892 ELSE
50893 IF(IFL.EQ.5) THEN
50894 XMF =XMBOT
50895 XMFP=XMTOP
50896 ELSEIF(IFL.LT.5) THEN
50897 XMF=0D0
50898 XMFP=0D0
50899 ENDIF
50900 CBL=UMIXC(IX,1)
50901 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
50902 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
50903 CAR=0D0
50904 ENDIF
50905
50906 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50907 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50908 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50909 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50910 CAL=CALP
50911 CBL=CBLP
50912 CAR=CARP
50913 CBR=CBRP
50914
50915C...F1 -> F` CHI
50916 IF(ILR.EQ.1) THEN
50917 CA=CAL
50918 CB=CBL
50919C...F2 -> F` CHI
50920 ELSE
50921 CA=CAR
50922 CB=CBR
50923 ENDIF
50924 LKNT=LKNT+1
50925 XL=PYLAMF(XMI2,XMA2,XMB2)
50926C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50927 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50928 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
50929 IDLAM(LKNT,3)=0
50930 IF(IDU.EQ.1) THEN
50931 IDLAM(LKNT,1)=-KFCCHI(IX)
50932 IDLAM(LKNT,2)=IFL+1
50933 ELSE
50934 IDLAM(LKNT,1)=KFCCHI(IX)
50935 IDLAM(LKNT,2)=IFL-1
50936 ENDIF
50937 ENDIF
50938 140 CONTINUE
50939
50940C...NEUTRAL DECAYS
50941 DO 150 IX=1,4
50942C...DI -> D CHI10
50943 XMF=PMAS(IFL,1)
50944 XMJ=SMZ(IX)
50945 AXMJ=ABS(XMJ)
50946 IF(XMI.GE.AXMJ+XMF) THEN
50947 XMA2=XMJ**2
50948 XMB2=XMF**2
50949 IF(IDU.EQ.1) THEN
50950 IF(IFL.EQ.5) THEN
50951 XMF=XMBOT
50952 ELSEIF(IFL.LT.5) THEN
50953 XMF=0D0
50954 ENDIF
50955 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
50956 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
50957 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50958 CBR=CAL
50959 ELSE
50960 IF(IFL.EQ.6) THEN
50961 XMF=XMTOP
50962 ELSEIF(IFL.LT.5) THEN
50963 XMF=0D0
50964 ENDIF
50965 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
50966 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
50967 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50968 CBR=CAL
50969 ENDIF
50970
50971 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50972 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50973 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50974 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50975 CAL=CALP
50976 CBL=CBLP
50977 CAR=CARP
50978 CBR=CBRP
50979
50980C...F1 -> F CHI
50981 IF(ILR.EQ.1) THEN
50982 CA=CAL
50983 CB=CBL
50984C...F2 -> F CHI
50985 ELSE
50986 CA=CAR
50987 CB=CBR
50988 ENDIF
50989 LKNT=LKNT+1
50990 XL=PYLAMF(XMI2,XMA2,XMB2)
50991C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50992 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50993 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
50994 IDLAM(LKNT,1)=KFNCHI(IX)
50995 IDLAM(LKNT,2)=IFL
50996 IDLAM(LKNT,3)=0
50997 ENDIF
50998 150 CONTINUE
50999
51000C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
51001C...IG=23,25,35,36
51002 DO 160 II=1,4
51003 IG=IGG(II)
51004 IF(ILR.EQ.1) GOTO 160
51005 XMB=PMAS(IG,1)
51006 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
51007 IF(XMI.LT.XMSF1+XMB) GOTO 160
51008 IF(IG.EQ.23) THEN
51009 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
51010 BR=EI*XW/CW
51011 BLR=0D0
51012 ELSEIF(IG.EQ.25) THEN
51013 IF(IFL.EQ.5) THEN
51014 XMF=XMBOT
51015 ELSEIF(IFL.EQ.6) THEN
51016 XMF=XMTOP
51017 ELSEIF(IFL.LT.5) THEN
51018 XMF=0D0
51019 ELSE
51020 XMF=PMAS(IFL,1)
51021 ENDIF
51022 IF(IDU.EQ.2) THEN
51023 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
51024 & XMF**2/XMW*COSA/SBETA
51025 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
51026 & XMF**2/XMW*COSA/SBETA
51027 ELSE
51028 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
51029 & XMF**2/XMW*(-SINA)/CBETA
51030 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
51031 & XMF**2/XMW*(-SINA)/CBETA
51032 ENDIF
51033 IF(IFL.EQ.5) THEN
51034 AT=ATRIB
51035 ELSEIF(IFL.EQ.6) THEN
51036 AT=ATRIT
51037 ELSEIF(IFL.EQ.15) THEN
51038 AT=ATRIL
51039 ELSE
51040 AT=0D0
51041 ENDIF
51042C.........need to complexify
51043 IF(IDU.EQ.2) THEN
51044 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
51045 & AT*COSA)
51046 ELSE
51047 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
51048 & AT*SINA)
51049 ENDIF
51050 BL=GHLL
51051 BR=GHRR
51052 BLR=-GHLR
51053 ELSEIF(IG.EQ.35) THEN
51054 IF(IFL.EQ.5) THEN
51055 XMF=XMBOT
51056 ELSEIF(IFL.EQ.6) THEN
51057 XMF=XMTOP
51058 ELSEIF(IFL.LT.5) THEN
51059 XMF=0D0
51060 ELSE
51061 XMF=PMAS(IFL,1)
51062 ENDIF
51063 IF(IDU.EQ.2) THEN
51064 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
51065 & XMF**2/XMW*SINA/SBETA
51066 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
51067 & XMF**2/XMW*SINA/SBETA
51068 ELSE
51069 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
51070 & XMF**2/XMW*COSA/CBETA
51071 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
51072 & XMF**2/XMW*COSA/CBETA
51073 ENDIF
51074 IF(IFL.EQ.5) THEN
51075 AT=ATRIB
51076 ELSEIF(IFL.EQ.6) THEN
51077 AT=ATRIT
51078 ELSEIF(IFL.EQ.15) THEN
51079 AT=ATRIL
51080 ELSE
51081 AT=0D0
51082 ENDIF
51083C.........Need to complexify
51084 IF(IDU.EQ.2) THEN
51085 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
51086 & AT*SINA)
51087 ELSE
51088 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
51089 & AT*COSA)
51090 ENDIF
51091 BL=GHLL
51092 BR=GHRR
51093 BLR=GHLR
51094 ELSEIF(IG.EQ.36) THEN
51095 GHLL=0D0
51096 GHRR=0D0
51097 IF(IFL.EQ.5) THEN
51098 XMF=XMBOT
51099 ELSEIF(IFL.EQ.6) THEN
51100 XMF=XMTOP
51101 ELSEIF(IFL.LT.5) THEN
51102 XMF=0D0
51103 ELSE
51104 XMF=PMAS(IFL,1)
51105 ENDIF
51106 IF(IFL.EQ.5) THEN
51107 AT=ATRIB
51108 ELSEIF(IFL.EQ.6) THEN
51109 AT=ATRIT
51110 ELSEIF(IFL.EQ.15) THEN
51111 AT=ATRIL
51112 ELSE
51113 AT=0D0
51114 ENDIF
51115C.........Need to complexify
51116 IF(IDU.EQ.2) THEN
51117 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
51118 ELSE
51119 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
51120 ENDIF
51121 BL=GHLL
51122 BR=GHRR
51123 BLR=GHLR
51124 ENDIF
51125 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
51126 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
51127 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
51128 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51129 LKNT=LKNT+1
51130 IF(IG.EQ.23) THEN
51131 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
51132 ELSE
51133 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
51134 ENDIF
51135 IDLAM(LKNT,3)=0
51136 IDLAM(LKNT,1)=KFIN-KSUSY1
51137 IDLAM(LKNT,2)=IG
51138 160 CONTINUE
51139
51140C...SF -> SF' + W
51141 XMB=PMAS(24,1)
51142 IF(MOD(IFL,2).EQ.0) THEN
51143 KF1=KSUSY1+IFL-1
51144 ELSE
51145 KF1=KSUSY1+IFL+1
51146 ENDIF
51147 KF2=KF1+KSUSY1
51148 XMSF1=PMAS(PYCOMP(KF1),1)
51149 XMSF2=PMAS(PYCOMP(KF2),1)
51150 IF(XMI.GT.XMB+XMSF1) THEN
51151 IF(MOD(IFL,2).EQ.0) THEN
51152 IF(ILR.EQ.1) THEN
51153 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
51154 ELSE
51155 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
51156 ENDIF
51157 ELSE
51158 IF(ILR.EQ.1) THEN
51159 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
51160 ELSE
51161 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
51162 ENDIF
51163 ENDIF
51164 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51165 LKNT=LKNT+1
51166 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
51167 IDLAM(LKNT,3)=0
51168 IDLAM(LKNT,1)=KF1
51169 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
51170 ENDIF
51171 IF(XMI.GT.XMB+XMSF2) THEN
51172 IF(MOD(IFL,2).EQ.0) THEN
51173 IF(ILR.EQ.1) THEN
51174 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
51175 ELSE
51176 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
51177 ENDIF
51178 ELSE
51179 IF(ILR.EQ.1) THEN
51180 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
51181 ELSE
51182 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
51183 ENDIF
51184 ENDIF
51185 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
51186 LKNT=LKNT+1
51187 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
51188 IDLAM(LKNT,3)=0
51189 IDLAM(LKNT,1)=KF2
51190 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
51191 ENDIF
51192
51193C...SF -> SF' + HC
51194 XMB=PMAS(37,1)
51195 IF(MOD(IFL,2).EQ.0) THEN
51196 KF1=KSUSY1+IFL-1
51197 ELSE
51198 KF1=KSUSY1+IFL+1
51199 ENDIF
51200 KF2=KF1+KSUSY1
51201 XMSF1=PMAS(PYCOMP(KF1),1)
51202 XMSF2=PMAS(PYCOMP(KF2),1)
51203 IF(XMI.GT.XMB+XMSF1) THEN
51204 XMF=0D0
51205 XMFP=0D0
51206 AT=0D0
51207 AB=0D0
51208 IF(MOD(IFL,2).EQ.0) THEN
51209C...T1-> B1 HC
51210 IF(ILR.EQ.1) THEN
51211 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
51212 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
51213 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
51214 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
51215C...T2-> B1 HC
51216 ELSE
51217 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
51218 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
51219 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
51220 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
51221 ENDIF
51222 IF(IFL.EQ.6) THEN
51223 XMF=XMTOP
51224 XMFP=XMBOT
51225 AT=ATRIT
51226 AB=ATRIB
51227 ENDIF
51228 ELSE
51229C...B1 -> T1 HC
51230 IF(ILR.EQ.1) THEN
51231 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
51232 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
51233 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
51234 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
51235C...B2-> T1 HC
51236 ELSE
51237 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
51238 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
51239 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
51240 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
51241 ENDIF
51242 IF(IFL.EQ.5) THEN
51243 XMF=XMTOP
51244 XMFP=XMBOT
51245 AT=ATRIT
51246 AB=ATRIB
51247 ENDIF
51248 ENDIF
51249 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51250 LKNT=LKNT+1
51251C.......Need to complexify
51252 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
51253 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
51254 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
51255 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
51256 IDLAM(LKNT,3)=0
51257 IDLAM(LKNT,1)=KF1
51258 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
51259 ENDIF
51260 IF(XMI.GT.XMB+XMSF2) THEN
51261 XMF=0D0
51262 XMFP=0D0
51263 AT=0D0
51264 AB=0D0
51265 IF(MOD(IFL,2).EQ.0) THEN
51266C...T1-> B2 HC
51267 IF(ILR.EQ.1) THEN
51268 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
51269 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
51270 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
51271 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
51272C...T2-> B2 HC
51273 ELSE
51274 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
51275 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
51276 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
51277 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
51278 ENDIF
51279 IF(IFL.EQ.6) THEN
51280 XMF=XMTOP
51281 XMFP=XMBOT
51282 AT=ATRIT
51283 AB=ATRIB
51284 ENDIF
51285 ELSE
51286C...B1 -> T2 HC
51287 IF(ILR.EQ.1) THEN
51288 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
51289 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
51290 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
51291 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
51292C...B2-> T2 HC
51293 ELSE
51294 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
51295 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
51296 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
51297 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
51298 ENDIF
51299 IF(IFL.EQ.5) THEN
51300 XMF=XMTOP
51301 XMFP=XMBOT
51302 AT=ATRIT
51303 AB=ATRIB
51304 ENDIF
51305 ENDIF
51306 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51307 LKNT=LKNT+1
51308C.......Need to complexify
51309 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
51310 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
51311 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
51312 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
51313 IDLAM(LKNT,3)=0
51314 IDLAM(LKNT,1)=KF2
51315 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
51316 ENDIF
51317
51318C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
51319
51320 IF(IFL.LE.6) THEN
51321 XMFP=0D0
51322 XMF=0D0
51323 IF(IFL.EQ.6) XMF=PMAS(6,1)
51324 IF(IFL.EQ.5) XMF=PMAS(5,1)
51325 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
51326 AXMJ=ABS(XMJ)
51327 IF(XMI.GE.AXMJ+XMF) THEN
51328 AL=-SFMIX(IFL,3)
51329 BL=SFMIX(IFL,1)
51330 AR=-SFMIX(IFL,4)
51331 BR=SFMIX(IFL,2)
51332C...F1 -> F CHI
51333 IF(ILR.EQ.1) THEN
51334 XCA=AL
51335 XCB=BL
51336C...F2 -> F CHI
51337 ELSE
51338 XCA=AR
51339 XCB=BR
51340 ENDIF
51341 LKNT=LKNT+1
51342 XMA2=XMJ**2
51343 XMB2=XMF**2
51344 XL=PYLAMF(XMI2,XMA2,XMB2)
51345 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
51346 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
51347 IDLAM(LKNT,1)=KSUSY1+21
51348 IDLAM(LKNT,2)=IFL
51349 IDLAM(LKNT,3)=0
51350 ENDIF
51351 ENDIF
51352
51353C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
51354 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
51355 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
51356C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
51357C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
51358C...M*M = C1**2 * G**2/(16PI**2)
51359C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
51360 LKNT=LKNT+1
51361 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
51362 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
51363 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
51364 IDLAM(LKNT,1)=KSUSY1+22
51365 IDLAM(LKNT,2)=4
51366 IDLAM(LKNT,3)=0
51367 ENDIF
51368
51369C...R-violating sfermion decays (SKANDS).
51370 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
51371
51372 IKNT=LKNT
51373 XLAM(0)=0D0
51374 DO 170 I=1,IKNT
51375 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
51376 XLAM(0)=XLAM(0)+XLAM(I)
51377 170 CONTINUE
51378 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
51379
51380 RETURN
51381 END
51382
51383C*********************************************************************
51384
51385C...PYGLUI
51386C...Calculates gluino decay modes.
51387
51388 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
51389
51390C...Double precision and integer declarations.
51391 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51392 IMPLICIT INTEGER(I-N)
51393 INTEGER PYK,PYCHGE,PYCOMP
51394C...Parameter statement to help give large particle numbers.
51395 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51396 &KEXCIT=4000000,KDIMEN=5000000)
51397C...Commonblocks.
51398 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51399 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51400 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51401 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51402 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51403CC &SFMIX(16,4),
51404C COMMON/PYINTS/XXM(20)
51405 COMPLEX*16 CXC
51406 COMMON/PYINTC/XXC(10),CXC(8)
51407 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51408
51409C...Local variables
51410 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
51411 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
51412 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
51413 DOUBLE PRECISION PYLAMF,XL
51414 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
51415 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
51416 DOUBLE PRECISION XLAM(0:400)
51417 INTEGER IDLAM(400,3)
51418 INTEGER LKNT,IX,ILR,I,IKNT,IFL
51419 DOUBLE PRECISION SR2
51420 DOUBLE PRECISION GAM
51421 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
51422 EXTERNAL PYGAUS,PYXXZ6
51423 DOUBLE PRECISION PYGAUS,PYXXZ6
51424 DOUBLE PRECISION PREC
51425 INTEGER KFNCHI(4),KFCCHI(2)
51426 DATA PI/3.141592654D0/
51427 DATA SR2/1.4142136D0/
51428 DATA PREC/1D-2/
51429 DATA KFNCHI/1000022,1000023,1000025,1000035/
51430 DATA KFCCHI/1000024,1000037/
51431
51432C...COUNT THE NUMBER OF DECAY MODES
51433 LKNT=0
51434 IF(KFIN.NE.KSUSY1+21) RETURN
51435 KCIN=PYCOMP(KFIN)
51436
51437 XW=PARU(102)
51438 TANW = SQRT(XW/(1D0-XW))
51439
51440 XMI=PMAS(KCIN,1)
51441 AXMI=ABS(XMI)
51442 XMI2=XMI**2
51443 AEM=PYALEM(XMI2)
51444 AS =PYALPS(XMI2)
51445 C1=AEM/XW
51446 XMI3=AXMI**3
51447
51448 XMI=SIGN(XMI,RMSS(3))
51449
51450C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
51451
51452 IF(IMSS(11).EQ.1) THEN
51453 XMP=RMSS(29)
51454 IDG=39+KSUSY1
51455 XMGR=PMAS(PYCOMP(IDG),1)
51456 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51457 IF(AXMI.GT.XMGR) THEN
51458 LKNT=LKNT+1
51459 IDLAM(LKNT,1)=IDG
51460 IDLAM(LKNT,2)=21
51461 IDLAM(LKNT,3)=0
51462 XLAM(LKNT)=XFAC
51463 ENDIF
51464 ENDIF
51465
51466C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
51467
51468 DO 110 IFL=1,6
51469 DO 100 ILR=1,2
51470 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
51471 AXMJ=ABS(XMJ)
51472 XMF=PMAS(IFL,1)
51473 IF(AXMI.GE.AXMJ+XMF) THEN
51474C...Minus sign difference from gluino-quark-squark feynman rules
51475 AL=SFMIX(IFL,1)
51476 BL=-SFMIX(IFL,3)
51477 AR=SFMIX(IFL,2)
51478 BR=-SFMIX(IFL,4)
51479C...F1 -> F CHI
51480 IF(ILR.EQ.1) THEN
51481 CA=AL
51482 CB=BL
51483C...F2 -> F CHI
51484 ELSE
51485 CA=AR
51486 CB=BR
51487 ENDIF
51488 LKNT=LKNT+1
51489 XMA2=XMJ**2
51490 XMB2=XMF**2
51491 XL=PYLAMF(XMI2,XMA2,XMB2)
51492 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
51493 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
51494 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
51495 IDLAM(LKNT,2)=-IFL
51496 IDLAM(LKNT,3)=0
51497 LKNT=LKNT+1
51498 XLAM(LKNT)=XLAM(LKNT-1)
51499 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51500 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51501 IDLAM(LKNT,3)=0
51502 ENDIF
51503 100 CONTINUE
51504 110 CONTINUE
51505
51506C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
51507C...GLUINO -> NI Q QBAR
51508 DO 170 IX=1,4
51509 XMJ=SMZ(IX)
51510 AXMJ=ABS(XMJ)
51511 IF(AXMI.GE.AXMJ) THEN
51512 DO 120 I=1,4
51513 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
51514 120 CONTINUE
51515 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
51516 ORPP=DCONJG(OLPP)
51517 XXC(1)=0D0
51518 XXC(2)=XMJ
51519 XXC(3)=0D0
51520 XXC(4)=XMI
51521 IA=1
51522 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
51523 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
51524 XXC(7)=XXC(5)
51525 XXC(8)=XXC(6)
51526 XXC(9)=1D6
51527 XXC(10)=0D0
51528 EI=KCHG(IA,1)/3D0
51529 T3I=SIGN(1D0,EI+1D-6)/2D0
51530 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51531 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51532 CXC(1)=0D0
51533 CXC(2)=-GLIJ
51534 CXC(3)=0D0
51535 CXC(4)=DCONJG(GLIJ)
51536 CXC(5)=0D0
51537 CXC(6)=GRIJ
51538 CXC(7)=0D0
51539 CXC(8)=-DCONJG(GRIJ)
51540 S12MIN=0D0
51541 S12MAX=(AXMI-AXMJ)**2
51542 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
51543 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51544 LKNT=LKNT+1
51545 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
51546 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
51547 IDLAM(LKNT,1)=KFNCHI(IX)
51548 IDLAM(LKNT,2)=1
51549 IDLAM(LKNT,3)=-1
51550 ENDIF
51551 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51552 LKNT=LKNT+1
51553 XLAM(LKNT)=XLAM(LKNT-1)
51554 IDLAM(LKNT,1)=KFNCHI(IX)
51555 IDLAM(LKNT,2)=3
51556 IDLAM(LKNT,3)=-3
51557 ENDIF
51558 130 CONTINUE
51559 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51560 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
51561 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
51562 GOTO 140
51563 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
51564 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
51565 ENDIF
51566 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
51567 LKNT=LKNT+1
51568 XLAM(LKNT)=GAM
51569 IDLAM(LKNT,1)=KFNCHI(IX)
51570 IDLAM(LKNT,2)=5
51571 IDLAM(LKNT,3)=-5
51572 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
51573 ENDIF
51574C...U-TYPE QUARKS
51575 140 CONTINUE
51576 IA=2
51577 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
51578 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
51579C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
51580 XXC(7)=XXC(5)
51581 XXC(8)=XXC(6)
51582 EI=KCHG(IA,1)/3D0
51583 T3I=SIGN(1D0,EI+1D-6)/2D0
51584 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51585 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51586 CXC(2)=-GLIJ
51587 CXC(4)=DCONJG(GLIJ)
51588 CXC(6)=GRIJ
51589 CXC(8)=-DCONJG(GRIJ)
51590 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
51591 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51592 LKNT=LKNT+1
51593 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
51594 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
51595 IDLAM(LKNT,1)=KFNCHI(IX)
51596 IDLAM(LKNT,2)=2
51597 IDLAM(LKNT,3)=-2
51598 ENDIF
51599 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51600 LKNT=LKNT+1
51601 XLAM(LKNT)=XLAM(LKNT-1)
51602 IDLAM(LKNT,1)=KFNCHI(IX)
51603 IDLAM(LKNT,2)=4
51604 IDLAM(LKNT,3)=-4
51605 ENDIF
51606 150 CONTINUE
51607C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
51608C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
51609 XMF=PMAS(6,1)
51610 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
51611 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
51612 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
51613 GOTO 160
51614 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
51615 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
51616 ENDIF
51617 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
51618 LKNT=LKNT+1
51619 XLAM(LKNT)=GAM
51620 IDLAM(LKNT,1)=KFNCHI(IX)
51621 IDLAM(LKNT,2)=6
51622 IDLAM(LKNT,3)=-6
51623 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
51624 ENDIF
51625 160 CONTINUE
51626 ENDIF
51627 170 CONTINUE
51628
51629C...GLUINO -> CI Q QBAR'
51630 DO 210 IX=1,2
51631 XMJ=SMW(IX)
51632 AXMJ=ABS(XMJ)
51633 IF(AXMI.GE.AXMJ) THEN
51634 DO 180 I=1,2
51635 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
51636 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
51637 180 CONTINUE
51638 S12MIN=0D0
51639 S12MAX=(AXMI-AXMJ)**2
51640 XXC(1)=0D0
51641 XXC(2)=XMJ
51642 XXC(3)=0D0
51643 XXC(4)=XMI
51644 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
51645 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
51646 XXC(9)=1D6
51647 XXC(10)=0D0
51648 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
51649 ORPP=DCONJG(OLPP)
51650 CXC(1)=DCMPLX(0D0,0D0)
51651 CXC(3)=DCMPLX(0D0,0D0)
51652 CXC(5)=DCMPLX(0D0,0D0)
51653 CXC(7)=DCMPLX(0D0,0D0)
51654 CXC(2)=UMIXC(IX,1)*OLPP/SR2
51655 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
51656 CXC(6)=DCMPLX(0D0,0D0)
51657 CXC(8)=DCMPLX(0D0,0D0)
51658 IF(XXC(5).LT.AXMI) THEN
51659 XXC(5)=1D6
51660 ELSEIF(XXC(6).LT.AXMI) THEN
51661 XXC(6)=1D6
51662 ENDIF
51663 XXC(7)=XXC(6)
51664 XXC(8)=XXC(5)
51665 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
51666 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
51667 LKNT=LKNT+1
51668 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
51669 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51670 IDLAM(LKNT,1)=KFCCHI(IX)
51671 IDLAM(LKNT,2)=1
51672 IDLAM(LKNT,3)=-2
51673 LKNT=LKNT+1
51674 XLAM(LKNT)=XLAM(LKNT-1)
51675 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51676 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51677 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51678 ENDIF
51679 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51680 LKNT=LKNT+1
51681 XLAM(LKNT)=XLAM(LKNT-1)
51682 IDLAM(LKNT,1)=KFCCHI(IX)
51683 IDLAM(LKNT,2)=3
51684 IDLAM(LKNT,3)=-4
51685 LKNT=LKNT+1
51686 XLAM(LKNT)=XLAM(LKNT-1)
51687 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51688 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51689 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51690 ENDIF
51691 190 CONTINUE
51692
51693 XMF=PMAS(6,1)
51694 XMFP=PMAS(5,1)
51695 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
51696 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
51697 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
51698 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
51699 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
51700 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
51701 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
51702 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
51703 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
51704 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
51705 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
51706 CALL PYTBBC(IX,100,XMI,GAM)
51707 LKNT=LKNT+1
51708 XLAM(LKNT)=GAM
51709 IDLAM(LKNT,1)=KFCCHI(IX)
51710 IDLAM(LKNT,2)=5
51711 IDLAM(LKNT,3)=-6
51712 LKNT=LKNT+1
51713 XLAM(LKNT)=XLAM(LKNT-1)
51714 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51715 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51716 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51717 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
51718 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
51719 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
51720 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
51721 ENDIF
51722 200 CONTINUE
51723 ENDIF
51724 210 CONTINUE
51725
51726C...R-parity violating (3-body) decays.
51727 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
51728
51729 IKNT=LKNT
51730 XLAM(0)=0D0
51731 DO 220 I=1,IKNT
51732 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
51733 XLAM(0)=XLAM(0)+XLAM(I)
51734 220 CONTINUE
51735 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
51736
51737 RETURN
51738 END
51739
51740
51741C*********************************************************************
51742
51743C...PYTBBN
51744C...Calculates the three-body decay of gluinos into
51745C...neutralinos and third generation fermions.
51746
51747 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
51748
51749C...Double precision and integer declarations.
51750 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51751 IMPLICIT INTEGER(I-N)
51752 INTEGER PYK,PYCHGE,PYCOMP
51753C...Parameter statement to help give large particle numbers.
51754 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51755 &KEXCIT=4000000,KDIMEN=5000000)
51756C...Commonblocks.
51757 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51758 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51759 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51760 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51761 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51762 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
51763
51764C...Local variables.
51765 EXTERNAL PYSIMP,PYLAMF
51766 DOUBLE PRECISION PYSIMP,PYLAMF
51767 INTEGER LIN,NN
51768 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
51769 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
51770 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
51771 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
51772 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
51773 DOUBLE PRECISION XLN1,XLN2,B1,B2
51774 DOUBLE PRECISION E,XMGLU,GAM
51775 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
51776 SAVE HRB,HLB,FLB,FRB
51777 DOUBLE PRECISION ALPHAW,ALPHAS
51778 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
51779 SAVE HLT,HRT,FLT,FRT
51780 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
51781 SAVE AMN,AN,ZN
51782 DOUBLE PRECISION AMBOT,SINC,COSC
51783 DOUBLE PRECISION AMTOP,SINA,COSA
51784 DOUBLE PRECISION SINW,COSW,TANW
51785 DOUBLE PRECISION ROT1(4,4)
51786 LOGICAL IFIRST
51787 SAVE IFIRST
51788 DATA IFIRST/.TRUE./
51789
51790 TANB=RMSS(5)
51791 SINB=TANB/SQRT(1D0+TANB**2)
51792 COSB=SINB/TANB
51793 XW=PARU(102)
51794 SINW=SQRT(XW)
51795 COSW=SQRT(1D0-XW)
51796 TANW=SINW/COSW
51797 AMW=PMAS(24,1)
51798 COSC=SFMIX(5,1)
51799 SINC=SFMIX(5,3)
51800 COSA=SFMIX(6,1)
51801 SINA=SFMIX(6,3)
51802 AMBOT=PYMRUN(5,XMGLU**2)
51803 AMTOP=PYMRUN(6,XMGLU**2)
51804 W2=SQRT(2D0)
51805 FAKT1=AMBOT/W2/AMW/COSB
51806 FAKT2=AMTOP/W2/AMW/SINB
51807 IF(IFIRST) THEN
51808 DO 110 II=1,4
51809 AMN(II)=SMZ(II)
51810 DO 100 J=1,4
51811 ROT1(II,J)=0D0
51812 AN(II,J)=0D0
51813 100 CONTINUE
51814 110 CONTINUE
51815 ROT1(1,1)=COSW
51816 ROT1(1,2)=-SINW
51817 ROT1(2,1)=-ROT1(1,2)
51818 ROT1(2,2)=ROT1(1,1)
51819 ROT1(3,3)=COSB
51820 ROT1(3,4)=SINB
51821 ROT1(4,3)=-ROT1(3,4)
51822 ROT1(4,4)=ROT1(3,3)
51823 DO 140 II=1,4
51824 DO 130 J=1,4
51825 DO 120 JJ=1,4
51826 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
51827 120 CONTINUE
51828 130 CONTINUE
51829 140 CONTINUE
51830 DO 150 J=1,4
51831 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
51832 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51833 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
51834 & XW)*AN(J,2)/COSW
51835 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
51836 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
51837 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
51838 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
51839C FLU(J)=ZN(3)
51840C FRU(J)=ZN(2)
51841 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
51842 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51843 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
51844 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
51845 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
51846 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
51847 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
51848C FLD(J)=ZN(3)
51849C FRD(J)=ZN(2)
51850 150 CONTINUE
51851C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51852C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51853C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51854C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51855 IFIRST=.FALSE.
51856 ENDIF
51857
51858 IF(NINT(3D0*E).EQ.2) THEN
51859 HL=HLT(I)
51860 HR=HRT(I)
51861 FL=FLT(I)
51862 FR=FRT(I)
51863 COSD=SFMIX(6,1)
51864 SIND=SFMIX(6,3)
51865 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
51866 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
51867 XM=PMAS(6,1)
51868 ELSE
51869 HL=HLB(I)
51870 HR=HRB(I)
51871 FL=FLB(I)
51872 FR=FRB(I)
51873 COSD=SFMIX(5,1)
51874 SIND=SFMIX(5,3)
51875 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
51876 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
51877 XM=PMAS(5,1)
51878 ENDIF
51879 COSD2=COSD*COSD
51880 SIND2=SIND*SIND
51881 COS2D=COSD2-SIND2
51882 SIN2D=SIND*COSD*2D0
51883 HL2=HL*HL
51884 HR2=HR*HR
51885 FL2=FL*FL
51886 FR2=FR*FR
51887 FF=FL*FR
51888 HH=HL*HR
51889 HFL=HL*FL
51890 HFR=HR*FR
51891 HRFL=HR*FL
51892 HLFR=HL*FR
51893 XM2=XM*XM
51894 XMG=XMGLU
51895 XMG2=XMG*XMG
51896 ALPHAW=PYALEM(XMG2)
51897 ALPHAS=PYALPS(XMG2)
51898 XMR=AMN(I)
51899 XMR2=XMR*XMR
51900 XMQ4=XMG*XM2*XMR
51901 XM24=(XMG2+XM2)*(XM2+XMR2)
51902 SMIN=4D0*XM2
51903 SMAX=(XMG-ABS(XMR))**2
51904 XMQA=XMG2+2D0*XM2+XMR2
51905 DO 170 LIN=1,NN-1
51906 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51907 GRS=SBAR-XMQA
51908 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
51909 W=DSQRT(W)
51910 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
51911 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
51912 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
51913 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
51914 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
51915 & +2D0*(FF*SIND2-HH*COSD2))*W
51916 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
51917 & +4D0*HFL*XM*XMR)*XLN1
51918 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
51919 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
51920 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
51921 & +8D0*HFL*XMQ4*SIN2D)*B1
51922 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
51923 & +4D0*HFR*XMR*XM)*XLN2
51924 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
51925 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
51926 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
51927 & -8D0*HFR*XMQ4*SIN2D)*B2
51928 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
51929 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
51930 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
51931 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
51932 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
51933 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
51934 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
51935 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
51936 G(5)=(2D0*(HH*COSD2-FF*SIND2)
51937 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
51938 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
51939 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
51940 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
51941 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
51942 & +COS2D*XM*(SBAR+XMG2-XMR2))
51943 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
51944 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
51945 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
51946 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
51947 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
51948 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
51949 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
51950 SUMME(LIN)=0D0
51951 DO 160 J=0,6
51952 SUMME(LIN)=SUMME(LIN)+G(J)
51953 160 CONTINUE
51954 170 CONTINUE
51955 SUMME(0)=0D0
51956 SUMME(NN)=0D0
51957 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51958 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51959
51960 RETURN
51961 END
51962
51963C*********************************************************************
51964
51965C...PYTBBC
51966C...Calculates the three-body decay of gluinos into
51967C...charginos and third generation fermions.
51968
51969 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
51970
51971C...Double precision and integer declarations.
51972 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51973 IMPLICIT INTEGER(I-N)
51974 INTEGER PYK,PYCHGE,PYCOMP
51975C...Parameter statement to help give large particle numbers.
51976 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51977 &KEXCIT=4000000,KDIMEN=5000000)
51978C...Commonblocks.
51979 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51980 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51981 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51982 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51983 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51984 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
51985
51986C...Local variables.
51987 EXTERNAL PYSIMP,PYLAMF
51988 DOUBLE PRECISION PYSIMP,PYLAMF
51989 INTEGER I,NN,LIN
51990 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
51991 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
51992 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
51993 DOUBLE PRECISION SUMME(0:100),A(4,8)
51994 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
51995 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
51996 DOUBLE PRECISION XMGLU,GAM
51997 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
51998 &DDD(2),EEE(2),FFF(2)
51999 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
52000 DOUBLE PRECISION ALPHAW,ALPHAS
52001 DOUBLE PRECISION AMC(2)
52002 SAVE AMC
52003 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
52004 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
52005 SAVE AMSB,AMST
52006 LOGICAL IFIRST
52007 SAVE IFIRST
52008 DATA IFIRST/.TRUE./
52009
52010 TANB=RMSS(5)
52011 SINB=TANB/SQRT(1D0+TANB**2)
52012 COSB=SINB/TANB
52013 XW=PARU(102)
52014 AMW=PMAS(24,1)
52015 COSC=SFMIX(5,1)
52016 SINC=SFMIX(5,3)
52017 COSA=SFMIX(6,1)
52018 SINA=SFMIX(6,3)
52019 AMBOT=PYMRUN(5,XMGLU**2)
52020 AMTOP=PYMRUN(6,XMGLU**2)
52021 W2=SQRT(2D0)
52022 AMW=PMAS(24,1)
52023 FAKT1=AMBOT/W2/AMW/COSB
52024 FAKT2=AMTOP/W2/AMW/SINB
52025 IF(IFIRST) THEN
52026 AMC(1)=SMW(1)
52027 AMC(2)=SMW(2)
52028 DO 100 JJ=1,2
52029 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
52030 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
52031 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
52032 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
52033 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
52034 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
52035 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
52036 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
52037 100 CONTINUE
52038 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
52039 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
52040 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
52041 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
52042 IFIRST=.FALSE.
52043 ENDIF
52044
52045 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
52046 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
52047 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
52048 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
52049
52050 COS2A=COSA**2-SINA**2
52051 SIN2A=SINA*COSA*2D0
52052 COS2C=COSC**2-SINC**2
52053 SIN2C=SINC*COSC*2D0
52054
52055 XMG=XMGLU
52056 XMT=PMAS(6,1)
52057 XMB=PMAS(5,1)
52058 XMR=AMC(I)
52059 XMG2=XMG*XMG
52060 ALPHAW=PYALEM(XMG2)
52061 ALPHAS=PYALPS(XMG2)
52062 XMT2=XMT*XMT
52063 XMB2=XMB*XMB
52064 XMR2=XMR*XMR
52065 XMQ2=XMG2+XMT2+XMB2+XMR2
52066 XMQ4=XMG*XMT*XMB*XMR
52067 XMQ3=XMG2*XMR2+XMT2*XMB2
52068 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
52069 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
52070
52071 XMST(1)=AMST(1)*AMST(1)
52072 XMST(2)=AMST(1)*AMST(1)
52073 XMST(3)=AMST(2)*AMST(2)
52074 XMST(4)=AMST(2)*AMST(2)
52075 XMSB(1)=AMSB(1)*AMSB(1)
52076 XMSB(2)=AMSB(2)*AMSB(2)
52077 XMSB(3)=AMSB(1)*AMSB(1)
52078 XMSB(4)=AMSB(2)*AMSB(2)
52079
52080 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
52081 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
52082 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
52083 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
52084 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
52085 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
52086 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
52087 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
52088
52089 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
52090 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
52091 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
52092 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
52093 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
52094 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
52095 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
52096 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
52097
52098 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
52099 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
52100 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
52101 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
52102 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
52103 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
52104 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
52105 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
52106
52107 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
52108 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
52109 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
52110 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
52111 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
52112 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
52113 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
52114 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
52115
52116 SMAX=(XMG-ABS(XMR))**2
52117 SMIN=(XMB+XMT)**2+0.1D0
52118
52119 DO 120 LIN=0,NN-1
52120 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
52121 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
52122 GRS=SBAR-XMQ2
52123 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
52124 W=DSQRT(W)/2D0/SBAR
52125 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
52126 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
52127 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
52128 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
52129 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
52130 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
52131 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
52132 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
52133 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
52134 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
52135 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
52136 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
52137 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
52138 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
52139 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
52140 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
52141 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
52142 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
52143 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
52144 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
52145 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
52146 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
52147 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
52148 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
52149 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
52150 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
52151 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
52152 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
52153 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
52154 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
52155 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
52156 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
52157 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
52158 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
52159 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
52160 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
52161 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
52162 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
52163 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
52164 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
52165 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
52166 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
52167 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
52168 DO 110 J=1,4
52169 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
52170 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
52171 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
52172 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
52173 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
52174 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
52175 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
52176 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
52177 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
52178 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
52179 & -A(J,6)*(XMG2+XMR2-SBAR)
52180 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
52181 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
52182 & /(GRS+XMSB(J)+XMST(J))
52183 110 CONTINUE
52184 120 CONTINUE
52185 SUMME(NN)=0D0
52186 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
52187 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
52188
52189 RETURN
52190 END
52191
52192C*********************************************************************
52193
52194C...PYNJDC
52195C...Calculates decay widths for the neutralinos (admixtures of
52196C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
52197
52198C...Input: KCIN = KF code for particle
52199C...Output: XLAM = widths
52200C... IDLAM = KF codes for decay particles
52201C... IKNT = number of decay channels defined
52202C...AUTHOR: STEPHEN MRENNA
52203C...Last change:
52204C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
52205C...when CHIGAMMA .NE. 0
52206C...10 FEB 96: Calculate this decay for small tan(beta)
52207
52208 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
52209
52210C...Double precision and integer declarations.
52211 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52212 IMPLICIT INTEGER(I-N)
52213 INTEGER PYK,PYCHGE,PYCOMP
52214C...Parameter statement to help give large particle numbers.
52215 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52216 &KEXCIT=4000000,KDIMEN=5000000)
52217C...Commonblocks.
52218 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52219 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52220 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52221c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52222c &SFMIX(16,4)
52223 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52224 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52225C COMMON/PYINTS/XXM(20)
52226 COMPLEX*16 CXC
52227 COMMON/PYINTC/XXC(10),CXC(8)
52228 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
52229
52230C...Local variables.
52231 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
52232 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
52233 INTEGER KFIN
52234 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
52235 &XMZ,XMZ2,AXMJ,AXMI
52236 DOUBLE PRECISION S12MIN,S12MAX
52237 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
52238 DOUBLE PRECISION PYLAMF,XL
52239 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
52240 DOUBLE PRECISION PYX2XH,PYX2XG
52241 DOUBLE PRECISION XLAM(0:400)
52242 INTEGER IDLAM(400,3)
52243 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
52244 INTEGER ITH(3),KF1,KF2
52245 INTEGER ITHC
52246 DOUBLE PRECISION DH(3),EH(3)
52247 DOUBLE PRECISION SR2
52248 DOUBLE PRECISION CBETA,SBETA
52249 DOUBLE PRECISION GAMCON,XMT1,XMT2
52250 DOUBLE PRECISION PYALEM,PI,PYALPS
52251 DOUBLE PRECISION RAT1,RAT2
52252 DOUBLE PRECISION T3T,FCOL
52253 DOUBLE PRECISION ALFA,BETA,TANB
52254 DOUBLE PRECISION PYXXGA
52255 EXTERNAL PYGAUS,PYXXZ6
52256 DOUBLE PRECISION PYGAUS,PYXXZ6
52257 DOUBLE PRECISION PREC
52258 INTEGER KFNCHI(4),KFCCHI(2)
52259 DATA ITH/25,35,36/
52260 DATA ITHC/37/
52261 DATA PREC/1D-2/
52262 DATA PI/3.141592654D0/
52263 DATA SR2/1.4142136D0/
52264 DATA KFNCHI/1000022,1000023,1000025,1000035/
52265 DATA KFCCHI/1000024,1000037/
52266
52267C...COUNT THE NUMBER OF DECAY MODES
52268 LKNT=0
52269
52270 XMW=PMAS(24,1)
52271 XMW2=XMW**2
52272 XMZ=PMAS(23,1)
52273 XMZ2=XMZ**2
52274 XW=1D0-XMW2/XMZ2
52275 XW1=1D0-XW
52276 TANW = SQRT(XW/XW1)
52277
52278C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
52279 IX=1
52280 IF(KFIN.EQ.KFNCHI(2)) IX=2
52281 IF(KFIN.EQ.KFNCHI(3)) IX=3
52282 IF(KFIN.EQ.KFNCHI(4)) IX=4
52283
52284 XMI=SMZ(IX)
52285 XMI2=XMI**2
52286 AXMI=ABS(XMI)
52287 AEM=PYALEM(XMI2)
52288 AS =PYALPS(XMI2)
52289 C1=AEM/XW
52290 XMI3=ABS(XMI**3)
52291
52292 TANB=RMSS(5)
52293 BETA=ATAN(TANB)
52294 ALFA=RMSS(18)
52295 CBETA=COS(BETA)
52296 SBETA=TANB*CBETA
52297 CALFA=COS(ALFA)
52298 SALFA=SIN(ALFA)
52299
52300 DO 110 I=1,4
52301 DO 100 J=1,4
52302 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
52303 100 CONTINUE
52304 110 CONTINUE
52305 DO 130 I=1,2
52306 DO 120 J=1,2
52307 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52308 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52309 120 CONTINUE
52310 130 CONTINUE
52311
52312C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52313 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
52314
52315C...FORCE CHI0_2 -> CHI0_1 + GAMMA
52316 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
52317 XMJ=SMZ(1)
52318 AXMJ=ABS(XMJ)
52319 LKNT=LKNT+1
52320 GAMCON=AEM**3/8D0/PI/XMW2/XW
52321 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
52322 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
52323 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
52324 IDLAM(LKNT,1)=KSUSY1+22
52325 IDLAM(LKNT,2)=22
52326 IDLAM(LKNT,3)=0
52327 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
52328 GOTO 340
52329 ENDIF
52330
52331C...GRAVITINO DECAY MODES
52332
52333 IF(IMSS(11).EQ.1) THEN
52334 XMP=RMSS(29)
52335 IDG=39+KSUSY1
52336 XMGR=PMAS(PYCOMP(IDG),1)
52337 SINW=SQRT(XW)
52338 COSW=SQRT(1D0-XW)
52339 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
52340 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
52341 LKNT=LKNT+1
52342 IDLAM(LKNT,1)=IDG
52343 IDLAM(LKNT,2)=22
52344 IDLAM(LKNT,3)=0
52345 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
52346 ENDIF
52347 IF(AXMI.GT.XMGR+XMZ) THEN
52348 LKNT=LKNT+1
52349 IDLAM(LKNT,1)=IDG
52350 IDLAM(LKNT,2)=23
52351 IDLAM(LKNT,3)=0
52352 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
52353 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
52354 & (1D0-XMZ2/XMI2)**4
52355 ENDIF
52356 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
52357 LKNT=LKNT+1
52358 IDLAM(LKNT,1)=IDG
52359 IDLAM(LKNT,2)=25
52360 IDLAM(LKNT,3)=0
52361 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
52362 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
52363 ENDIF
52364 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
52365 LKNT=LKNT+1
52366 IDLAM(LKNT,1)=IDG
52367 IDLAM(LKNT,2)=35
52368 IDLAM(LKNT,3)=0
52369 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
52370 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
52371 ENDIF
52372 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
52373 LKNT=LKNT+1
52374 IDLAM(LKNT,1)=IDG
52375 IDLAM(LKNT,2)=36
52376 IDLAM(LKNT,3)=0
52377 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
52378 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
52379 ENDIF
52380 IF(IX.EQ.1) GOTO 300
52381 ENDIF
52382
52383 DO 220 IJ=1,IX-1
52384 XMJ=SMZ(IJ)
52385 AXMJ=ABS(XMJ)
52386 XMJ2=XMJ**2
52387
52388C...CHI0_I -> CHI0_J + GAMMA
52389 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
52390 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
52391 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
52392 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
52393 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
52394 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
52395 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
52396 LKNT=LKNT+1
52397 IDLAM(LKNT,1)=KFNCHI(IJ)
52398 IDLAM(LKNT,2)=22
52399 IDLAM(LKNT,3)=0
52400 GAMCON=AEM**3/8D0/PI/XMW2/XW
52401 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
52402 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
52403 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
52404 ENDIF
52405 ENDIF
52406
52407C...CHI0_I -> CHI0_J + Z0
52408 IF(AXMI.GE.AXMJ+XMZ) THEN
52409 LKNT=LKNT+1
52410 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
52411 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
52412 ORPP=-DCONJG(OLPP)
52413 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52414 GLR=DBLE(OLPP*DCONJG(ORPP))
52415 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
52416 IDLAM(LKNT,1)=KFNCHI(IJ)
52417 IDLAM(LKNT,2)=23
52418 IDLAM(LKNT,3)=0
52419 ELSEIF(AXMI.GE.AXMJ) THEN
52420 XXC(1)=0D0
52421 XXC(2)=XMJ
52422 XXC(3)=0D0
52423 XXC(4)=XMI
52424 XXC(9)=XMZ
52425 XXC(10)=PMAS(23,2)
52426 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
52427 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
52428 ORPP=DCONJG(OLPP)
52429C...CHARGED LEPTONS
52430 FID=11
52431 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52432 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52433 EI=KCHG(FID,1)/3D0
52434 T3I=SIGN(1D0,EI+1D-6)/2D0
52435 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52436 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52437 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52438 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52439 CXC(2)=-GLIJ
52440 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52441 CXC(4)=DCONJG(GLIJ)
52442 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52443 CXC(6)=GRIJ
52444 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52445 CXC(8)=-DCONJG(GRIJ)
52446 S12MIN=0D0
52447 S12MAX=(AXMI-AXMJ)**2
52448 IF( XXC(5).LT.AXMI ) THEN
52449 XXC(5)=1D6
52450 ENDIF
52451 IF(XXC(6).LT.AXMI ) THEN
52452 XXC(6)=1D6
52453 ENDIF
52454 XXC(7)=XXC(5)
52455 XXC(8)=XXC(6)
52456
52457 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
52458 LKNT=LKNT+1
52459 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52460 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52461 IDLAM(LKNT,1)=KFNCHI(IJ)
52462 IDLAM(LKNT,2)=FID
52463 IDLAM(LKNT,3)=-FID
52464 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
52465 LKNT=LKNT+1
52466 XLAM(LKNT)=XLAM(LKNT-1)
52467 IDLAM(LKNT,1)=KFNCHI(IJ)
52468 IDLAM(LKNT,2)=13
52469 IDLAM(LKNT,3)=-13
52470 ENDIF
52471 ENDIF
52472 140 CONTINUE
52473 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52474 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
52475 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
52476 ELSE
52477 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
52478 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
52479 ENDIF
52480 IF( XXC(5).LT.AXMI ) THEN
52481 XXC(5)=1D6
52482 ENDIF
52483 IF(XXC(6).LT.AXMI ) THEN
52484 XXC(6)=1D6
52485 ENDIF
52486 XXC(7)=XXC(5)
52487 XXC(8)=XXC(6)
52488
52489 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
52490 LKNT=LKNT+1
52491 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52492 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52493 IDLAM(LKNT,1)=KFNCHI(IJ)
52494 IDLAM(LKNT,2)=15
52495 IDLAM(LKNT,3)=-15
52496 ENDIF
52497
52498C...NEUTRINOS
52499 150 CONTINUE
52500 FID=12
52501 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52502 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52503 EI=KCHG(FID,1)/3D0
52504 T3I=SIGN(1D0,EI+1D-6)/2D0
52505 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52506 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52507 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52508 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52509 CXC(2)=-GLIJ
52510 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52511 CXC(4)=DCONJG(GLIJ)
52512 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52513 CXC(6)=GRIJ
52514 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52515 CXC(8)=-DCONJG(GRIJ)
52516 S12MIN=0D0
52517 S12MAX=(AXMI-AXMJ)**2
52518 IF( XXC(5).LT.AXMI ) THEN
52519 XXC(5)=1D6
52520 ENDIF
52521 IF( XXC(6).LT.AXMI ) THEN
52522 XXC(6)=1D6
52523 ENDIF
52524 XXC(7)=XXC(5)
52525 XXC(8)=XXC(6)
52526
52527 LKNT=LKNT+1
52528 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52529 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52530 IDLAM(LKNT,1)=KFNCHI(IJ)
52531 IDLAM(LKNT,2)=12
52532 IDLAM(LKNT,3)=-12
52533 LKNT=LKNT+1
52534 XLAM(LKNT)=XLAM(LKNT-1)
52535 IDLAM(LKNT,1)=KFNCHI(IJ)
52536 IDLAM(LKNT,2)=14
52537 IDLAM(LKNT,3)=-14
52538 160 CONTINUE
52539
52540 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
52541 & THEN
52542 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
52543 IF( XXC(5).LT.AXMI ) THEN
52544 XXC(5)=1D6
52545 ENDIF
52546 XXC(7)=XXC(5)
52547 LKNT=LKNT+1
52548 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52549 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52550 ELSE
52551 LKNT=LKNT+1
52552 XLAM(LKNT)=XLAM(LKNT-1)
52553 ENDIF
52554 IDLAM(LKNT,1)=KFNCHI(IJ)
52555 IDLAM(LKNT,2)=16
52556 IDLAM(LKNT,3)=-16
52557C...D-TYPE QUARKS
52558 170 CONTINUE
52559 FID=1
52560 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52561 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52562 EI=KCHG(FID,1)/3D0
52563 T3I=SIGN(1D0,EI+1D-6)/2D0
52564 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52565 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52566 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52567 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52568 CXC(2)=-GLIJ
52569 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52570 CXC(4)=DCONJG(GLIJ)
52571 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52572 CXC(6)=GRIJ
52573 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52574 CXC(8)=-DCONJG(GRIJ)
52575 S12MIN=0D0
52576 S12MAX=(AXMI-AXMJ)**2
52577 IF( XXC(5).LT.AXMI ) THEN
52578 XXC(5)=1D6
52579 ENDIF
52580 IF( XXC(6).LT.AXMI ) THEN
52581 XXC(6)=1D6
52582 ENDIF
52583 XXC(7)=XXC(5)
52584 XXC(8)=XXC(6)
52585
52586 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52587 LKNT=LKNT+1
52588 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52589 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
52590 IDLAM(LKNT,1)=KFNCHI(IJ)
52591 IDLAM(LKNT,2)=1
52592 IDLAM(LKNT,3)=-1
52593 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52594 LKNT=LKNT+1
52595 XLAM(LKNT)=XLAM(LKNT-1)
52596 IDLAM(LKNT,1)=KFNCHI(IJ)
52597 IDLAM(LKNT,2)=3
52598 IDLAM(LKNT,3)=-3
52599 ENDIF
52600 ENDIF
52601 180 CONTINUE
52602 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52603 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52604 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
52605 ELSE
52606 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
52607 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52608 ENDIF
52609 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
52610 IF(XXC(5).LT.AXMI) THEN
52611 XXC(5)=1D6
52612 ELSEIF(XXC(6).LT.AXMI) THEN
52613 XXC(6)=1D6
52614 ENDIF
52615 XXC(7)=XXC(5)
52616 XXC(8)=XXC(6)
52617 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52618 LKNT=LKNT+1
52619 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52620 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
52621 IDLAM(LKNT,1)=KFNCHI(IJ)
52622 IDLAM(LKNT,2)=5
52623 IDLAM(LKNT,3)=-5
52624 ENDIF
52625
52626C...U-TYPE QUARKS
52627 190 CONTINUE
52628 FID=2
52629 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52630 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52631 EI=KCHG(FID,1)/3D0
52632 T3I=SIGN(1D0,EI+1D-6)/2D0
52633 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52634 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52635 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52636 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52637 CXC(2)=-GLIJ
52638 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52639 CXC(4)=DCONJG(GLIJ)
52640 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52641 CXC(6)=GRIJ
52642 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52643 CXC(8)=-DCONJG(GRIJ)
52644
52645 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
52646 IF(XXC(5).LT.AXMI) THEN
52647 XXC(5)=1D6
52648 ELSEIF(XXC(6).LT.AXMI) THEN
52649 XXC(6)=1D6
52650 ENDIF
52651 XXC(7)=XXC(5)
52652 XXC(8)=XXC(6)
52653
52654 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52655 LKNT=LKNT+1
52656 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52657 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
52658 IDLAM(LKNT,1)=KFNCHI(IJ)
52659 IDLAM(LKNT,2)=2
52660 IDLAM(LKNT,3)=-2
52661 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52662 LKNT=LKNT+1
52663 XLAM(LKNT)=XLAM(LKNT-1)
52664 IDLAM(LKNT,1)=KFNCHI(IJ)
52665 IDLAM(LKNT,2)=4
52666 IDLAM(LKNT,3)=-4
52667 ENDIF
52668 ENDIF
52669 200 CONTINUE
52670 ENDIF
52671
52672C...CHI0_I -> CHI0_J + H0_K
52673 EH(1)=SIN(ALFA)
52674 EH(2)=COS(ALFA)
52675 EH(3)=-SIN(BETA)
52676 DH(1)=COS(ALFA)
52677 DH(2)=-SIN(ALFA)
52678 DH(3)=COS(BETA)
52679 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
52680 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
52681 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
52682 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
52683 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
52684 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
52685 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
52686 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
52687 DO 210 IH=1,3
52688 XMH=PMAS(ITH(IH),1)
52689 XMH2=XMH**2
52690 IF(AXMI.GE.AXMJ+XMH) THEN
52691 LKNT=LKNT+1
52692 XL=PYLAMF(XMI2,XMJ2,XMH2)
52693 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
52694 F12K=F21K
52695C...SIGN OF MASSES I,J
52696 XMK=XMJ
52697 IF(IH.EQ.3) XMK=-XMK
52698 GX2=ABS(F21K)**2+ABS(F12K)**2
52699 GLR=DBLE(F21K*DCONJG(F12K))
52700 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
52701 IDLAM(LKNT,1)=KFNCHI(IJ)
52702 IDLAM(LKNT,2)=ITH(IH)
52703 IDLAM(LKNT,3)=0
52704 ENDIF
52705 210 CONTINUE
52706 220 CONTINUE
52707
52708C...CHI0_I -> CHI+_J + W-
52709 DO 260 IJ=1,2
52710 XMJ=SMW(IJ)
52711 AXMJ=ABS(XMJ)
52712 XMJ2=XMJ**2
52713 IF(AXMI.GE.AXMJ+XMW) THEN
52714 LKNT=LKNT+1
52715 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
52716 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
52717 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
52718 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
52719 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
52720 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
52721 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
52722 IDLAM(LKNT,1)=KFCCHI(IJ)
52723 IDLAM(LKNT,2)=-24
52724 IDLAM(LKNT,3)=0
52725 LKNT=LKNT+1
52726 XLAM(LKNT)=XLAM(LKNT-1)
52727 IDLAM(LKNT,1)=-KFCCHI(IJ)
52728 IDLAM(LKNT,2)=24
52729 IDLAM(LKNT,3)=0
52730 ELSEIF(AXMI.GE.AXMJ) THEN
52731 S12MIN=0D0
52732 S12MAX=(AXMI-AXMJ)**2
52733 RT2I = 1D0/SQRT(2D0)
52734 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
52735 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
52736 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
52737 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
52738 CXC(5)=DCMPLX(0D0,0D0)
52739 CXC(7)=DCMPLX(0D0,0D0)
52740 IA=11
52741 JA=12
52742 EI=KCHG(IA,1)/3D0
52743 T3I=SIGN(1D0,EI+1D-6)/2D0
52744 EJ=KCHG(JA,1)/3D0
52745 T3J=SIGN(1D0,EJ+1D-6)/2D0
52746 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
52747 & TANW+ZMIXC(IX,2)*T3J)*RT2I
52748 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
52749 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
52750 CXC(6)=DCMPLX(0D0,0D0)
52751 CXC(8)=DCMPLX(0D0,0D0)
52752 XXC(1)=0D0
52753 XXC(2)=XMJ
52754 XXC(3)=0D0
52755 XXC(4)=XMI
52756 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52757 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52758 XXC(9)=PMAS(24,1)
52759 XXC(10)=PMAS(24,2)
52760 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
52761 IF(XXC(5).LT.AXMI) THEN
52762 XXC(5)=1D6
52763 ELSEIF(XXC(6).LT.AXMI) THEN
52764 XXC(6)=1D6
52765 ENDIF
52766 XXC(7)=XXC(6)
52767 XXC(8)=XXC(5)
52768 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
52769 LKNT=LKNT+1
52770 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52771 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52772 IDLAM(LKNT,1)=KFCCHI(IJ)
52773 IDLAM(LKNT,2)=11
52774 IDLAM(LKNT,3)=-12
52775 LKNT=LKNT+1
52776 XLAM(LKNT)=XLAM(LKNT-1)
52777 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52778 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52779 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52780 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
52781 LKNT=LKNT+1
52782 XLAM(LKNT)=XLAM(LKNT-1)
52783 IDLAM(LKNT,1)=KFCCHI(IJ)
52784 IDLAM(LKNT,2)=13
52785 IDLAM(LKNT,3)=-14
52786 LKNT=LKNT+1
52787 XLAM(LKNT)=XLAM(LKNT-1)
52788 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52789 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52790 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52791 ENDIF
52792 ENDIF
52793 230 CONTINUE
52794 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52795 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
52796 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
52797 ELSE
52798 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
52799 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
52800 ENDIF
52801 IF(XXC(5).LT.AXMI) THEN
52802 XXC(5)=1D6
52803 ENDIF
52804 IF(XXC(6).LT.AXMI) THEN
52805 XXC(6)=1D6
52806 ENDIF
52807 XXC(7)=XXC(6)
52808 XXC(8)=XXC(5)
52809 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
52810 LKNT=LKNT+1
52811 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52812 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52813 XLAM(LKNT)=XLAM(LKNT-1)
52814 IDLAM(LKNT,1)=KFCCHI(IJ)
52815 IDLAM(LKNT,2)=15
52816 IDLAM(LKNT,3)=-16
52817 LKNT=LKNT+1
52818 XLAM(LKNT)=XLAM(LKNT-1)
52819 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52820 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52821 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52822 ENDIF
52823
52824C...NOW, DO THE QUARKS
52825 240 CONTINUE
52826 IA=1
52827 JA=2
52828 EI=KCHG(IA,1)/3D0
52829 T3I=SIGN(1D0,EI+1D-6)/2D0
52830 EJ=KCHG(JA,1)/3D0
52831 T3J=SIGN(1D0,EJ+1D-6)/2D0
52832 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
52833 & TANW+ZMIXC(IX,2)*T3J)
52834 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
52835 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
52836 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
52837 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
52838 IF(XXC(5).LT.AXMI) THEN
52839 XXC(5)=1D6
52840 ENDIF
52841 IF(XXC(6).LT.AXMI) THEN
52842 XXC(6)=1D6
52843 ENDIF
52844 XXC(7)=XXC(6)
52845 XXC(8)=XXC(5)
52846 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
52847 LKNT=LKNT+1
52848 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52849 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52850 IDLAM(LKNT,1)=KFCCHI(IJ)
52851 IDLAM(LKNT,2)=1
52852 IDLAM(LKNT,3)=-2
52853 LKNT=LKNT+1
52854 XLAM(LKNT)=XLAM(LKNT-1)
52855 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52856 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52857 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52858 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52859 LKNT=LKNT+1
52860 XLAM(LKNT)=XLAM(LKNT-1)
52861 IDLAM(LKNT,1)=KFCCHI(IJ)
52862 IDLAM(LKNT,2)=3
52863 IDLAM(LKNT,3)=-4
52864 LKNT=LKNT+1
52865 XLAM(LKNT)=XLAM(LKNT-1)
52866 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52867 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52868 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52869 ENDIF
52870 ENDIF
52871 250 CONTINUE
52872 ENDIF
52873 260 CONTINUE
52874 270 CONTINUE
52875
52876C...CHI0_I -> CHI+_I + H-
52877 DO 280 IJ=1,2
52878 XMJ=SMW(IJ)
52879 AXMJ=ABS(XMJ)
52880 XMJ2=XMJ**2
52881 XMHP=PMAS(ITHC,1)
52882 IF(AXMI.GE.AXMJ+XMHP) THEN
52883 LKNT=LKNT+1
52884 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
52885 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
52886 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
52887 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
52888 & UMIXC(IJ,2)/SR2)
52889 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52890 GLR=DBLE(OLPP*DCONJG(ORPP))
52891 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52892 IDLAM(LKNT,1)=KFCCHI(IJ)
52893 IDLAM(LKNT,2)=-ITHC
52894 IDLAM(LKNT,3)=0
52895 LKNT=LKNT+1
52896 XLAM(LKNT)=XLAM(LKNT-1)
52897 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52898 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52899 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52900 ELSE
52901
52902 ENDIF
52903 280 CONTINUE
52904
52905C...2-BODY DECAYS TO FERMION SFERMION
52906 DO 290 J=1,16
52907 IF(J.GE.7.AND.J.LE.10) GOTO 290
52908 KF1=KSUSY1+J
52909 KF2=KSUSY2+J
52910 XMSF1=PMAS(PYCOMP(KF1),1)
52911 XMSF2=PMAS(PYCOMP(KF2),1)
52912 XMF=PMAS(J,1)
52913 IF(J.LE.6) THEN
52914 FCOL=3D0
52915 ELSE
52916 FCOL=1D0
52917 ENDIF
52918
52919 EI=KCHG(J,1)/3D0
52920 T3T=SIGN(1D0,EI)
52921 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
52922 IF(MOD(J,2).EQ.0) THEN
52923 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52924 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
52925 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52926 CBR=CAL
52927 ELSE
52928 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52929 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
52930 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52931 CBR=CAL
52932 ENDIF
52933
52934C...D~ D_L
52935 IF(AXMI.GE.XMF+XMSF1) THEN
52936 LKNT=LKNT+1
52937 XMA2=XMSF1**2
52938 XMB2=XMF**2
52939 XL=PYLAMF(XMI2,XMA2,XMB2)
52940 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
52941 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
52942 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52943 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52944 IDLAM(LKNT,1)=KF1
52945 IDLAM(LKNT,2)=-J
52946 IDLAM(LKNT,3)=0
52947 LKNT=LKNT+1
52948 XLAM(LKNT)=XLAM(LKNT-1)
52949 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52950 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52951 IDLAM(LKNT,3)=0
52952 ENDIF
52953
52954C...D~ D_R
52955 IF(AXMI.GE.XMF+XMSF2) THEN
52956 LKNT=LKNT+1
52957 XMA2=XMSF2**2
52958 XMB2=XMF**2
52959 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
52960 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
52961 XL=PYLAMF(XMI2,XMA2,XMB2)
52962 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52963 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52964 IDLAM(LKNT,1)=KF2
52965 IDLAM(LKNT,2)=-J
52966 IDLAM(LKNT,3)=0
52967 LKNT=LKNT+1
52968 XLAM(LKNT)=XLAM(LKNT-1)
52969 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52970 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52971 IDLAM(LKNT,3)=0
52972 ENDIF
52973 290 CONTINUE
52974 300 CONTINUE
52975C...3-BODY DECAY TO Q Q~ GLUINO
52976 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52977 IF(AXMI.GE.XMJ) THEN
52978 RT2I = 1D0/SQRT(2D0)
52979 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
52980 ORPP=DCONJG(OLPP)
52981 AXMJ=ABS(XMJ)
52982 XXC(1)=0D0
52983 XXC(2)=XMJ
52984 XXC(3)=0D0
52985 XXC(4)=XMI
52986 FID=1
52987 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52988 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52989 XXC(7)=XXC(5)
52990 XXC(8)=XXC(6)
52991 XXC(9)=1D6
52992 XXC(10)=0D0
52993 EI=KCHG(FID,1)/3D0
52994 T3I=SIGN(1D0,EI+1D-6)/2D0
52995 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52996 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52997 CXC(1)=0D0
52998 CXC(2)=-GLIJ
52999 CXC(3)=0D0
53000 CXC(4)=DCONJG(GLIJ)
53001 CXC(5)=0D0
53002 CXC(6)=GRIJ
53003 CXC(7)=0D0
53004 CXC(8)=-DCONJG(GRIJ)
53005 S12MIN=0D0
53006 S12MAX=(AXMI-AXMJ)**2
53007CMRENNA.This statement must be here to define S12MAX
53008 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
53009C...ALL QUARKS BUT T
53010 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
53011 LKNT=LKNT+1
53012 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
53013 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
53014 IDLAM(LKNT,1)=KSUSY1+21
53015 IDLAM(LKNT,2)=1
53016 IDLAM(LKNT,3)=-1
53017 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
53018 LKNT=LKNT+1
53019 XLAM(LKNT)=XLAM(LKNT-1)
53020 IDLAM(LKNT,1)=KSUSY1+21
53021 IDLAM(LKNT,2)=3
53022 IDLAM(LKNT,3)=-3
53023 ENDIF
53024 ENDIF
53025 310 CONTINUE
53026 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
53027 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
53028 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
53029 ELSE
53030 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
53031 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
53032 ENDIF
53033 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
53034 XXC(7)=XXC(5)
53035 XXC(8)=XXC(6)
53036 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
53037 LKNT=LKNT+1
53038 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
53039 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
53040 IDLAM(LKNT,1)=KSUSY1+21
53041 IDLAM(LKNT,2)=5
53042 IDLAM(LKNT,3)=-5
53043 ENDIF
53044C...U-TYPE QUARKS
53045 320 CONTINUE
53046 FID=2
53047 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
53048 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
53049 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
53050 XXC(7)=XXC(5)
53051 XXC(8)=XXC(6)
53052 EI=KCHG(FID,1)/3D0
53053 T3I=SIGN(1D0,EI+1D-6)/2D0
53054 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
53055 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
53056 CXC(2)=-GLIJ
53057 CXC(4)=DCONJG(GLIJ)
53058 CXC(6)=GRIJ
53059 CXC(8)=-DCONJG(GRIJ)
53060 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
53061 LKNT=LKNT+1
53062 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
53063 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
53064 IDLAM(LKNT,1)=KSUSY1+21
53065 IDLAM(LKNT,2)=2
53066 IDLAM(LKNT,3)=-2
53067 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
53068 LKNT=LKNT+1
53069 XLAM(LKNT)=XLAM(LKNT-1)
53070 IDLAM(LKNT,1)=KSUSY1+21
53071 IDLAM(LKNT,2)=4
53072 IDLAM(LKNT,3)=-4
53073 ENDIF
53074 ENDIF
53075 330 CONTINUE
53076 ENDIF
53077
53078C...R-violating decay modes (SKANDS).
53079 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
53080
53081 340 IKNT=LKNT
53082 XLAM(0)=0D0
53083 DO 350 I=1,IKNT
53084 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
53085 XLAM(0)=XLAM(0)+XLAM(I)
53086 350 CONTINUE
53087 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
53088
53089 RETURN
53090 END
53091
53092C*********************************************************************
53093
53094C...PYCJDC
53095C...Calculate decay widths for the charginos (admixtures of
53096C...charged Wino and charged Higgsino.
53097
53098C...Input: KCIN = KF code for particle
53099C...Output: XLAM = widths
53100C... IDLAM = KF codes for decay particles
53101C... IKNT = number of decay channels defined
53102C...AUTHOR: STEPHEN MRENNA
53103C...Last change:
53104C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
53105C...when CHIENU .NE. 0
53106
53107 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
53108
53109C...Double precision and integer declarations.
53110 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53111 IMPLICIT INTEGER(I-N)
53112 INTEGER PYK,PYCHGE,PYCOMP
53113C...Parameter statement to help give large particle numbers.
53114 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53115 &KEXCIT=4000000,KDIMEN=5000000)
53116C...Commonblocks.
53117 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53118 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53119 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
53120 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53121 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53122CC &SFMIX(16,4),
53123C COMMON/PYINTS/XXM(20)
53124 COMPLEX*16 CXC
53125 COMMON/PYINTC/XXC(10),CXC(8)
53126 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
53127
53128C...Local variables
53129 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
53130 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
53131 INTEGER KFIN,KCIN
53132 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
53133 &XMZ,XMZ2,AXMJ,AXMI
53134 DOUBLE PRECISION S12MIN,S12MAX
53135 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
53136 DOUBLE PRECISION PYLAMF,XL
53137 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
53138 DOUBLE PRECISION PYX2XH,PYX2XG
53139 DOUBLE PRECISION XLAM(0:400)
53140 INTEGER IDLAM(400,3)
53141 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
53142 INTEGER ITH(3)
53143 INTEGER ITHC
53144 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
53145 DOUBLE PRECISION SR2
53146 DOUBLE PRECISION CBETA,SBETA,TANB
53147
53148 DOUBLE PRECISION PYALEM,PI,PYALPS
53149 DOUBLE PRECISION FCOL
53150 INTEGER KF1,KF2,ISF
53151 INTEGER KFNCHI(4),KFCCHI(2)
53152
53153 DOUBLE PRECISION TEMP
53154 EXTERNAL PYGAUS,PYXXZ6
53155 DOUBLE PRECISION PYGAUS,PYXXZ6
53156 DOUBLE PRECISION PREC
53157 DATA ITH/25,35,36/
53158 DATA ITHC/37/
53159 DATA ETAH/1D0,1D0,-1D0/
53160 DATA SR2/1.4142136D0/
53161 DATA PI/3.141592654D0/
53162 DATA PREC/1D-2/
53163 DATA KFNCHI/1000022,1000023,1000025,1000035/
53164 DATA KFCCHI/1000024,1000037/
53165
53166C...COUNT THE NUMBER OF DECAY MODES
53167 LKNT=0
53168 XMW=PMAS(24,1)
53169 XMW2=XMW**2
53170 XMZ=PMAS(23,1)
53171 XMZ2=XMZ**2
53172 XW=1D0-XMW2/XMZ2
53173 XW1=1D0-XW
53174 TANW = SQRT(XW/XW1)
53175
53176C...1 OR 2 DEPENDING ON CHARGINO TYPE
53177 IX=1
53178 IF(KFIN.EQ.KFCCHI(2)) IX=2
53179 KCIN=PYCOMP(KFIN)
53180
53181 XMI=SMW(IX)
53182 XMI2=XMI**2
53183 AXMI=ABS(XMI)
53184 AEM=PYALEM(XMI2)
53185 AS =PYALPS(XMI2)
53186 C1=AEM/XW
53187 XMI3=ABS(XMI**3)
53188 TANB=RMSS(5)
53189 BETA=ATAN(TANB)
53190 CBETA=COS(BETA)
53191 SBETA=TANB*CBETA
53192 ALFA=RMSS(18)
53193
53194 DO 110 I=1,2
53195 DO 100 J=1,2
53196 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
53197 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
53198 100 CONTINUE
53199 110 CONTINUE
53200
53201C...GRAVITINO DECAY MODES
53202
53203 IF(IMSS(11).EQ.1) THEN
53204 XMP=RMSS(29)
53205 IDG=39+KSUSY1
53206 XMGR=PMAS(PYCOMP(IDG),1)
53207C SINW=SQRT(XW)
53208C COSW=SQRT(1D0-XW)
53209 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
53210 IF(AXMI.GT.XMGR+XMW) THEN
53211 LKNT=LKNT+1
53212 IDLAM(LKNT,1)=IDG
53213 IDLAM(LKNT,2)=24
53214 IDLAM(LKNT,3)=0
53215 XLAM(LKNT)=XFAC*(
53216 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
53217 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
53218 & (1D0-XMW2/XMI2)**4
53219 ENDIF
53220 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
53221 LKNT=LKNT+1
53222 IDLAM(LKNT,1)=IDG
53223 IDLAM(LKNT,2)=37
53224 IDLAM(LKNT,3)=0
53225 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
53226 & (ABS(UMIXC(IX,2))*SBETA)**2))
53227 & *(1D0-PMAS(37,1)**2/XMI2)**4
53228 ENDIF
53229 ENDIF
53230
53231C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
53232 IF(IX.EQ.1) GOTO 170
53233 XMJ=SMW(1)
53234 AXMJ=ABS(XMJ)
53235 XMJ2=XMJ**2
53236
53237C...CHI_2+ -> CHI_1+ + Z0
53238 IF(AXMI.GE.AXMJ+XMZ) THEN
53239 LKNT=LKNT+1
53240 IJ=1
53241 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
53242 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
53243 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
53244 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
53245 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53246 GLR=DBLE(OLPP*DCONJG(ORPP))
53247 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
53248 IDLAM(LKNT,1)=KFCCHI(1)
53249 IDLAM(LKNT,2)=23
53250 IDLAM(LKNT,3)=0
53251
53252C...CHARGED LEPTONS
53253 ELSEIF(AXMI.GE.AXMJ) THEN
53254 S12MIN=0D0
53255 S12MAX=(AXMI-AXMJ)**2
53256 IA=11
53257 JA=12
53258 EI=KCHG(IABS(IA),1)/3D0
53259 T3I=SIGN(1D0,EI+1D-6)/2D0
53260 XXC(1)=0D0
53261 XXC(2)=XMJ
53262 XXC(3)=0D0
53263 XXC(4)=XMI
53264 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53265 XXC(6)=1D6
53266 XXC(9)=PMAS(23,1)
53267 XXC(10)=PMAS(23,2)
53268 IJ=1
53269 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
53270 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
53271 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
53272 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
53273 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53274 CXC(2)=DCMPLX(0D0,0D0)
53275 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53276 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
53277 CXC(5)=-DCMPLX(EI/XW1)*ORPP
53278 CXC(6)=DCMPLX(0D0,0D0)
53279 CXC(7)=-DCMPLX(EI/XW1)*OLPP
53280 CXC(8)=DCMPLX(0D0,0D0)
53281 IF( XXC(5).LT.AXMI ) THEN
53282 XXC(5)=1D6
53283 ENDIF
53284 XXC(7)=XXC(5)
53285 XXC(8)=XXC(6)
53286 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
53287 LKNT=LKNT+1
53288 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
53289 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53290 IDLAM(LKNT,1)=KFCCHI(1)
53291 IDLAM(LKNT,2)=11
53292 IDLAM(LKNT,3)=-11
53293 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
53294 LKNT=LKNT+1
53295 XLAM(LKNT)=XLAM(LKNT-1)
53296 IDLAM(LKNT,1)=KFCCHI(1)
53297 IDLAM(LKNT,2)=13
53298 IDLAM(LKNT,3)=-13
53299 ENDIF
53300 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
53301 LKNT=LKNT+1
53302 XLAM(LKNT)=XLAM(LKNT-1)
53303 IDLAM(LKNT,1)=KFCCHI(1)
53304 IDLAM(LKNT,2)=15
53305 IDLAM(LKNT,3)=-15
53306 ENDIF
53307 ENDIF
53308
53309C...NEUTRINOS
53310 120 CONTINUE
53311 IA=12
53312 JA=11
53313 EI=KCHG(IABS(IA),1)/3D0
53314 T3I=SIGN(1D0,EI+1D-6)/2D0
53315 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53316 XXC(6)=1D6
53317 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53318 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53319 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
53320 CXC(5)=-DCMPLX(EI/XW1)*ORPP
53321 CXC(7)=-DCMPLX(EI/XW1)*OLPP
53322 IF( XXC(5).LT.AXMI ) THEN
53323 XXC(5)=1D6
53324 ENDIF
53325 XXC(7)=XXC(5)
53326 XXC(8)=XXC(6)
53327 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
53328 LKNT=LKNT+1
53329 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
53330 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53331 IDLAM(LKNT,1)=KFCCHI(1)
53332 IDLAM(LKNT,2)=12
53333 IDLAM(LKNT,3)=-12
53334 LKNT=LKNT+1
53335 XLAM(LKNT)=XLAM(LKNT-1)
53336 IDLAM(LKNT,1)=KFCCHI(1)
53337 IDLAM(LKNT,2)=14
53338 IDLAM(LKNT,3)=-14
53339 ENDIF
53340 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
53341 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
53342 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
53343 ELSE
53344 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
53345 ENDIF
53346 IF( XXC(5).LT.AXMI ) THEN
53347 XXC(5)=1D6
53348 ENDIF
53349 XXC(7)=XXC(5)
53350 LKNT=LKNT+1
53351 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
53352 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53353 IDLAM(LKNT,1)=KFCCHI(1)
53354 IDLAM(LKNT,2)=16
53355 IDLAM(LKNT,3)=-16
53356 ENDIF
53357
53358C...D-TYPE QUARKS
53359 130 CONTINUE
53360 IA=1
53361 JA=2
53362 EI=KCHG(IABS(IA),1)/3D0
53363 T3I=SIGN(1D0,EI+1D-6)/2D0
53364 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53365 XXC(6)=1D6
53366 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53367 CXC(2)=DCMPLX(0D0,0D0)
53368 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53369 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
53370 CXC(5)=-DCMPLX(EI/XW1)*ORPP
53371 CXC(6)=DCMPLX(0D0,0D0)
53372 CXC(7)=-DCMPLX(EI/XW1)*OLPP
53373 CXC(8)=DCMPLX(0D0,0D0)
53374 IF( XXC(5).LT.AXMI ) THEN
53375 XXC(5)=1D6
53376 ENDIF
53377 XXC(7)=XXC(5)
53378 XXC(8)=XXC(6)
53379 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
53380 LKNT=LKNT+1
53381 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53382 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53383 IDLAM(LKNT,1)=KFCCHI(1)
53384 IDLAM(LKNT,2)=1
53385 IDLAM(LKNT,3)=-1
53386 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
53387 LKNT=LKNT+1
53388 XLAM(LKNT)=XLAM(LKNT-1)
53389 IDLAM(LKNT,1)=KFCCHI(1)
53390 IDLAM(LKNT,2)=3
53391 IDLAM(LKNT,3)=-3
53392 ENDIF
53393 ENDIF
53394 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
53395 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
53396 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
53397 ELSE
53398 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
53399 ENDIF
53400 IF( XXC(5).LT.AXMI ) THEN
53401 XXC(5)=1D6
53402 ENDIF
53403 XXC(7)=XXC(5)
53404 LKNT=LKNT+1
53405 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53406 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53407 IDLAM(LKNT,1)=KFCCHI(1)
53408 IDLAM(LKNT,2)=5
53409 IDLAM(LKNT,3)=-5
53410 ENDIF
53411
53412C...U-TYPE QUARKS
53413 140 CONTINUE
53414 IA=2
53415 JA=1
53416 EI=KCHG(IABS(IA),1)/3D0
53417 T3I=SIGN(1D0,EI+1D-6)/2D0
53418 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53419 XXC(6)=1D6
53420 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53421 CXC(2)=DCMPLX(0D0,0D0)
53422 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53423 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
53424 CXC(5)=-DCMPLX(EI/XW1)*ORPP
53425 CXC(6)=DCMPLX(0D0,0D0)
53426 CXC(7)=-DCMPLX(EI/XW1)*OLPP
53427 CXC(8)=DCMPLX(0D0,0D0)
53428 IF( XXC(5).LT.AXMI ) THEN
53429 XXC(5)=1D6
53430 ENDIF
53431 XXC(7)=XXC(5)
53432 XXC(8)=XXC(6)
53433 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
53434 LKNT=LKNT+1
53435 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53436 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53437 IDLAM(LKNT,1)=KFCCHI(1)
53438 IDLAM(LKNT,2)=2
53439 IDLAM(LKNT,3)=-2
53440 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
53441 LKNT=LKNT+1
53442 XLAM(LKNT)=XLAM(LKNT-1)
53443 IDLAM(LKNT,1)=KFCCHI(1)
53444 IDLAM(LKNT,2)=4
53445 IDLAM(LKNT,3)=-4
53446 ENDIF
53447 ENDIF
53448 150 CONTINUE
53449 ENDIF
53450
53451C...CHI_2+ -> CHI_1+ + H0_K
53452 EH(2)=COS(ALFA)
53453 EH(1)=SIN(ALFA)
53454 EH(3)=-SBETA
53455 DH(2)=-SIN(ALFA)
53456 DH(1)=COS(ALFA)
53457 DH(3)=COS(BETA)
53458 DO 160 IH=1,3
53459 XMH=PMAS(ITH(IH),1)
53460 XMH2=XMH**2
53461C...NO 3-BODY OPTION
53462 IF(AXMI.GE.AXMJ+XMH) THEN
53463 LKNT=LKNT+1
53464 XL=PYLAMF(XMI2,XMJ2,XMH2)
53465 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
53466 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
53467 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
53468 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
53469 XMK=XMJ*ETAH(IH)
53470 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53471 GLR=DBLE(OLPP*DCONJG(ORPP))
53472 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
53473 IDLAM(LKNT,1)=KFCCHI(1)
53474 IDLAM(LKNT,2)=ITH(IH)
53475 IDLAM(LKNT,3)=0
53476 ENDIF
53477 160 CONTINUE
53478
53479C...CHI1 JUMPS TO HERE
53480 170 CONTINUE
53481
53482C...CHI+_I -> CHI0_J + W+
53483 DO 220 IJ=1,4
53484 XMJ=SMZ(IJ)
53485 AXMJ=ABS(XMJ)
53486 XMJ2=XMJ**2
53487 IF(AXMI.GE.AXMJ+XMW) THEN
53488 LKNT=LKNT+1
53489 DO 180 I=1,4
53490 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
53491 180 CONTINUE
53492 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
53493 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
53494 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
53495 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
53496 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
53497 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
53498 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
53499 IDLAM(LKNT,1)=KFNCHI(IJ)
53500 IDLAM(LKNT,2)=24
53501 IDLAM(LKNT,3)=0
53502C...LEPTONS
53503 ELSEIF(AXMI.GE.AXMJ) THEN
53504 S12MIN=0D0
53505 S12MAX=(AXMI-AXMJ)**2
53506 DO 190 I=1,4
53507 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
53508 190 CONTINUE
53509 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
53510 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
53511 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
53512 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
53513 CXC(5)=DCMPLX(0D0,0D0)
53514 CXC(7)=DCMPLX(0D0,0D0)
53515 IA=11
53516 JA=12
53517 EI=KCHG(IA,1)/3D0
53518 T3I=SIGN(1D0,EI+1D-6)/2D0
53519 EJ=KCHG(JA,1)/3D0
53520 T3J=SIGN(1D0,EJ+1D-6)/2D0
53521 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
53522 & TANW+ZMIXC(IJ,2)*T3J)/SR2
53523 CXC(4)=-DCONJG(UMIXC(IX,1))*(
53524 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
53525 CXC(6)=DCMPLX(0D0,0D0)
53526 CXC(8)=DCMPLX(0D0,0D0)
53527 XXC(1)=0D0
53528 XXC(2)=XMJ
53529 XXC(3)=0D0
53530 XXC(4)=XMI
53531 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53532 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
53533 XXC(9)=PMAS(24,1)
53534 XXC(10)=PMAS(24,2)
53535CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
53536 IF(XXC(5).LT.AXMI) THEN
53537 XXC(5)=1D6
53538 ELSEIF(XXC(6).LT.AXMI) THEN
53539 XXC(6)=1D6
53540 ENDIF
53541 XXC(7)=XXC(6)
53542 XXC(8)=XXC(5)
53543C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
53544C...--> 1/(16PI)/M**3*(AEM/XW)**2
53545 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
53546 LKNT=LKNT+1
53547 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53548 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
53549 IDLAM(LKNT,1)=KFNCHI(IJ)
53550 IDLAM(LKNT,2)=-11
53551 IDLAM(LKNT,3)=12
53552C...ONLY DECAY CHI+1 -> E+ NU_E
53553 IF( IMSS(12).NE. 0 ) GOTO 260
53554 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
53555 LKNT=LKNT+1
53556 XLAM(LKNT)=XLAM(LKNT-1)
53557 IDLAM(LKNT,1)=KFNCHI(IJ)
53558 IDLAM(LKNT,2)=-13
53559 IDLAM(LKNT,3)=14
53560 ENDIF
53561 ENDIF
53562 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
53563 LKNT=LKNT+1
53564 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
53565 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
53566 ELSE
53567 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
53568 ENDIF
53569 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
53570 IF(XXC(5).LT.AXMI) THEN
53571 XXC(5)=1D6
53572 ELSEIF(XXC(6).LT.AXMI) THEN
53573 XXC(6)=1D6
53574 ENDIF
53575 XXC(7)=XXC(6)
53576 XXC(8)=XXC(5)
53577 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53578 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
53579 IDLAM(LKNT,1)=KFNCHI(IJ)
53580 IDLAM(LKNT,2)=-15
53581 IDLAM(LKNT,3)=16
53582 ENDIF
53583
53584C...NOW, DO THE QUARKS
53585 200 CONTINUE
53586 IA=1
53587 JA=2
53588 EI=KCHG(IA,1)/3D0
53589 T3I=SIGN(1D0,EI+1D-6)/2D0
53590 EJ=KCHG(JA,1)/3D0
53591 T3J=SIGN(1D0,EJ+1D-6)/2D0
53592 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
53593 & TANW+ZMIXC(IJ,2)*T3J)
53594 CXC(4)=-DCONJG(UMIXC(IX,1))*(
53595 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
53596 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53597 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
53598 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
53599 IF(XXC(5).LT.AXMI) THEN
53600 XXC(5)=1D6
53601 ENDIF
53602 IF(XXC(6).LT.AXMI) THEN
53603 XXC(6)=1D6
53604 ENDIF
53605 XXC(7)=XXC(6)
53606 XXC(8)=XXC(5)
53607 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
53608 LKNT=LKNT+1
53609 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53610 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53611 IDLAM(LKNT,1)=KFNCHI(IJ)
53612 IDLAM(LKNT,2)=-1
53613 IDLAM(LKNT,3)=2
53614 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
53615 LKNT=LKNT+1
53616 XLAM(LKNT)=XLAM(LKNT-1)
53617 IDLAM(LKNT,1)=KFNCHI(IJ)
53618 IDLAM(LKNT,2)=-3
53619 IDLAM(LKNT,3)=4
53620 ENDIF
53621 ENDIF
53622 210 CONTINUE
53623 ENDIF
53624 220 CONTINUE
53625
53626C...CHI+_I -> CHI0_J + H+
53627 DO 230 IJ=1,4
53628 XMJ=SMZ(IJ)
53629 AXMJ=ABS(XMJ)
53630 XMJ2=XMJ**2
53631 XMHP=PMAS(ITHC,1)
53632 IF(AXMI.GE.AXMJ+XMHP) THEN
53633 LKNT=LKNT+1
53634 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
53635 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
53636 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
53637 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
53638 & UMIXC(IX,2)/SR2)
53639 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53640 GLR=DBLE(OLPP*DCONJG(ORPP))
53641 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
53642 IDLAM(LKNT,1)=KFNCHI(IJ)
53643 IDLAM(LKNT,2)=ITHC
53644 IDLAM(LKNT,3)=0
53645 ELSE
53646
53647 ENDIF
53648 230 CONTINUE
53649
53650C...2-BODY DECAYS TO FERMION SFERMION
53651 DO 240 J=1,16
53652 IF(J.GE.7.AND.J.LE.10) GOTO 240
53653 IF(MOD(J,2).EQ.0) THEN
53654 KF1=KSUSY1+J-1
53655 ELSE
53656 KF1=KSUSY1+J+1
53657 ENDIF
53658 KF2=KF1+KSUSY1
53659 XMSF1=PMAS(PYCOMP(KF1),1)
53660 XMSF2=PMAS(PYCOMP(KF2),1)
53661 XMF=PMAS(J,1)
53662 IF(J.LE.6) THEN
53663 FCOL=3D0
53664 ELSE
53665 FCOL=1D0
53666 ENDIF
53667
53668C...U~ D_L
53669 IF(MOD(J,2).EQ.0) THEN
53670 XMFP=PMAS(J-1,1)
53671 CAL=UMIXC(IX,1)
53672 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
53673 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
53674 CBR=0D0
53675 ISF=J-1
53676 ELSE
53677 XMFP=PMAS(J+1,1)
53678 CAL=VMIXC(IX,1)
53679 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
53680 CBR=0D0
53681 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
53682 ISF=J+1
53683 ENDIF
53684
53685C...~U_L D
53686 IF(AXMI.GE.XMF+XMSF1) THEN
53687 LKNT=LKNT+1
53688 XMA2=XMSF1**2
53689 XMB2=XMF**2
53690 XL=PYLAMF(XMI2,XMA2,XMB2)
53691 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
53692 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
53693 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
53694 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
53695 IDLAM(LKNT,3)=0
53696 IF(MOD(J,2).EQ.0) THEN
53697 IDLAM(LKNT,1)=-KF1
53698 IDLAM(LKNT,2)=J
53699 ELSE
53700 IDLAM(LKNT,1)=KF1
53701 IDLAM(LKNT,2)=-J
53702 ENDIF
53703 ENDIF
53704
53705C...U~ D_R
53706 IF(AXMI.GE.XMF+XMSF2) THEN
53707 LKNT=LKNT+1
53708 XMA2=XMSF2**2
53709 XMB2=XMF**2
53710 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
53711 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
53712 XL=PYLAMF(XMI2,XMA2,XMB2)
53713 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
53714 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
53715 IDLAM(LKNT,3)=0
53716 IF(MOD(J,2).EQ.0) THEN
53717 IDLAM(LKNT,1)=-KF2
53718 IDLAM(LKNT,2)=J
53719 ELSE
53720 IDLAM(LKNT,1)=KF2
53721 IDLAM(LKNT,2)=-J
53722 ENDIF
53723 ENDIF
53724 240 CONTINUE
53725
53726C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
53727C...A 2-BODY -- 2-BODY CHAIN
53728 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
53729 IF(AXMI.GE.XMJ) THEN
53730 AXMJ=ABS(XMJ)
53731 S12MIN=0D0
53732 S12MAX=(AXMI-AXMJ)**2
53733 XXC(1)=0D0
53734 XXC(2)=XMJ
53735 XXC(3)=0D0
53736 XXC(4)=XMI
53737 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
53738 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
53739 XXC(9)=1D6
53740 XXC(10)=0D0
53741 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
53742 ORPP=DCONJG(OLPP)
53743 CXC(1)=DCMPLX(0D0,0D0)
53744 CXC(3)=DCMPLX(0D0,0D0)
53745 CXC(5)=DCMPLX(0D0,0D0)
53746 CXC(7)=DCMPLX(0D0,0D0)
53747 CXC(2)=UMIXC(IX,1)*OLPP/SR2
53748 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
53749 CXC(6)=DCMPLX(0D0,0D0)
53750 CXC(8)=DCMPLX(0D0,0D0)
53751 IF(XXC(5).LT.AXMI) THEN
53752 XXC(5)=1D6
53753 ELSEIF(XXC(6).LT.AXMI) THEN
53754 XXC(6)=1D6
53755 ENDIF
53756 XXC(7)=XXC(6)
53757 XXC(8)=XXC(5)
53758 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
53759 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
53760 LKNT=LKNT+1
53761 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
53762 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53763 IDLAM(LKNT,1)=KSUSY1+21
53764 IDLAM(LKNT,2)=-1
53765 IDLAM(LKNT,3)=2
53766 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
53767 LKNT=LKNT+1
53768 XLAM(LKNT)=XLAM(LKNT-1)
53769 IDLAM(LKNT,1)=KSUSY1+21
53770 IDLAM(LKNT,2)=-3
53771 IDLAM(LKNT,3)=4
53772 ENDIF
53773 ENDIF
53774 250 CONTINUE
53775 ENDIF
53776
53777C...R-violating decay modes (SKANDS).
53778 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
53779
53780 260 IKNT=LKNT
53781 XLAM(0)=0D0
53782 DO 270 I=1,IKNT
53783 XLAM(0)=XLAM(0)+XLAM(I)
53784 IF(XLAM(I).LT.0D0) THEN
53785 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
53786 & (IDLAM(I,J),J=1,3)
53787 XLAM(I)=0D0
53788 ENDIF
53789 270 CONTINUE
53790 IF(XLAM(0).EQ.0D0) THEN
53791 XLAM(0)=1D-6
53792 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
53793 WRITE(MSTU(11),*) LKNT
53794 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
53795 ENDIF
53796
53797 RETURN
53798 END
53799
53800C*********************************************************************
53801
53802C...PYXXZ6
53803C...Used in the calculation of inoi -> inoj + f + ~f.
53804
53805 FUNCTION PYXXZ6(X)
53806
53807C...Double precision and integer declarations.
53808 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53809 IMPLICIT INTEGER(I-N)
53810 INTEGER PYK,PYCHGE,PYCOMP
53811C...Parameter statement to help give large particle numbers.
53812 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53813 &KEXCIT=4000000,KDIMEN=5000000)
53814C...Commonblocks.
53815 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53816C COMMON/PYINTS/XXM(20)
53817 COMPLEX*16 CXC
53818 COMMON/PYINTC/XXC(10),CXC(8)
53819 SAVE /PYDAT1/,/PYINTC/
53820
53821C...Local variables.
53822 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
53823 DOUBLE PRECISION PYXXZ6,X
53824 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
53825 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
53826 DOUBLE PRECISION SIJ
53827 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
53828 DOUBLE PRECISION OL2
53829 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
53830 INTEGER I
53831
53832C...Statement functions.
53833C...Integral from x to y of (t-a)(b-t) dt.
53834 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
53835C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
53836 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
53837 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
53838C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
53839 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
53840 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
53841C...Integral from x to y of (t-a)/(b-t) dt.
53842 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
53843C...Integral from x to y of 1/(t-a) dt.
53844 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
53845
53846 XM12=XXC(1)**2
53847 XM22=XXC(2)**2
53848 XM32=XXC(3)**2
53849 S=XXC(4)**2
53850 S13=X
53851
53852 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
53853 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
53854 &( (X-XM22-S)**2 -4D0*XM22*S ) )
53855
53856 S23MIN=(S23AVE-S23DEL)
53857 S23MAX=(S23AVE+S23DEL)
53858
53859 XMSD1=XXC(5)**2
53860 XMSD2=XXC(7)**2
53861 XMSU1=XXC(6)**2
53862 XMSU2=XXC(8)**2
53863
53864 XMV=XXC(9)
53865 XMG=XXC(10)
53866 QLLS=CXC(1)
53867 QLLU=CXC(2)
53868 QLRS=CXC(3)
53869 QLRT=CXC(4)
53870 QRLS=CXC(5)
53871 QRLT=CXC(6)
53872 QRRS=CXC(7)
53873 QRRU=CXC(8)
53874 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
53875 SIJ=2D0*XXC(2)*XXC(4)*S13
53876 IF(XMV.LE.1000D0) THEN
53877 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
53878 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
53879 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
53880 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
53881 IF(XXC(5).LE.10000D0) THEN
53882 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
53883 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
53884 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
53885 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
53886 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
53887 & *(S13-XMV**2)/WPROP2
53888 ELSE
53889 WFL1=0D0
53890 ENDIF
53891
53892 IF(XXC(6).LE.10000D0) THEN
53893 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
53894 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
53895 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
53896 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
53897 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
53898 & *(S13-XMV**2)/WPROP2
53899 ELSE
53900 WFL2=0D0
53901 ENDIF
53902 ELSE
53903 WW=0D0
53904 WFL1=0D0
53905 WFL2=0D0
53906 ENDIF
53907 IF(XXC(5).LE.10000D0) THEN
53908 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
53909 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
53910 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
53911 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
53912 ELSE
53913 WF1=0D0
53914 ENDIF
53915 IF(XXC(6).LE.10000D0) THEN
53916 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
53917 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
53918 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
53919 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
53920 ELSE
53921 WF2=0D0
53922 ENDIF
53923
53924 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
53925
53926 IF(PYXXZ6.LT.0D0) THEN
53927 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
53928 WRITE(MSTU(11),*) (XXC(I),I=1,5)
53929 WRITE(MSTU(11),*) (XXC(I),I=6,10)
53930 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
53931 WRITE(MSTU(11),*) S23MIN,S23MAX
53932 PYXXZ6=0D0
53933 ENDIF
53934
53935 RETURN
53936 END
53937
53938
53939C*********************************************************************
53940
53941C...PYXXGA
53942C...Calculates chi0_i -> chi0_j + gamma.
53943
53944 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
53945
53946C...Double precision and integer declarations.
53947 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53948 IMPLICIT INTEGER(I-N)
53949 INTEGER PYK,PYCHGE,PYCOMP
53950
53951C...Local variables.
53952 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
53953 DOUBLE PRECISION F1,F2
53954
53955 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
53956 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
53957 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
53958 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
53959
53960 RETURN
53961 END
53962
53963C*********************************************************************
53964
53965C...PYX2XG
53966C...Calculates the decay rate for ino -> ino + gauge boson.
53967
53968 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
53969
53970C...Double precision and integer declarations.
53971 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53972 IMPLICIT INTEGER(I-N)
53973 INTEGER PYK,PYCHGE,PYCOMP
53974
53975C...Local variables.
53976 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
53977 DOUBLE PRECISION XL,PYLAMF,C1
53978 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53979
53980 XMI2=XM1**2
53981 XMI3=ABS(XM1**3)
53982 XMJ2=XM2**2
53983 XMV2=XM3**2
53984 XL=PYLAMF(XMI2,XMJ2,XMV2)
53985 PYX2XG=C1/8D0/XMI3*SQRT(XL)
53986 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
53987 &12D0*GLR*XM1*XM2*XMV2)
53988
53989 RETURN
53990 END
53991
53992C*********************************************************************
53993
53994C...PYX2XH
53995C...Calculates the decay rate for ino -> ino + H.
53996
53997 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
53998
53999C...Double precision and integer declarations.
54000 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54001 IMPLICIT INTEGER(I-N)
54002 INTEGER PYK,PYCHGE,PYCOMP
54003
54004C...Local variables.
54005 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
54006 DOUBLE PRECISION XL,PYLAMF,C1
54007 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
54008
54009 XMI2=XM1**2
54010 XMI3=ABS(XM1**3)
54011 XMJ2=XM2**2
54012 XMV2=XM3**2
54013 XL=PYLAMF(XMI2,XMJ2,XMV2)
54014 PYX2XH=C1/8D0/XMI3*SQRT(XL)
54015 &*(GX2*(XMI2+XMJ2-XMV2)+
54016 &4D0*GLR*XM1*XM2)
54017
54018 RETURN
54019 END
54020
54021C*********************************************************************
54022
54023C...PYHEXT
54024C...Calculates the non-standard decay modes of the Higgs boson.
54025C...
54026C...Author: Stephen Mrenna
54027C...Last Update: April 2001
54028C......Allow complex values for Z,U, and V
54029
54030 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
54031
54032C...Double precision and integer declarations.
54033 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54034 IMPLICIT INTEGER(I-N)
54035 INTEGER PYK,PYCHGE,PYCOMP
54036C...Parameter statement to help give large particle numbers.
54037 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54038 &KEXCIT=4000000,KDIMEN=5000000)
54039C...Commonblocks.
54040 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54041 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54042 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54043 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54044 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54045 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54046 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
54047
54048C...Local variables.
54049 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
54050 COMPLEX*16 QIJ,RIJ,F21K,F12K
54051 INTEGER KFIN
54052 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
54053 DOUBLE PRECISION XMI2,XMI3,XMJ2
54054 DOUBLE PRECISION PYLAMF,XL,CF,EI
54055 INTEGER IDU,IFL
54056 DOUBLE PRECISION TANW,XW,AEM,C1,AS
54057 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
54058 DOUBLE PRECISION XLAM(0:400)
54059 INTEGER IDLAM(400,3)
54060 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
54061 INTEGER ITH(4)
54062 INTEGER KFNCHI(4),KFCCHI(2)
54063 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
54064 DOUBLE PRECISION SR2
54065 DOUBLE PRECISION BETA,ALFA
54066 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
54067 DOUBLE PRECISION PYALEM
54068 DOUBLE PRECISION AL,AR,ALR
54069 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
54070 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
54071 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
54072 DATA ITH/25,35,36,37/
54073 DATA ETAH/1D0,1D0,-1D0/
54074 DATA SR2/1.4142136D0/
54075 DATA KFNCHI/1000022,1000023,1000025,1000035/
54076 DATA KFCCHI/1000024,1000037/
54077
54078C...COUNT THE NUMBER OF DECAY MODES
54079 LKNT=IKNT
54080
54081 XMW=PMAS(24,1)
54082 XMW2=XMW**2
54083 XMZ=PMAS(23,1)
54084 XW=PARU(102)
54085 TANW = SQRT(XW/(1D0-XW))
54086 CW=SQRT(1D0-XW)
54087
54088C...1 - 4 DEPENDING ON Higgs species.
54089 IH=1
54090 IF(KFIN.EQ.ITH(2)) IH=2
54091 IF(KFIN.EQ.ITH(3)) IH=3
54092 IF(KFIN.EQ.ITH(4)) IH=4
54093
54094 XMI=PMAS(KFIN,1)
54095 XMI2=XMI**2
54096 AXMI=ABS(XMI)
54097 AEM=PYALEM(XMI2)
54098 C1=AEM/XW
54099 XMI3=ABS(XMI**3)
54100
54101 TANB=RMSS(5)
54102 BETA=ATAN(TANB)
54103 CBETA=COS(BETA)
54104 SBETA=TANB*CBETA
54105 ALFA=RMSS(18)
54106 COSA=COS(ALFA)
54107 SINA=SIN(ALFA)
54108 ATRIT=RMSS(16)
54109 ATRIB=RMSS(15)
54110 ATRIL=RMSS(17)
54111 XMUZ=-RMSS(4)
54112
54113 DO 110 I=1,4
54114 DO 100 J=1,4
54115 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
54116 100 CONTINUE
54117 110 CONTINUE
54118 DO 130 I=1,2
54119 DO 120 J=1,2
54120 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
54121 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
54122 120 CONTINUE
54123 130 CONTINUE
54124
54125
54126 IF(IH.EQ.4) GOTO 220
54127
54128C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
54129C...H0_K -> CHI0_I + CHI0_J
54130 EH(2)=SINA
54131 EH(1)=COSA
54132 EH(3)=CBETA
54133 DH(2)=COSA
54134 DH(1)=-SINA
54135 DH(3)=SBETA
54136 DO 150 IJ=1,4
54137 XMJ=SMZ(IJ)
54138 AXMJ=ABS(XMJ)
54139 DO 140 IK=1,IJ
54140 XMK=SMZ(IK)
54141 AXMK=ABS(XMK)
54142 IF(AXMI.GE.AXMJ+AXMK) THEN
54143 LKNT=LKNT+1
54144 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
54145 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
54146 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
54147 & ZMIXC(IJ,3)*ZMIXC(IK,1))
54148 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
54149 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
54150 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
54151 & ZMIXC(IJ,4)*ZMIXC(IK,1))
54152 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
54153 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
54154C...SIGN OF MASSES I,J
54155 XML=XMK*ETAH(IH)
54156 GX2=ABS(F12K)**2+ABS(F21K)**2
54157 GLR=DBLE(F12K*DCONJG(F21K))
54158 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
54159 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
54160 IDLAM(LKNT,1)=KFNCHI(IJ)
54161 IDLAM(LKNT,2)=KFNCHI(IK)
54162 IDLAM(LKNT,3)=0
54163 ENDIF
54164 140 CONTINUE
54165 150 CONTINUE
54166
54167C...H0_K -> CHI+_I CHI-_J
54168 DO 170 IJ=1,2
54169 XMJ=SMW(IJ)
54170 AXMJ=ABS(XMJ)
54171 DO 160 IK=1,2
54172 XMK=SMW(IK)
54173 AXMK=ABS(XMK)
54174 IF(AXMI.GE.AXMJ+AXMK) THEN
54175 LKNT=LKNT+1
54176 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
54177 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
54178 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
54179 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
54180 GX2=ABS(OLPP)**2+ABS(ORPP)**2
54181 GLR=DBLE(OLPP*DCONJG(ORPP))
54182 XML=XMK*ETAH(IH)
54183 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
54184 IDLAM(LKNT,1)=KFCCHI(IJ)
54185 IDLAM(LKNT,2)=-KFCCHI(IK)
54186 IDLAM(LKNT,3)=0
54187 ENDIF
54188 160 CONTINUE
54189 170 CONTINUE
54190
54191C...HIGGS TO SFERMION SFERMION
54192 DO 200 IFL=1,16
54193 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
54194 IJ=KSUSY1+IFL
54195 XMJL=PMAS(PYCOMP(IJ),1)
54196 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
54197 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
54198 XMJ=XMJL
54199 XMJ2=XMJ**2
54200 XL=PYLAMF(XMI2,XMJ2,XMJ2)
54201 XMF=PMAS(IFL,1)
54202 EI=KCHG(IFL,1)/3D0
54203 IDU=2-MOD(IFL,2)
54204
54205 IF(IH.EQ.1) THEN
54206 IF(IDU.EQ.1) THEN
54207 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
54208 & XMF**2/XMW*SINA/CBETA
54209 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
54210 & XMF**2/XMW*SINA/CBETA
54211 IF(IFL.EQ.5) THEN
54212 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
54213 & ATRIB*SINA)
54214 ELSEIF(IFL.EQ.15) THEN
54215 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
54216 & ATRIL*SINA)
54217 ELSE
54218 GHLR=0D0
54219 ENDIF
54220 ELSE
54221 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
54222 & XMF**2/XMW*COSA/SBETA
54223 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
54224 & XMF**2/XMW*COSA/SBETA
54225 IF(IFL.EQ.6) THEN
54226 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
54227 & ATRIT*COSA)
54228 ELSE
54229 GHLR=0D0
54230 ENDIF
54231 ENDIF
54232
54233 ELSEIF(IH.EQ.2) THEN
54234 IF(IDU.EQ.1) THEN
54235 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
54236 & XMF**2/XMW*COSA/CBETA
54237 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
54238 & XMF**2/XMW*COSA/CBETA
54239 IF(IFL.EQ.5) THEN
54240 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
54241 & ATRIB*COSA)
54242 ELSEIF(IFL.EQ.15) THEN
54243 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
54244 & ATRIL*COSA)
54245 ELSE
54246 GHLR=0D0
54247 ENDIF
54248 ELSE
54249 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
54250 & XMF**2/XMW*SINA/SBETA
54251 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
54252 & XMF**2/XMW*SINA/SBETA
54253 IF(IFL.EQ.6) THEN
54254 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
54255 & ATRIT*SINA)
54256 ELSE
54257 GHLR=0D0
54258 ENDIF
54259 ENDIF
54260
54261 ELSEIF(IH.EQ.3) THEN
54262 GHLL=0D0
54263 GHRR=0D0
54264 GHLR=0D0
54265 IF(IDU.EQ.1) THEN
54266 IF(IFL.EQ.5) THEN
54267 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
54268 ELSEIF(IFL.EQ.15) THEN
54269 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
54270 ENDIF
54271 ELSE
54272 IF(IFL.EQ.6) THEN
54273 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
54274 ENDIF
54275 ENDIF
54276 ENDIF
54277 IF(IH.EQ.3) GOTO 180
54278
54279 AL=SFMIX(IFL,1)**2
54280 AR=SFMIX(IFL,2)**2
54281 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
54282 IF(IFL.LE.6) THEN
54283 CF=3D0
54284 ELSE
54285 CF=1D0
54286 ENDIF
54287
54288 IF(AXMI.GE.2D0*XMJ) THEN
54289 LKNT=LKNT+1
54290 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54291 & (GHLL*AL+GHRR*AR
54292 & +2D0*GHLR*ALR)**2
54293 IDLAM(LKNT,1)=IJ
54294 IDLAM(LKNT,2)=-IJ
54295 IDLAM(LKNT,3)=0
54296 ENDIF
54297
54298 IF(AXMI.GE.2D0*XMJR) THEN
54299 LKNT=LKNT+1
54300 AL=SFMIX(IFL,3)**2
54301 AR=SFMIX(IFL,4)**2
54302 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
54303 XMJ=XMJR
54304 XMJ2=XMJ**2
54305 XL=PYLAMF(XMI2,XMJ2,XMJ2)
54306 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54307 & (GHLL*AL+GHRR*AR
54308 & +2D0*GHLR*ALR)**2
54309 IDLAM(LKNT,1)=IJ+KSUSY1
54310 IDLAM(LKNT,2)=-(IJ+KSUSY1)
54311 IDLAM(LKNT,3)=0
54312 ENDIF
54313 180 CONTINUE
54314
54315 IF(AXMI.GE.XMJL+XMJR) THEN
54316 LKNT=LKNT+1
54317 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
54318 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
54319 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
54320 XMJ=XMJR
54321 XMJ2=XMJ**2
54322 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
54323 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54324 & (GHLL*AL+GHRR*AR)**2
54325 IDLAM(LKNT,1)=IJ
54326 IDLAM(LKNT,2)=-(IJ+KSUSY1)
54327 IDLAM(LKNT,3)=0
54328 LKNT=LKNT+1
54329 IDLAM(LKNT,1)=-IJ
54330 IDLAM(LKNT,2)=IJ+KSUSY1
54331 IDLAM(LKNT,3)=0
54332 XLAM(LKNT)=XLAM(LKNT-1)
54333 ENDIF
54334 ENDIF
54335 190 CONTINUE
54336 200 CONTINUE
54337 210 CONTINUE
54338
54339 GOTO 270
54340 220 CONTINUE
54341
54342C...H+ -> CHI+_I + CHI0_J
54343 DO 240 IJ=1,4
54344 XMJ=SMZ(IJ)
54345 AXMJ=ABS(XMJ)
54346 XMJ2=XMJ**2
54347 DO 230 IK=1,2
54348 XMK=SMW(IK)
54349 AXMK=ABS(XMK)
54350 IF(AXMI.GE.AXMJ+AXMK) THEN
54351 LKNT=LKNT+1
54352 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
54353 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
54354 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
54355 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
54356 GX2=ABS(OLPP)**2+ABS(ORPP)**2
54357 GLR=DBLE(OLPP*DCONJG(ORPP))
54358 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
54359 IDLAM(LKNT,1)=KFNCHI(IJ)
54360 IDLAM(LKNT,2)=KFCCHI(IK)
54361 IDLAM(LKNT,3)=0
54362 ENDIF
54363 230 CONTINUE
54364 240 CONTINUE
54365
54366 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
54367 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
54368 AL=0D0
54369 AR=0D0
54370 CF=3D0
54371
54372C...H+ -> T_1 B_1~
54373 XM1=PMAS(PYCOMP(KSUSY1+6),1)
54374 XM2=PMAS(PYCOMP(KSUSY1+5),1)
54375 IF(XMI.GE.XM1+XM2) THEN
54376 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54377 LKNT=LKNT+1
54378 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54379 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
54380 IDLAM(LKNT,1)=KSUSY1+6
54381 IDLAM(LKNT,2)=-(KSUSY1+5)
54382 IDLAM(LKNT,3)=0
54383 ENDIF
54384
54385C...H+ -> T_2 B_1~
54386 XM1=PMAS(PYCOMP(KSUSY2+6),1)
54387 XM2=PMAS(PYCOMP(KSUSY1+5),1)
54388 IF(XMI.GE.XM1+XM2) THEN
54389 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54390 LKNT=LKNT+1
54391 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54392 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
54393 IDLAM(LKNT,1)=KSUSY2+6
54394 IDLAM(LKNT,2)=-(KSUSY1+5)
54395 IDLAM(LKNT,3)=0
54396 ENDIF
54397
54398C...H+ -> T_1 B_2~
54399 XM1=PMAS(PYCOMP(KSUSY1+6),1)
54400 XM2=PMAS(PYCOMP(KSUSY2+5),1)
54401 IF(XMI.GE.XM1+XM2) THEN
54402 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54403 LKNT=LKNT+1
54404 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54405 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
54406 IDLAM(LKNT,1)=KSUSY1+6
54407 IDLAM(LKNT,2)=-(KSUSY2+5)
54408 IDLAM(LKNT,3)=0
54409 ENDIF
54410
54411C...H+ -> T_2 B_2~
54412 XM1=PMAS(PYCOMP(KSUSY2+6),1)
54413 XM2=PMAS(PYCOMP(KSUSY2+5),1)
54414 IF(XMI.GE.XM1+XM2) THEN
54415 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54416 LKNT=LKNT+1
54417 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54418 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
54419 IDLAM(LKNT,1)=KSUSY2+6
54420 IDLAM(LKNT,2)=-(KSUSY2+5)
54421 IDLAM(LKNT,3)=0
54422 ENDIF
54423
54424C...H+ -> UL DL~
54425 GL=-XMW/SR2*SIN(2D0*BETA)
54426 DO 250 IJ=1,3,2
54427 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
54428 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
54429 IF(XMI.GE.XM1+XM2) THEN
54430 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54431 LKNT=LKNT+1
54432 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
54433 IDLAM(LKNT,1)=-(KSUSY1+IJ)
54434 IDLAM(LKNT,2)=KSUSY1+IJ+1
54435 IDLAM(LKNT,3)=0
54436 ENDIF
54437 250 CONTINUE
54438
54439C...H+ -> EL~ NUL
54440 CF=1D0
54441 DO 260 IJ=11,13,2
54442 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
54443 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
54444 IF(XMI.GE.XM1+XM2) THEN
54445 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54446 LKNT=LKNT+1
54447 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
54448 IDLAM(LKNT,1)=-(KSUSY1+IJ)
54449 IDLAM(LKNT,2)=KSUSY1+IJ+1
54450 IDLAM(LKNT,3)=0
54451 ENDIF
54452 260 CONTINUE
54453
54454C...H+ -> TAU1 NUTAUL
54455 XM1=PMAS(PYCOMP(KSUSY1+15),1)
54456 XM2=PMAS(PYCOMP(KSUSY1+16),1)
54457 IF(XMI.GE.XM1+XM2) THEN
54458 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54459 LKNT=LKNT+1
54460 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
54461 IDLAM(LKNT,1)=-(KSUSY1+15)
54462 IDLAM(LKNT,2)= KSUSY1+16
54463 IDLAM(LKNT,3)=0
54464 ENDIF
54465
54466C...H+ -> TAU2 NUTAUL
54467 XM1=PMAS(PYCOMP(KSUSY2+15),1)
54468 XM2=PMAS(PYCOMP(KSUSY1+16),1)
54469 IF(XMI.GE.XM1+XM2) THEN
54470 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54471 LKNT=LKNT+1
54472 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
54473 IDLAM(LKNT,1)=-(KSUSY2+15)
54474 IDLAM(LKNT,2)= KSUSY1+16
54475 IDLAM(LKNT,3)=0
54476 ENDIF
54477
54478 270 CONTINUE
54479 IKNT=LKNT
54480 XLAM(0)=0D0
54481 DO 280 I=1,IKNT
54482 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
54483 XLAM(0)=XLAM(0)+XLAM(I)
54484 280 CONTINUE
54485 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
54486
54487 RETURN
54488 END
54489
54490C*********************************************************************
54491
54492C...PYH2XX
54493C...Calculates the decay rate for a Higgs to an ino pair.
54494
54495 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
54496
54497C...Double precision and integer declarations.
54498 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54499 IMPLICIT INTEGER(I-N)
54500 INTEGER PYK,PYCHGE,PYCOMP
54501C...Commonblocks.
54502 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54503 SAVE /PYDAT1/
54504
54505C...Local variables.
54506 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
54507 DOUBLE PRECISION XL,PYLAMF,C1
54508 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
54509
54510 XMI2=XM1**2
54511 XMI3=ABS(XM1**3)
54512 XMJ2=XM2**2
54513 XMK2=XM3**2
54514 XL=PYLAMF(XMI2,XMJ2,XMK2)
54515 PYH2XX=C1/4D0/XMI3*SQRT(XL)
54516 &*(GX2*(XMI2-XMJ2-XMK2)-
54517 &4D0*GLR*XM3*XM2)
54518 IF(PYH2XX.LT.0D0) PYH2XX=0D0
54519
54520 RETURN
54521 END
54522
54523C*********************************************************************
54524
54525C...PYGAUS
54526C...Integration by adaptive Gaussian quadrature.
54527C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
54528
54529 FUNCTION PYGAUS(F, A, B, EPS)
54530
54531C...Double precision and integer declarations.
54532 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54533 IMPLICIT INTEGER(I-N)
54534 INTEGER PYK,PYCHGE,PYCOMP
54535
54536C...Local declarations.
54537 EXTERNAL F
54538 DOUBLE PRECISION F,W(12), X(12)
54539 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
54540 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
54541 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
54542 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
54543 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
54544 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
54545 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
54546 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
54547 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
54548 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
54549 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
54550 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
54551
54552C...The Gaussian quadrature algorithm.
54553 H = 0D0
54554 IF(B .EQ. A) GOTO 140
54555 CONST = 5D-3 / ABS(B-A)
54556 BB = A
54557 100 CONTINUE
54558 AA = BB
54559 BB = B
54560 110 CONTINUE
54561 C1 = 0.5D0*(BB+AA)
54562 C2 = 0.5D0*(BB-AA)
54563 S8 = 0D0
54564 DO 120 I = 1, 4
54565 U = C2*X(I)
54566 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
54567 120 CONTINUE
54568 S16 = 0D0
54569 DO 130 I = 5, 12
54570 U = C2*X(I)
54571 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
54572 130 CONTINUE
54573 S16 = C2*S16
54574 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
54575 H = H + S16
54576 IF(BB .NE. B) GOTO 100
54577 ELSE
54578 BB = C1
54579 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
54580 H = 0D0
54581 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
54582 GOTO 140
54583 ENDIF
54584 140 CONTINUE
54585 PYGAUS = H
54586
54587 RETURN
54588 END
54589
54590C*********************************************************************
54591
54592C...PYGAU2
54593C...Integration by adaptive Gaussian quadrature.
54594C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
54595C...Carbon copy of PYGAUS, but avoids having to use it recursively.
54596
54597 FUNCTION PYGAU2(F, A, B, EPS)
54598
54599C...Double precision and integer declarations.
54600 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54601 IMPLICIT INTEGER(I-N)
54602 INTEGER PYK,PYCHGE,PYCOMP
54603
54604C...Local declarations.
54605 EXTERNAL F
54606 DOUBLE PRECISION F,W(12), X(12)
54607 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
54608 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
54609 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
54610 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
54611 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
54612 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
54613 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
54614 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
54615 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
54616 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
54617 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
54618 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
54619
54620C...The Gaussian quadrature algorithm.
54621 H = 0D0
54622 IF(B .EQ. A) GOTO 140
54623 CONST = 5D-3 / ABS(B-A)
54624 BB = A
54625 100 CONTINUE
54626 AA = BB
54627 BB = B
54628 110 CONTINUE
54629 C1 = 0.5D0*(BB+AA)
54630 C2 = 0.5D0*(BB-AA)
54631 S8 = 0D0
54632 DO 120 I = 1, 4
54633 U = C2*X(I)
54634 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
54635 120 CONTINUE
54636 S16 = 0D0
54637 DO 130 I = 5, 12
54638 U = C2*X(I)
54639 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
54640 130 CONTINUE
54641 S16 = C2*S16
54642 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
54643 H = H + S16
54644 IF(BB .NE. B) GOTO 100
54645 ELSE
54646 BB = C1
54647 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
54648 H = 0D0
54649 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
54650 GOTO 140
54651 ENDIF
54652 140 CONTINUE
54653 PYGAU2 = H
54654
54655 RETURN
54656 END
54657
54658C*********************************************************************
54659
54660C...PYSIMP
54661C...Simpson formula for an integral.
54662
54663 FUNCTION PYSIMP(Y,X0,X1,N)
54664
54665C...Double precision and integer declarations.
54666 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54667 IMPLICIT INTEGER(I-N)
54668 INTEGER PYK,PYCHGE,PYCOMP
54669
54670C...Local variables.
54671 DOUBLE PRECISION Y,X0,X1,H,S
54672 DIMENSION Y(0:N)
54673
54674 S=0D0
54675 H=(X1-X0)/N
54676 DO 100 I=0,N-2,2
54677 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
54678 100 CONTINUE
54679 PYSIMP=S*H/3D0
54680
54681 RETURN
54682 END
54683
54684C*********************************************************************
54685
54686C...PYLAMF
54687C...The standard lambda function.
54688
54689 FUNCTION PYLAMF(X,Y,Z)
54690
54691C...Double precision and integer declarations.
54692 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54693 IMPLICIT INTEGER(I-N)
54694 INTEGER PYK,PYCHGE,PYCOMP
54695
54696C...Local variables.
54697 DOUBLE PRECISION PYLAMF,X,Y,Z
54698
54699 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
54700 IF(PYLAMF.LT.0D0) PYLAMF=0D0
54701
54702 RETURN
54703 END
54704
54705C*********************************************************************
54706
54707C...PYTBDY
54708C...Generates 3-body decays of gauginos.
54709
54710 SUBROUTINE PYTBDY(IDIN)
54711
54712C...Double precision and integer declarations.
54713 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54714 IMPLICIT INTEGER(I-N)
54715 INTEGER PYK,PYCHGE,PYCOMP
54716C...Parameter statement to help give large particle numbers.
54717 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54718 &KEXCIT=4000000,KDIMEN=5000000)
54719C...Commonblocks.
54720 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54721 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54722 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54723C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54724 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54725 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54726 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54727C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
54728 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYSSMT/
54729
54730C...Local variables.
54731 DOUBLE PRECISION XM(5)
54732 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
54733 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
54734 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
54735 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
54736 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
54737 DOUBLE PRECISION CPHI1,SPHI1
54738 DOUBLE PRECISION S23DEL,EPS
54739 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
54740 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
54741 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
54742 INTEGER INOID(4)
54743 DATA INOID/22,23,25,35/
54744 DATA EPS/1D-6/
54745
54746 ID=IDIN
54747 ISKIP=1
54748 XM(1)=P(N+1,5)
54749 XM(2)=P(N+2,5)
54750 XM(3)=P(N+3,5)
54751 XM(5)=P(ID,5)
54752
54753C...GENERATE S12
54754 S12MIN=(XM(1)+XM(2))**2
54755 S12MAX=(XM(5)-XM(3))**2
54756 YJACO1=S12MAX-S12MIN
54757
54758C...Initialize some parameters
54759 XW=PARU(102)
54760 XW1=1D0-XW
54761 TANW=SQRT(XW/XW1)
54762 IZID1=0
54763 IWID1=0
54764 IZID2=0
54765 IWID2=0
54766
54767 IA=K(N+2,2)
54768 JA=K(N+3,2)
54769
54770C...Mrenna: check that we are indeed decaying a SUSY particle
54771 IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
54772
54773 ELSE
54774 DO 100 I1=1,4
54775 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
54776 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
54777 100 CONTINUE
54778 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
54779 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
54780 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
54781 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
54782 ZM12=XM(5)**2
54783 ZM22=XM(1)**2
54784 EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
54785 T3I=SIGN(1D0,EI+1D-6)/2D0
54786 ENDIF
54787
54788 IF(MSTP(47).EQ.0) THEN
54789 ISKIP=0
54790 ELSEIF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
54791 ISKIP=0
54792 ELSEIF(IZID1*IZID2.NE.0) THEN
54793 SQMZ=PMAS(23,1)**2
54794 GMMZ=PMAS(23,1)*PMAS(23,2)
54795 DO 110 I=1,4
54796 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
54797 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
54798 110 CONTINUE
54799 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
54800 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
54801 ORPP=DCONJG(OLPP)
54802 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
54803 XLR2=XLL2
54804 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
54805 XRL2=XRR2
54806 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
54807 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
54808 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
54809 XM1M2=SMZ(IZID1)*SMZ(IZID2)
54810 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
54811 QLLU=-GLIJ
54812 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
54813 QLRT=DCONJG(GLIJ)
54814 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
54815 QRLT=GRIJ
54816 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
54817 QRRU=-DCONJG(GRIJ)
54818 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
54819 IF(IZID1.NE.0) THEN
54820 XM1M2=SMZ(IZID1)*SMW(IWID2)
54821 IZID1=IWID2
54822 IZID2=IZID1
54823 ELSE
54824 XM1M2=SMZ(IZID2)*SMW(IWID1)
54825 IZID1=IWID1
54826 ENDIF
54827 RT2I = 1D0/SQRT(2D0)
54828 SQMZ=PMAS(24,1)**2
54829 GMMZ=PMAS(24,1)*PMAS(24,2)
54830 DO 120 I=1,2
54831 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54832 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54833 120 CONTINUE
54834 DO 130 I=1,4
54835 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
54836 130 CONTINUE
54837 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
54838 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
54839 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
54840 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
54841 EJ=KCHG(IABS(JA),1)/3D0
54842 T3J=SIGN(1D0,EJ+1D-6)/2D0
54843 QRLS=DCMPLX(0D0,0D0)
54844 QRLT=QRLS
54845 QRRS=QRLS
54846 QRRU=QRLS
54847 XRR2=1D6**2
54848 XRL2=XRR2
54849 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
54850 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
54851 IF(MOD(IA,2).EQ.0) THEN
54852 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
54853 & TANW+ZMIXC(IZID2,2)*T3I)
54854 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54855 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
54856 ELSE
54857 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
54858 & TANW+ZMIXC(IZID2,2)*T3J)
54859 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54860 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
54861 ENDIF
54862 ELSEIF(IWID1*IWID2.NE.0) THEN
54863 IZID1=IWID1
54864 IZID2=IWID2
54865 XM1M2=SMW(IWID1)*SMW(IWID2)
54866 SQMZ=PMAS(23,1)**2
54867 GMMZ=PMAS(23,1)*PMAS(23,2)
54868 DO 140 I=1,2
54869 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54870 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54871 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
54872 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
54873 140 CONTINUE
54874 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
54875 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
54876 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
54877 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
54878 QRLS=-DCMPLX(EI/XW1)*ORPP
54879 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
54880 QRRS=-DCMPLX(EI/XW1)*OLPP
54881 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
54882 IF(MOD(IA,2).EQ.0) THEN
54883 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
54884 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
54885 ELSE
54886 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
54887 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
54888 ENDIF
54889 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
54890 &THEN
54891 ISKIP=0
54892 ELSE
54893 ISKIP=0
54894 ENDIF
54895
54896 IF(ISKIP.NE.0) THEN
54897 WTMAX=0D0
54898 DO 160 KT=1,100
54899 S12=S12MIN+YJACO1*(KT-1)/99
54900 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54901 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54902 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54903 & -(2D0*XM(1)*XM(2))**2
54904 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54905 & -(2D0*XM(3)*XM(5))**2
54906 S23DF1=S23DF1*EPS
54907 S23DF2=S23DF2*EPS
54908 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54909 S23DEL=S23DEL/EPS
54910 S23MIN=S23AVE-S23DEL
54911 S23MAX=S23AVE+S23DEL
54912 YJACO2=S23MAX-S23MIN
54913 TH=S12
54914 DO 150 KS=1,100
54915 S23=S23MIN+YJACO2*(KS-1)/99
54916 SH=S23
54917 UH=ZM12+ZM22-SH-TH
54918 WU2 = (UH-ZM12)*(UH-ZM22)
54919 WT2 = (TH-ZM12)*(TH-ZM22)
54920 WS2 = XM1M2*SH
54921 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54922 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54923 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54924 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54925 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54926 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54927 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54928 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
54929 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54930 IF(WT0.GT.WTMAX) WTMAX=WT0
54931 150 CONTINUE
54932 160 CONTINUE
54933
54934 WTMAX=WTMAX*1.05D0
54935 ENDIF
54936
54937C...FIND S12*
54938 AX=S12MIN
54939 CX=S12MAX
54940 BX=S12MIN+0.5D0*YJACO1
54941 X0=AX
54942 X3=CX
54943 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
54944 X1=BX
54945 X2=BX+C*(CX-BX)
54946 ELSE
54947 X2=BX
54948 X1=BX-C*(BX-AX)
54949 ENDIF
54950
54951C...SOLVE FOR F1 AND F2
54952 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54953 &-(2D0*XM(1)*XM(2))**2
54954 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54955 &-(2D0*XM(3)*XM(5))**2
54956 S23DF1=S23DF1*EPS
54957 S23DF2=S23DF2*EPS
54958 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54959 F1=-2D0*S23DEL/EPS
54960 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54961 &-(2D0*XM(1)*XM(2))**2
54962 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54963 &-(2D0*XM(3)*XM(5))**2
54964 S23DF1=S23DF1*EPS
54965 S23DF2=S23DF2*EPS
54966 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54967 F2=-2D0*S23DEL/EPS
54968
54969 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
54970C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
54971 IF(F2.LE.F1)THEN
54972 X0=X1
54973 X1=X2
54974 X2=R*X1+C*X3
54975 F1=F2
54976 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54977 & -(2D0*XM(1)*XM(2))**2
54978 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54979 & -(2D0*XM(3)*XM(5))**2
54980 S23DF1=S23DF1*EPS
54981 S23DF2=S23DF2*EPS
54982 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54983 F2=-2D0*S23DEL/EPS
54984 ELSE
54985 X3=X2
54986 X2=X1
54987 X1=R*X2+C*X0
54988 F2=F1
54989 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54990 & -(2D0*XM(1)*XM(2))**2
54991 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54992 & -(2D0*XM(3)*XM(5))**2
54993 S23DF1=S23DF1*EPS
54994 S23DF2=S23DF2*EPS
54995 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54996 F1=-2D0*S23DEL/EPS
54997 ENDIF
54998 GOTO 170
54999 ENDIF
55000C...WE WANT THE MAXIMUM, NOT THE MINIMUM
55001 IF(F1.LT.F2)THEN
55002 GOLDEN=-F1
55003 XMIN=X1
55004 ELSE
55005 GOLDEN=-F2
55006 XMIN=X2
55007 ENDIF
55008
55009 IKNT=0
55010 180 S12=S12MIN+PYR(0)*YJACO1
55011 IKNT=IKNT+1
55012C...GENERATE S23
55013 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
55014 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
55015 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
55016 &-(2D0*XM(1)*XM(2))**2
55017 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
55018 &-(2D0*XM(3)*XM(5))**2
55019 S23DF1=S23DF1*EPS
55020 S23DF2=S23DF2*EPS
55021 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
55022 S23DEL=S23DEL/EPS
55023 S23MIN=S23AVE-S23DEL
55024 S23MAX=S23AVE+S23DEL
55025 YJACO2=S23MAX-S23MIN
55026 S23=S23MIN+PYR(0)*YJACO2
55027
55028C...CHECK THE SAMPLING
55029 IF(IKNT.GT.100) THEN
55030 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
55031 GOTO 190
55032 ENDIF
55033 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
55034
55035 IF(ISKIP.EQ.0) GOTO 190
55036
55037 SH=S23
55038 TH=S12
55039 UH=ZM12+ZM22-SH-TH
55040
55041 WU2 = (UH-ZM12)*(UH-ZM22)
55042 WT2 = (TH-ZM12)*(TH-ZM22)
55043 WS2 = XM1M2*SH
55044 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
55045 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
55046
55047 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
55048 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
55049 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
55050 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
55051c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
55052c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
55053c &/DCMPLX(TH-XML2)
55054c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
55055c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
55056c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
55057 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
55058 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
55059 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
55060
55061 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
55062 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
55063
55064 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
55065 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
55066 D2=XM(5)-D1-D3
55067 P1=SQRT(D1*D1-XM(1)**2)
55068 P2=SQRT(D2*D2-XM(2)**2)
55069 P3=SQRT(D3*D3-XM(3)**2)
55070 CTHE1=2D0*PYR(0)-1D0
55071 ANG1=2D0*PYR(0)*PARU(1)
55072 CPHI1=COS(ANG1)
55073 SPHI1=SIN(ANG1)
55074 ARG=1D0-CTHE1**2
55075 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
55076 STHE1=SQRT(ARG)
55077 P(N+1,1)=P1*STHE1*CPHI1
55078 P(N+1,2)=P1*STHE1*SPHI1
55079 P(N+1,3)=P1*CTHE1
55080 P(N+1,4)=D1
55081
55082C...GET CPHI3
55083 ANG3=2D0*PYR(0)*PARU(1)
55084 CPHI3=COS(ANG3)
55085 SPHI3=SIN(ANG3)
55086 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
55087 ARG=1D0-CTHE3**2
55088 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
55089 STHE3=SQRT(ARG)
55090 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
55091 &+P3*STHE3*SPHI3*SPHI1
55092 &+P3*CTHE3*STHE1*CPHI1
55093 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
55094 &-P3*STHE3*SPHI3*CPHI1
55095 &+P3*CTHE3*STHE1*SPHI1
55096 P(N+3,3)=P3*STHE3*CPHI3*STHE1
55097 &+P3*CTHE3*CTHE1
55098 P(N+3,4)=D3
55099
55100 DO 200 I=1,3
55101 P(N+2,I)=-P(N+1,I)-P(N+3,I)
55102 200 CONTINUE
55103 P(N+2,4)=D2
55104
55105 RETURN
55106 END
55107
55108
55109C*********************************************************************
55110
55111C...PYTECM
55112C...Finds the s-hat dependent eigenvalues of the inverse propagator
55113C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
55114C...phase space generation. Extended to include techni-a meson, and
55115C...to return the width.
55116
55117 SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
55118
55119C...Double precision and integer declarations.
55120 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55121 IMPLICIT INTEGER(I-N)
55122 INTEGER PYK,PYCHGE,PYCOMP
55123C...Parameter statement to help give large particle numbers.
55124 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55125 &KEXCIT=4000000,KDIMEN=5000000)
55126C...Commonblocks.
55127 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55128 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55129 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
55130 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
55131 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
55132
55133C...Local variables.
55134 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
55135 &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
55136 &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
55137 INTEGER i,j,ierr
55138
55139 SH=SMIN
55140 SHR=SQRT(SH)
55141 AEM=PYALEM(SH)
55142
55143 SINW=MIN(SQRT(PARU(102)),1D0)
55144 COSW=SQRT(1D0-SINW**2)
55145 TANW=SINW/COSW
55146 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
55147 QUPD=2D0*RTCM(2)-1D0
55148
55149 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
55150 FAR=SQRT(AEM/ALPRHT)
55151 FAO=FAR*QUPD
55152 FZR=FAR*CT2W
55153 FZO=-FAO*TANW
55154 FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
55155 FWR=FAR/(2D0*SINW)
55156 FWX=-FWR/RTCM(47)
55157
55158 DO 110 I=1,5
55159 DO 100 J=1,5
55160 AT(I,J)=0D0
55161 100 CONTINUE
55162 110 CONTINUE
55163
55164C...NC
55165 IF(IOPT.EQ.1) THEN
55166 AR(1,1) = SH
55167 AR(2,2) = SH-PMAS(23,1)**2
55168 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
55169 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
55170 AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
55171 AR(1,2) = 0D0
55172 AR(2,1) = 0D0
55173 AR(1,3) = SH*FAR
55174 AR(3,1) = AR(1,3)
55175 AR(1,4) = SH*FAO
55176 AR(4,1) = AR(1,4)
55177 AR(2,3) = SH*FZR
55178 AR(3,2) = AR(2,3)
55179 AR(2,4) = SH*FZO
55180 AR(4,2) = AR(2,4)
55181 AR(3,4) = 0D0
55182 AR(4,3) = 0D0
55183 AR(2,5) = SH*FZX
55184 AR(5,2) = AR(2,5)
55185 AR(1,5) = 0D0
55186 AR(5,1) = AR(1,5)
55187 AR(3,5) = 0D0
55188 AR(5,3) = AR(3,5)
55189 AR(4,5) = 0D0
55190 AR(5,4) = AR(4,5)
55191 CALL PYWIDT(23,SH,WDTP,WDTE)
55192 AT(2,2) = WDTP(0)*SHR
55193 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
55194 AT(3,3) = WDTP(0)*SHR
55195 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
55196 AT(4,4) = WDTP(0)*SHR
55197 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
55198 AT(5,5) = WDTP(0)*SHR
55199 IDIM=5
55200C...CC
55201 ELSE
55202 AR(1,1) = SH-PMAS(24,1)**2
55203 AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
55204 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
55205 AR(1,2) = SH*FWR
55206 AR(2,1) = AR(1,2)
55207 AR(1,3) = SH*FWX
55208 AR(3,1) = AR(1,3)
55209 AR(2,3) = 0D0
55210 AR(3,2) = 0D0
55211 CALL PYWIDT(24,SH,WDTP,WDTE)
55212 AT(1,1) = WDTP(0)*SHR
55213 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
55214 AT(2,2) = WDTP(0)*SHR
55215 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
55216 AT(3,3) = WDTP(0)*SHR
55217 IDIM=3
55218 ENDIF
55219 CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
55220
55221 IMIN=1
55222 SXMN=1D20
55223 DO 120 I=1,IDIM
55224 WX(I)=SQRT(ABS(SH-WR(I)))
55225 WR(I)=ABS(WR(I))
55226 IF(WR(I).LT.SXMN) THEN
55227 SXMN=WR(I)
55228 IMIN=I
55229 ENDIF
55230 120 CONTINUE
55231 SMOU=WX(IMIN)**2
55232 WIDO=WI(IMIN)/SHR
55233
55234 RETURN
55235 END
55236C*********************************************************************
55237
55238C...PYXDIN
55239C...Universal Extra Dimensions Model (UED)
55240C...Initialize the xd masses and widths
55241C...M. ELKACIMI 4/03/2006
55242C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands
55243
55244 SUBROUTINE PYXDIN
55245
55246C...Double precision and integer declarations.
55247 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55248 IMPLICIT INTEGER(I-N)
55249 INTEGER PYK,PYCHGE,PYCOMP
55250C...Commonblocks.
55251 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55252 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
55253 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
55254C...UED Pythia common
55255 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55256
55257C...SAVE statements
55258 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPUED/
55259
55260C...Print out some info about the UED model
55261 WRITE(MSTU(11),7000)
55262 & ' ',
55263 & '********** PYXDIN: initialization of UED ******************',
55264 & ' ',
55265 & 'Universal Extra Dimensions (UED) switched on ',
55266 & ' ',
55267 & 'This implementation is courtesy of',
55268 & ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ',
55269 & ' see [hep-ph/0602198] (Les Houches 2005) ',
55270 & ' ',
55271 & 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ',
55272 & 'Dobrescu), with gravity-mediated decay widths calculated in',
55273 & '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
55274 & 'radiative corrections to the KK masses from [hep/ph0204342]',
55275 & '(Cheng, Matchev, Schmaltz).'
55276 WRITE(MSTU(11),7000)
55277 & ' ',
55278 & 'SM particles can propagate into one small extra dimension ',
55279 & 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
55280 & 'graviton is further allowed to propagate into N = IUED(4)',
55281 & 'large (eV^-1) extra dimensions.'
55282 WRITE(MSTU(11),7000)
55283 & ' ',
55284 & 'The switches and parameters for UED are:',
55285 & ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
55286 & ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
55287 & ' IUED(3): (D=5) number of quark flavours',
55288 & ' IUED(4): (D=6) number of large extra dimensions into',
55289 & ' which the graviton propagates',
55290 & ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
55291 & ' IUED(6): (D=1) With/without rad.corrs. (=1/0)',
55292 & ' ',
55293 & ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
55294 & ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
55295 & ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
55296 & ' when IUED(5)=0',
55297 & ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
55298 WRITE(MSTU(11),7000)
55299 & ' ',
55300 & 'N.B.: the Higgs mass is also a free parameter of the UED ',
55301 & 'model, but is set through pmas(25,1).',
55302 & ' '
55303
55304C...Hardcoded switch, required by current implementation
55305 CALL PYGIVE('MSTP(42)=0')
55306
55307C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
55308 IF(IUED(2).EQ.0) CALL PYGIVE('MDCY(C5100022,1)=0')
55309
55310C...Calculated the radiative corrections to the KK particle masses
55311 CALL PYUEDC
55312
55313C...Initialize the graviton mass
55314C...only if the KK particles decays gravitationally
55315 IF(IUED(2).EQ.1) CALL PYGRAM(0)
55316
55317 WRITE(MSTU(11),7000)
55318 & '********** PYXDIN: UED initialization completed ***********'
55319
55320C...Format to use for comments
55321 7000 FORMAT(' * ',A)
55322
55323 RETURN
55324 END
55325C*********************************************************************
55326
55327C...PYUEDC
55328C...Auxiliary to PYXDIN
55329C...Mass kk states radiative corrections
55330C...Radiative corrections are included (hep/ph0204342)
55331
55332 SUBROUTINE PYUEDC
55333
55334C...Double precision and integer declarations.
55335 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55336 IMPLICIT INTEGER(I-N)
55337 INTEGER PYK,PYCHGE,PYCOMP
55338
55339 PARAMETER(KKPART=25,KKFLA=450)
55340
55341C...UED Pythia common
55342 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55343C...Pythia common: particles properties
55344 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55345C...Parameters.
55346 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55347C...Decay information.
55348 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
55349C...Resonance width and secondary decay treatment.
55350 COMMON/PYINT4/MWID(500),WIDS(500,5)
55351 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
55352
55353C...Local variables
55354 DOUBLE PRECISION PI,QUP,QDW
55355 DOUBLE PRECISION WDTP,WDTE
55356 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
55357 DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3
55358 DOUBLE PRECISION DSMG2,LOGLAM,DBMG2
55359 DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE
55360 DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2
55361 DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2
55362 DOUBLE PRECISION SWW1,CWW1
55363 DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST
55364 DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE
55365 DOUBLE PRECISION SW21,CW21,SW021,CW021
55366 COMMON/SW1/SW021,CW021
55367C...UED related declarations:
55368C...equivalences between ordered particles (451->475)
55369C...and UED particle code (5 000 000 + id)
55370 DIMENSION IUEDEQ(475)
55371 DATA (IUEDEQ(I),I=451,475)/
55372C...Singlet quarks
55373 & 6100001,6100002,6100003,6100004,6100005,6100006,
55374C...Doublet quarks
55375 & 5100001,5100002,5100003,5100004,5100005,5100006,
55376C...Singlet leptons
55377 & 6100011,6100013,6100015,
55378C...Doublet leptons
55379 & 5100012,5100011,5100014,5100013,5100016,5100015,
55380C...Gauge boson KK excitations
55381 & 5100021,5100022,5100023,5100024/
55382
55383C...N.B. rinv=rued(1)
55384 IF(RUED(1).LE.0.)THEN
55385 WRITE(MSTU(11),*) 'PYUEDC: RINV < 0 : ',RUED(1)
55386 WRITE(MSTU(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
55387 RETURN
55388 ENDIF
55389
55390 PI=DACOS(-1.D0)
55391 RMZ = PMAS(23,1)
55392 RMZ2 = RMZ**2
55393 RMW = PMAS(24,1)
55394 RMW2 = RMW**2
55395 ALPHEM = PARU(101)
55396 QUP = 2./3.
55397 QDW = -1./3.
55398
55399c...qt is q-tilde, qs is q-star
55400c...strong coupling value
55401 Q2 = RUED(1)**2
55402 ALPHS=PYALPS(Q2)
55403
55404c...weak mixing angle
55405 SW2=PARU(102)
55406 CW2=1D0-PARU(102)
55407
55408c...for the mass corrections
55409 RMKK = RUED(1)
55410 RMKK2 = RMKK**2
55411 ZETA3= 1.2
55412
55413C... Either fix the cutoff scale LAMUED
55414 IF(IUED(5).EQ.0)THEN
55415 LOGLAM = DLOG((RUED(3)*(1./RUED(1)))**2)
55416C... or the ratio LAMUED/RINV (=product Lambda*R)
55417 ELSEIF(IUED(5).EQ.1)THEN
55418 LOGLAM = DLOG(RUED(4)**2)
55419 ELSE
55420 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
55421 CALL PYSTOP(6000)
55422 ENDIF
55423
55424C...Calculate the radiative corrections for the UED KK masses
55425 IF(IUED(6).EQ.1)THEN
55426 RFACT=1.D0
55427C...or induce a minute mass difference
55428C...keeping the UED KK mass values nearly equal to 1/R
55429 ELSEIF(IUED(6).EQ.0)THEN
55430 RFACT=0.01D0
55431 ELSE
55432 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
55433 CALL PYSTOP(6001)
55434 ENDIF
55435
55436c...Take into account only the strong interactions:
55437
55438c...The space bulk corrections :
55439 DSMG2 = RMKK2*(-1.5)*(ALPHS/4./PI)*ZETA3/PI**2
55440c...The boundary terms:
55441 DBMG2 = RMKK2*(23./2.)*(ALPHS/4./PI)*LOGLAM
55442
55443c...Mass corrections for fermions are extracted from
55444c...Phys. Rev. D66 036005(2002)9
55445 DBMQDO=RMKK*(3.*(ALPHS/4./PI)+27./16.*(ALPHEM/4./PI/SW2)
55446 . +1./16.*(ALPHEM/4./PI/CW2))*LOGLAM
55447 DBMQU=RMKK*(3.*(ALPHS/4./PI)
55448 . +(ALPHEM/4./PI/CW2))*LOGLAM
55449 DBMQD=RMKK*(3.*(ALPHS/4./PI)
55450 . +0.25*(ALPHEM/4./PI/CW2))*LOGLAM
55451
55452 DBMLDO=RMKK *((27./16.)*(ALPHEM/4./PI/SW2)+9./16.*
55453 . (ALPHEM/4./PI/CW2))*LOGLAM
55454 DBMLE=RMKK *(9./4.*(ALPHEM/4./PI/CW2))*LOGLAM
55455
55456c...Vector boson masss matrix diagonalization
55457 DBMB2 = RMKK2*(-1./6.)*(ALPHEM/4./PI/CW2)*LOGLAM
55458 DSMB2 = RMKK2*(-39./2.)*(ALPHEM/4./PI**3/CW2)*ZETA3
55459 DBMA2 = RMKK2*(15./2.)*(ALPHEM/4./PI/SW2)*LOGLAM
55460 DSMA2 = RMKK2*(-5./2.)*(ALPHEM/4./PI**3/SW2)*ZETA3
55461
55462c...Elements of the mass matrix
55463 A = RMZ2*SW2 + DBMB2 + DSMB2
55464 B = RMZ2*CW2 + DBMA2 + DSMA2
55465 C = RMZ2*DSQRT(SW2*CW2)
55466 SQRDEL = DSQRT( (A-B)**2 + 4*C**2 )
55467
55468c...Eigenvalues: corrections to X1 and Z1 masses
55469 DMB2 = (A+B-SQRDEL)/2.
55470 DMA2 = (A+B+SQRDEL)/2.
55471
55472c...Rotation angles
55473 SWW1 = 2*C
55474 CWW1 = A-B-SQRDEL
55475C...Weinberg angle
55476 SW21= SWW1**2/(SWW1**2 + CWW1**2)
55477 CW21= 1. - SW21
55478
55479 SW021=SW21
55480 CW021=CW21
55481
55482c...Masses:
55483 RMGST = RMKK+RFACT*(DSQRT(RMKK2 + DSMG2 + DBMG2)-RMKK)
55484
55485 RMDQST=RMKK+RFACT*DBMQDO
55486 RMSQUS=RMKK+RFACT*DBMQU
55487 RMSQDS=RMKK+RFACT*DBMQD
55488
55489C...Note: MZ mass is included in ma2
55490 RMPHST= RMKK+RFACT*(DSQRT(RMKK2 + DMB2)-RMKK)
55491 RMZST = RMKK+RFACT*(DSQRT(RMKK2 + DMA2)-RMKK)
55492 RMWST = RMKK+RFACT*(DSQRT(RMKK2 + DBMA2 + DSMA2 + RMW**2)-RMKK)
55493
55494 RMLSLD=RMKK+RFACT*DBMLDO
55495 RMLSLE=RMKK+RFACT*DBMLE
55496
55497 DO 100 IPART=1,5,2
55498 PMAS(KKFLA+IPART,1)=RMSQDS
55499 100 CONTINUE
55500 DO 110 IPART=2,6,2
55501 PMAS(KKFLA+IPART,1)=RMSQUS
55502 110 CONTINUE
55503 DO 120 IPART=7,12
55504 PMAS(KKFLA+IPART,1)=RMDQST
55505 120 CONTINUE
55506 DO 130 IPART=13,15
55507 PMAS(KKFLA+IPART,1)=RMLSLE
55508 130 CONTINUE
55509 DO 140 IPART=16,21
55510 PMAS(KKFLA+IPART,1)=RMLSLD
55511 140 CONTINUE
55512 PMAS(KKFLA+22,1)=RMGST
55513 PMAS(KKFLA+23,1)=RMPHST
55514 PMAS(KKFLA+24,1)=RMZST
55515 PMAS(KKFLA+25,1)=RMWST
55516
55517 WRITE(MSTU(11),7000) ' PYUEDC: ',
55518 & 'UED Mass Spectrum (GeV) :'
55519 WRITE(MSTU(11),7100) ' m(d*_S,s*_S,b*_S) = ',RMSQDS
55520 WRITE(MSTU(11),7100) ' m(u*_S,c*_S,t*_S) = ',RMSQUS
55521 WRITE(MSTU(11),7100) ' m(q*_D) = ',RMDQST
55522 WRITE(MSTU(11),7100) ' m(l*_S) = ',RMLSLE
55523 WRITE(MSTU(11),7100) ' m(l*_D) = ',RMLSLD
55524 WRITE(MSTU(11),7100) ' m(g*) = ',RMGST
55525 WRITE(MSTU(11),7100) ' m(gamma*) = ',RMPHST
55526 WRITE(MSTU(11),7100) ' m(Z*) = ',RMZST
55527 WRITE(MSTU(11),7100) ' m(W*) = ',RMWST
55528 WRITE(MSTU(11),7000) ' '
55529
55530C...Initialize widths, branching ratios and life time
55531 DO 199 IPART=1,25
55532 KC=KKFLA+IPART
55533 IF(MWID(KC).EQ.1.AND.MDCY(KC,1).EQ.1)THEN
55534 CALL PYWIDT(IUEDEQ(KC),PMAS(KC,1)**2,WDTP,WDTE)
55535 IF(WDTP(0).LE.0)THEN
55536 WRITE(MSTU(11),*)
55537 + 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', KC
55538 WRITE(MSTU(11),*) 'INITIAL VALUE IS TAKEN',PMAS(KC,2)
55539 GOTO 199
55540 ELSE
55541 DO 180 IDC=1,MDCY(KC,3)
55542 IC=IDC+MDCY(KC,2)-1
55543 IF(MDME(IC,1).EQ.1.AND.WDTP(IDC).GT.0.)THEN
55544C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm
55545 PMAS(KC,4)=PARU(3)/WDTP(IDC)*1.D-12
55546 BRAT(IC)=WDTP(IDC)/WDTP(0)
55547 ENDIF
55548 180 CONTINUE
55549 ENDIF
55550 ENDIF
55551 199 CONTINUE
55552
55553C...Format to use for comments
55554 7000 FORMAT(' * ',A)
55555 7100 FORMAT(' * ',A,F12.3)
55556
55557 END
55558C********************************************************************
55559C...PYXUED
55560C... Last change:
55561C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
55562C... Original version:
55563C... M. El Kacimi
55564C... 05/07/2005
55565C Universal Extra Dimensions Subprocess cross sections
55566C The expressions used are from atl-com-phys-2005-003
55567C What is coded here is shat**2/pi * dsigma/dt = |M|**2
55568C For each UED subprocess, the color flow used is the same
55569C as the equivalent QCD subprocess. Different configuration
55570C color flows are considered to have the same probability.
55571C
55572C The Xsection is calculated following ATL-PHYS-PUB-2005-003
55573C by G.Azuelos and P.H.Beauchemin.
55574C
55575C This routine is called from pysigh.
55576
55577 SUBROUTINE PYXUED(NCHN,SIGS)
55578
55579C...Double precision and integer declarations
55580 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55581 IMPLICIT INTEGER(I-N)
55582C...
55583 INTEGER NGRDEC
55584 COMMON/DECMOD/NGRDEC
55585C...
55586 PARAMETER(KKPART=25,KKFLA=450)
55587C...Commonblocks
55588 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55589 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
55590 COMMON/PYINT1/MINT(400),VINT(400)
55591 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
55592 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
55593 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
55594 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
55595 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
55596 SAVE /PYDAT2/,/PYINT1/,/PYINT3/,/PYPARS/
55597C...UED Pythia common
55598 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55599C...Local arrays and complex variables
55600 DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS
55601 + ,FAC1,XMNKK,XMUED,SIGS
55602 INTEGER NCHN
55603
55604C...Return if UED not switched on
55605 IF (IUED(1).LE.0) THEN
55606 RETURN
55607 ENDIF
55608
55609C...Energy scale of the parton processus
55610C...taken equal to the mass of the final state kk
55611c Q2=XMNKK**2
55612
55613C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
55614 XMNKK=PMAS(KKFLA+23,1)
55615
55616C...To compare the cross section with phys-pub-2005-03
55617C...(no radiative corrections),
55618C...take xmnkk=rinv and q2=rinv**2
55619c++lnk
55620C...n.b. (rinv=rued(1))
55621c IF(NGRDEC.EQ.1)XMNKK=RUED(0)
55622 IF(NGRDEC.EQ.1)XMNKK=RUED(1)
55623c--lnk
55624
55625 SHAT=VINT(44)
55626 SP=SHAT
55627 THAT=VINT(45)
55628 TP=THAT-XMNKK**2
55629 UHAT=VINT(46)
55630 UP=UHAT-XMNKK**2
55631 BETA34=DSQRT(1.D0-4.D0*XMNKK**2/SHAT)
55632 PI=DACOS(-1.D0)
55633c++lnk
55634c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
55635 Q2=RUED(1)**2+(TP*UP-RUED(1)**4)/SP
55636
55637c IF(NGRDEC.EQ.1)Q2=RUED(0)**2
55638 IF(NGRDEC.EQ.1)Q2=RUED(1)**2
55639c--lnk
55640
55641C...Strong coupling value
55642 ALPHAS=PYALPS(Q2)
55643
55644 IF(ISUB.EQ.311)THEN
55645C...gg --> g* g*
55646 FAC1=9./8.*ALPHAS**2/(SP*TP*UP)**2
55647 XMUED=FAC1*(XMNKK**4*(6.*TP**4+18.*TP**3*UP+
55648 & 24.*TP**2*UP**2+18.*TP*UP**3+6.*UP**4)
55649 & +XMNKK**2*(6.*TP**4*UP+12.*TP**3*UP**2+
55650 & 12.*TP**2*UP**3+6*TP*UP**4)
55651 & +2.*TP**6+6*TP**5*UP+13*TP**4*UP**2+
55652 & 15.*TP**3*UP**3+13*TP**2*UP**4+
55653 & 6.*TP*UP**5+2.*UP**6)
55654 NCHN=NCHN+1
55655 ISIG(NCHN,1)=21
55656 ISIG(NCHN,2)=21
55657C...Three color flow configurations (qcd g+g->g+g)
55658 XCOL=PYR(0)
55659 IF(XCOL.LE.1./3.)THEN
55660 ISIG(NCHN,3)=1
55661 ELSEIF(XCOL.LE.2./3.)THEN
55662 ISIG(NCHN,3)=2
55663 ELSE
55664 ISIG(NCHN,3)=3
55665 ENDIF
55666 SIGH(NCHN)=COMFAC*XMUED
55667 ELSEIF(ISUB.EQ.312)THEN
55668C...q + g -> q*_D + g*, q*_S + g*
55669C...(the two channels have the same cross section)
55670 FAC1=-1./36.*ALPHAS**2/(SP*TP*UP)**2
55671 XMUED=FAC1*(12.*SP*UP**5+5.*SP**2*UP**4+22.*SP**3*UP**3+
55672 & 5.*SP**4*UP**2+12.*SP**5*UP)
55673 XMUED=COMFAC*2.*XMUED
55674
55675 DO 190 I=MMINA,MMAXA
55676 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
55677 DO 180 ISDE=1,2
55678
55679 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
55680 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
55681 NCHN=NCHN+1
55682 ISIG(NCHN,ISDE)=I
55683 ISIG(NCHN,3-ISDE)=21
55684 ISIG(NCHN,3)=1
55685 SIGH(NCHN)=XMUED
55686 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
55687 180 CONTINUE
55688 190 CONTINUE
55689
55690 ELSEIF(ISUB.EQ.313)THEN
55691C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj
55692C...(the two channels have the same cross section)
55693C...qi and qj have the same charge sign
55694 DO 100 I=MMIN1,MMAX1
55695 IA=IABS(I)
55696 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 100
55697 DO 101 J=MMIN2,MMAX2
55698 JA=IABS(J)
55699 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).
55700 & EQ.0) GOTO 101
55701 IF(J*I.LE.0)GOTO 101
55702 NCHN=NCHN+1
55703 ISIG(NCHN,1)=I
55704 ISIG(NCHN,2)=J
55705 IF(J.EQ.I)THEN
55706 FAC1=1./72.*ALPHAS**2/(TP*UP)**2
55707 XMUED=FAC1*
55708 & (XMNKK**2*(8*TP**3+4./3.*TP**2*UP+4./3.*TP*UP**2
55709 & +8.*UP**3)+8.*TP**4+56./3.*TP**3*UP+
55710 & 20.*TP**2*UP**2+56./3.*
55711 & TP*UP**3+8.*UP**4)
55712 SIGH(NCHN)=COMFAC*2.*XMUED
55713 ISIG(NCHN,3)=1
55714 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
55715 ELSE
55716 FAC1=2./9.*ALPHAS**2/TP**2
55717 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
55718 SIGH(NCHN)=COMFAC*2.*XMUED
55719 ISIG(NCHN,3)=1
55720 ENDIF
55721 101 CONTINUE
55722 100 CONTINUE
55723 ELSEIF(ISUB.EQ.314)THEN
55724C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
55725C...(the two channels have the same cross section)
55726 NCHN=NCHN+1
55727 ISIG(NCHN,1)=21
55728 ISIG(NCHN,2)=21
55729 ISIG(NCHN,3)=INT(1.5+PYR(0))
55730
55731 FAC1=5./6.*ALPHAS**2/(SP*TP*UP)**2
55732 XMUED=FAC1*(-XMNKK**4*(8.*TP*UP**3+8.*TP**2*UP**2+8.*TP**3*UP
55733 + +4.*UP**4+4*TP**4)
55734 + -XMNKK**2*(0.5*TP*UP**4+4.*TP**2*UP**3+15./2.*TP**3
55735 + *UP**2+ 4.*TP**4*UP)+TP*UP**5-0.25*TP**2*UP**4+
55736 + 2.*TP**3*UP**3-0.25*TP**4*UP**2+TP**5*UP)
55737
55738 SIGH(NCHN)=COMFAC*XMUED
55739C...has been multiplied by 5: all possible quark flavors in final state
55740
55741 ELSEIF(ISUB.EQ.315)THEN
55742C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
55743C...(the two channels have the same cross section)
55744 DO 141 I=MMIN1,MMAX1
55745 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
55746 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 141
55747 DO 142 J=MMIN2,MMAX2
55748 IF(J.EQ.0.OR.ABS(I).NE.ABS(J).OR.I*J.GE.0) GOTO 142
55749 FAC1=2./9.*ALPHAS**2*1./(SP*TP)**2
55750 XMUED=FAC1*(XMNKK**2*SP*(4.*TP**2-SP*TP-SP**2)+
55751 & 4.*TP**4+3.*SP*TP**3+11./12.*TP**2*SP**2-
55752 & 2./3.*SP**3*TP+SP**4)
55753 NCHN=NCHN+1
55754 ISIG(NCHN,1)=I
55755 ISIG(NCHN,2)=-I
55756 ISIG(NCHN,3)=1
55757 SIGH(NCHN)=COMFAC*2.*XMUED
55758 142 CONTINUE
55759 141 CONTINUE
55760 ELSEIF(ISUB.EQ.316)THEN
55761C...q + qbar' -> q*_D + q*_Sbar'
55762 FAC1=2./9.*ALPHAS**2
55763 DO 300 I=MMIN1,MMAX1
55764 IA=IABS(I)
55765 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 300
55766 DO 301 J=MMIN2,MMAX2
55767 JA=IABS(J)
55768 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 301
55769 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 301
55770 NCHN=NCHN+1
55771 ISIG(NCHN,1)=I
55772 ISIG(NCHN,2)=J
55773 ISIG(NCHN,3)=1
55774 FAC1=2./9.*ALPHAS**2/TP**2
55775 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
55776 SIGH(NCHN)=COMFAC*XMUED
55777 301 CONTINUE
55778 300 CONTINUE
55779
55780 ELSEIF(ISUB.EQ.317)THEN
55781C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar'
55782C...(the two channels have the same cross section)
55783 DO 400 I=MMIN1,MMAX1
55784 IA=IABS(I)
55785 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 400
55786 DO 401 J=MMIN1,MMAX1
55787 JA=IABS(J)
55788 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 401
55789 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 401
55790 NCHN=NCHN+1
55791 ISIG(NCHN,1)=I
55792 ISIG(NCHN,2)=J
55793 ISIG(NCHN,3)=1
55794 FAC1=1./18.*ALPHAS**2/TP**2
55795 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
55796 SIGH(NCHN)=COMFAC*2.*XMUED
55797 401 CONTINUE
55798 400 CONTINUE
55799 ELSEIF(ISUB.EQ.318)THEN
55800C...q + q' -> q*_D + q*_S'
55801 DO 500 I=MMIN1,MMAX1
55802 IA=IABS(I)
55803 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 500
55804 DO 501 J=MMIN2,MMAX2
55805 JA=IABS(J)
55806 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 501
55807 IF(J*I.LE.0)GOTO 501
55808 IF(IA.EQ.JA)THEN
55809 NCHN=NCHN+1
55810 ISIG(NCHN,1)=I
55811 ISIG(NCHN,2)=J
55812 ISIG(NCHN,3)=INT(1.5+PYR(0))
55813 FAC1=1./36.*ALPHAS**2/(TP*UP)**2
55814 XMUED=FAC1*(-8.*XMNKK**2*(TP**3+TP**2*UP+TP*UP**2+UP**3)
55815 & +8.*TP**4+4.*TP**2*UP**2+8.*UP**4)
55816 SIGH(NCHN)=COMFAC*XMUED
55817 ELSE
55818 NCHN=NCHN+1
55819 ISIG(NCHN,1)=I
55820 ISIG(NCHN,2)=J
55821 ISIG(NCHN,3)=1
55822 FAC1=1./18.*ALPHAS**2/TP**2
55823 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
55824 SIGH(NCHN)=COMFAC*2.*XMUED
55825 ENDIF
55826 501 CONTINUE
55827 500 CONTINUE
55828 ELSEIF(ISUB.EQ.319)THEN
55829C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
55830C...(the two channels have the same cross section)
55831 DO 741 I=MMIN1,MMAX1
55832 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
55833 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 741
55834 DO 742 J=MMIN2,MMAX2
55835 IF(J.EQ.0.OR.IABS(J).NE.IABS(I).OR.J*I.GT.0) GOTO 742
55836 FAC1=16./9.*ALPHAS**2*1./(SP)**2
55837 XMUED=FAC1*(2.*XMNKK**2*SP+SP**2+2.*SP*TP+2.*TP**2)
55838 NCHN=NCHN+1
55839 ISIG(NCHN,1)=I
55840 ISIG(NCHN,2)=-I
55841 ISIG(NCHN,3)=1
55842 SIGH(NCHN)=COMFAC*2.*XMUED
55843 742 CONTINUE
55844 741 CONTINUE
55845
55846 ENDIF
55847
55848 RETURN
55849 END
55850C*********************************************************************
55851
55852C...PYGRAM
55853C...Universal Extra Dimensions Model (UED)
55854C...Computation of the Graviton mass.
55855
55856 SUBROUTINE PYGRAM(IN)
55857
55858C...Double precision and integer declarations
55859 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55860 IMPLICIT INTEGER(I-N)
55861
55862C...Pythia commonblocks
55863 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55864 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55865C...UED Pythia common
55866 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55867
55868C...Local variables
55869 INTEGER KCFLA,NMAX
55870 PARAMETER(KCFLA=450,NMAX=5000)
55871 DIMENSION YVEC(5000),RESVEC(5000)
55872 COMMON/INTSAV/YSAV,YMAX,RESMAX
55873 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55874 COMMON/KAPPA/XKAPPA
55875
55876C...External function (used in call to PYGAUS)
55877 EXTERNAL PYGRAW
55878
55879C...SAVE statements
55880 SAVE /PYDAT1/,/PYDAT2/,/PYPUED/,/INTSAV/
55881
55882C...Initialization
55883 NDIM=IUED(4)
55884 RINV=RUED(1)
55885 XMD=RUED(2)
55886 PI=PARU(1)
55887
55888C...Initialize for numerical integration
55889 XMPLNK=2.4D+18
55890 XKAPPA=DSQRT(2.D0)/XMPLNK
55891
55892C...For NDIM=2, compute graviton mass distribution numerically
55893 IF(NDIM.EQ.2)THEN
55894
55895C... For first event: tabulate distribution of stepwise integrals:
55896C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
55897 IF(IN.EQ.0)THEN
55898 RESMAX = 0D0
55899 YMAX = 0D0
55900 DO 100 I=1,NMAX
55901 YSAV = (I-0.5)/DBLE(NMAX)
55902 TOL = 1D-6
55903C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
55904 RESINT = PYGAUS(PYGRAW,0D0,1D0,TOL)
55905 YVEC(I) = YSAV
55906 RESVEC(I) = RESINT
55907C... Save max of distribution (for accept/reject below)
55908 IF(RESINT.GT.RESMAX)THEN
55909 RESMAX = RESINT
55910 YMAX = YVEC(I)
55911 ENDIF
55912 100 CONTINUE
55913 ENDIF
55914
55915C... Generate Mg for each graviton (1D0 ensures a minimal open phase space)
55916 PCUJET=1D0
55917 KCGAKK=KCFLA+23
55918 XMGAMK=PMAS(KCGAKK,1)
55919
55920C... Pick random graviton mass, accept according to stored integrals
55921 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55922 110 RMG=AMMAX*PYR(0)
55923 X=RMG/XMGAMK
55924
55925C... Bin enumeration starts at 1, but make sure always in range
55926 IBIN=INT(NMAX*X)+1
55927 IBIN=MIN(IBIN,NMAX)
55928 IF(RESVEC(IBIN)/RESMAX.LT.PYR(0)) GOTO 110
55929
55930C... For NDIM=4 and 6, the analytical expression for the
55931C... graviton mass distribution integral is used.
55932 ELSEIF(NDIM.EQ.4.OR.NDIM.EQ.6)THEN
55933
55934C... Ensure minimal open phase space (max(mG*) < m(gamma*))
55935 PCUJET=1D0
55936
55937C... KK photon (?) compressed code and mass
55938 KCGAKK=KCFLA+23
55939 XMGAMK=PMAS(KCGAKK,1)
55940
55941C... Find maximum of (dGamma/dMg)
55942 IF(IN.EQ.0)THEN
55943 RESMAX=0D0
55944 YMAX=0D0
55945 DO 120 I=1,NMAX-1
55946 Y=I/DBLE(NMAX)
55947 RESINT=Y**(NDIM-3)*(1D0/(1D0-Y**2))*(1D0+DCOS(PI*Y))
55948 IF(RESINT.GE.RESMAX)THEN
55949 RESMAX=RESINT
55950 YMAX=Y
55951 ENDIF
55952 120 CONTINUE
55953 ENDIF
55954
55955C... Pick random graviton mass, accept/reject
55956 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55957 130 RMG=AMMAX*PYR(0)
55958 X=RMG/XMGAMK
55959 DGADMG=X**(NDIM-3)*(1./(1.-X**2))*(1.+DCOS(PI*X))
55960 IF(DGADMG/RESMAX.LT.PYR(0)) GOTO 130
55961
55962C... If the user has not chosen N=2,4 or 6, STOP
55963 ELSE
55964 WRITE(MSTU(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',NDIM,
55965 & ' (MUST BE 2, 4, OR 6) '
55966 CALL PYSTOP(6002)
55967 ENDIF
55968
55969C... Now store the sampled Mg
55970 PMAS(39,1)=RMG
55971
55972 RETURN
55973 END
55974
55975C*********************************************************************
55976
55977C...PYGRAW
55978C...Universal Extra Dimensions Model (UED)
55979C...
55980C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
55981C...
55982C...Integrand for the KK boson -> SM boson + graviton
55983C...graviton mass distribution (and gravity mediated total width),
55984C...which contains (see 0201300 and below for the full product)
55985C...the gravity mediated partial decay width Gamma(xx, yy)
55986C... i.e. GRADEN(YY)*PYWDKK(XXA)
55987C... where xx is exclusive to gravity
55988C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55989C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.
55990
55991 DOUBLE PRECISION FUNCTION PYGRAW(YIN)
55992
55993C...Double precision and integer declarations
55994 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55995 IMPLICIT INTEGER (I-N)
55996
55997C...Pythia commonblocks
55998 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55999
56000C...Local UED commonblocks and variables
56001 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
56002 COMMON/INTSAV/YSAV,YMAX,RESMAX
56003
56004C...SAVE statements
56005 SAVE /PYDAT1/,/INTSAV/
56006
56007C...External: Pythia's Gamma function
56008 EXTERNAL PYGAMM
56009
56010C...Pi
56011 PI=PARU(1)
56012 PI2=PI*PI
56013
56014 YMIN=1.D-9/RINV
56015 YY=YSAV
56016 XX=DSQRT(1.-YY**2)*YIN
56017 DJAC=(1.-YMIN)*DSQRT(1.-YY**2)
56018 FAC=2.*PI**((NDIM-1.)/2.)*XMPLNK**2*RINV**NDIM/XMD**(NDIM+2)
56019 XND=(NDIM-1.)/2.
56020 GAMMN=PYGAMM(XND)
56021 FAC=FAC/GAMMN
56022 XXA=DSQRT(XX**2+YY**2)
56023 GRADEN=4./PI2 * (YY**2/(1.-YY**2)**2)*(1.+DCOS(PI*YY))
56024
56025 PYGRAW=DJAC*
56026 + FAC*XX**(NDIM-2)*GRADEN*PYWDKK(XXA)
56027
56028 RETURN
56029 END
56030C*********************************************************************
56031
56032C...PYWDKK
56033C...Universal Extra Dimensions Model (UED)
56034C...
56035C...Multiplied by the square modulus of a form factor
56036C...(see GRADEN in function PYGRAW)
56037C...PYWDKK is the KK boson -> SM boson + graviton
56038C...gravity mediated partial decay width Gamma(xx, yy)
56039C... where xx is exclusive to gravity
56040C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
56041C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
56042C...
56043C...N.B. The Feynman rules for the couplings of the graviton fields
56044C...to the UED fields are related to the corresponding couplings of
56045C...the graviton fields to the SM fields by the form factor.
56046
56047 DOUBLE PRECISION FUNCTION PYWDKK(X)
56048
56049C...Double precision and integer declarations
56050 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
56051 IMPLICIT INTEGER (I-N)
56052
56053C...Pythia commonblocks
56054 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56055 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56056
56057C...Local UED commonblocks and variables
56058 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
56059 COMMON/KAPPA/XKAPPA
56060
56061C...SAVE statements
56062 SAVE /PYDAT1/,/PYDAT2/,/UEDGRA/,/KAPPA/
56063
56064 PI=PARU(1)
56065
56066C...gamma* mass 473
56067 KCQKK=473
56068 XMNKK=PMAS(KCQKK,1)
56069
56070C...Bosons partial width Macesanu hep-ph/0201300
56071 PYWDKK=XKAPPA**2/(96.*PI)*XMNKK**3/X**4*
56072 + ((1.-X**2)**2*(1.+3.*X**2+6.*X**4))
56073
56074 RETURN
56075 END
56076
56077C*********************************************************************
56078
56079C...PYEIGC
56080C...Finds eigenvalues of a general complex matrix
56081C
56082C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
56083C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
56084C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
56085C OF A COMPLEX GENERAL MATRIX.
56086C
56087C ON INPUT
56088C
56089C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
56090C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56091C DIMENSION STATEMENT.
56092C
56093C N IS THE ORDER OF THE MATRIX A=(AR,AI).
56094C
56095C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56096C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
56097C
56098C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
56099C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
56100C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
56101C
56102C ON OUTPUT
56103C
56104C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
56105C RESPECTIVELY, OF THE EIGENVALUES.
56106C
56107C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56108C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
56109C
56110C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
56111C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
56112C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
56113C
56114C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
56115C
56116C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56117C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56118C
56119C THIS VERSION DATED AUGUST 1983.
56120C
56121
56122 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
56123
56124 INTEGER N,NM,IS1,IS2,IERR,MATZ
56125 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
56126 X FV1(5),FV2(5),FV3(5)
56127 IF (N .LE. NM) GOTO 100
56128 IERR = 10 * N
56129 GOTO 120
56130C
56131 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
56132 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
56133 IF (MATZ .NE. 0) GOTO 110
56134C .......... FIND EIGENVALUES ONLY ..........
56135 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
56136 GOTO 120
56137C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
56138 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
56139 IF (IERR .NE. 0) GOTO 120
56140 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
56141 120 RETURN
56142 END
56143
56144C*********************************************************************
56145
56146C...PYCMQR
56147C...Auxiliary to PYEICG.
56148C
56149C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
56150C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
56151C AND WILKINSON.
56152C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
56153C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
56154C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
56155C
56156C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
56157C UPPER HESSENBERG MATRIX BY THE QR METHOD.
56158C
56159C ON INPUT
56160C
56161C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56162C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56163C DIMENSION STATEMENT.
56164C
56165C N IS THE ORDER OF THE MATRIX.
56166C
56167C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56168C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56169C SET LOW=1, IGH=N.
56170C
56171C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
56172C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
56173C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
56174C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
56175C THE REDUCTION BY CORTH, IF PERFORMED.
56176C
56177C ON OUTPUT
56178C
56179C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
56180C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
56181C CALLING COMQR IF SUBSEQUENT CALCULATION OF
56182C EIGENVECTORS IS TO BE PERFORMED.
56183C
56184C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
56185C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
56186C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
56187C FOR INDICES IERR+1,...,N.
56188C
56189C IERR IS SET TO
56190C ZERO FOR NORMAL RETURN,
56191C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
56192C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
56193C
56194C CALLS PYCDIV FOR COMPLEX DIVISION.
56195C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
56196C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56197C
56198C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56199C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56200C
56201C THIS VERSION DATED AUGUST 1983.
56202C
56203
56204 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
56205
56206 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
56207 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
56208 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
56209 X PYTHAG
56210
56211 IERR = 0
56212 IF (LOW .EQ. IGH) GOTO 130
56213C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
56214 L = LOW + 1
56215C
56216 DO 120 I = L, IGH
56217 LL = MIN0(I+1,IGH)
56218 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
56219 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
56220 YR = HR(I,I-1) / NORM
56221 YI = HI(I,I-1) / NORM
56222 HR(I,I-1) = NORM
56223 HI(I,I-1) = 0.0D0
56224C
56225 DO 100 J = I, IGH
56226 SI = YR * HI(I,J) - YI * HR(I,J)
56227 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
56228 HI(I,J) = SI
56229 100 CONTINUE
56230C
56231 DO 110 J = LOW, LL
56232 SI = YR * HI(J,I) + YI * HR(J,I)
56233 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
56234 HI(J,I) = SI
56235 110 CONTINUE
56236C
56237 120 CONTINUE
56238C .......... STORE ROOTS ISOLATED BY CBAL ..........
56239 130 DO 140 I = 1, N
56240 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
56241 WR(I) = HR(I,I)
56242 WI(I) = HI(I,I)
56243 140 CONTINUE
56244C
56245 EN = IGH
56246 TR = 0.0D0
56247 TI = 0.0D0
56248 ITN = 30*N
56249C .......... SEARCH FOR NEXT EIGENVALUE ..........
56250 150 IF (EN .LT. LOW) GOTO 320
56251 ITS = 0
56252 ENM1 = EN - 1
56253C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
56254C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
56255 160 DO 170 LL = LOW, EN
56256 L = EN + LOW - LL
56257 IF (L .EQ. LOW) GOTO 180
56258 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
56259 X + DABS(HR(L,L)) + DABS(HI(L,L))
56260 TST2 = TST1 + DABS(HR(L,L-1))
56261 IF (TST2 .EQ. TST1) GOTO 180
56262 170 CONTINUE
56263C .......... FORM SHIFT ..........
56264 180 IF (L .EQ. EN) GOTO 300
56265 IF (ITN .EQ. 0) GOTO 310
56266 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
56267 SR = HR(EN,EN)
56268 SI = HI(EN,EN)
56269 XR = HR(ENM1,EN) * HR(EN,ENM1)
56270 XI = HI(ENM1,EN) * HR(EN,ENM1)
56271 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
56272 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
56273 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
56274 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
56275 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
56276 ZZR = -ZZR
56277 ZZI = -ZZI
56278 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
56279 SR = SR - XR
56280 SI = SI - XI
56281 GOTO 210
56282C .......... FORM EXCEPTIONAL SHIFT ..........
56283 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
56284 SI = 0.0D0
56285C
56286 210 DO 220 I = LOW, EN
56287 HR(I,I) = HR(I,I) - SR
56288 HI(I,I) = HI(I,I) - SI
56289 220 CONTINUE
56290C
56291 TR = TR + SR
56292 TI = TI + SI
56293 ITS = ITS + 1
56294 ITN = ITN - 1
56295C .......... REDUCE TO TRIANGLE (ROWS) ..........
56296 LP1 = L + 1
56297C
56298 DO 240 I = LP1, EN
56299 SR = HR(I,I-1)
56300 HR(I,I-1) = 0.0D0
56301 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
56302 XR = HR(I-1,I-1) / NORM
56303 WR(I-1) = XR
56304 XI = HI(I-1,I-1) / NORM
56305 WI(I-1) = XI
56306 HR(I-1,I-1) = NORM
56307 HI(I-1,I-1) = 0.0D0
56308 HI(I,I-1) = SR / NORM
56309C
56310 DO 230 J = I, EN
56311 YR = HR(I-1,J)
56312 YI = HI(I-1,J)
56313 ZZR = HR(I,J)
56314 ZZI = HI(I,J)
56315 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
56316 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
56317 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
56318 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
56319 230 CONTINUE
56320C
56321 240 CONTINUE
56322C
56323 SI = HI(EN,EN)
56324 IF (SI .EQ. 0.0D0) GOTO 250
56325 NORM = PYTHAG(HR(EN,EN),SI)
56326 SR = HR(EN,EN) / NORM
56327 SI = SI / NORM
56328 HR(EN,EN) = NORM
56329 HI(EN,EN) = 0.0D0
56330C .......... INVERSE OPERATION (COLUMNS) ..........
56331 250 DO 280 J = LP1, EN
56332 XR = WR(J-1)
56333 XI = WI(J-1)
56334C
56335 DO 270 I = L, J
56336 YR = HR(I,J-1)
56337 YI = 0.0D0
56338 ZZR = HR(I,J)
56339 ZZI = HI(I,J)
56340 IF (I .EQ. J) GOTO 260
56341 YI = HI(I,J-1)
56342 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
56343 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
56344 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
56345 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
56346 270 CONTINUE
56347C
56348 280 CONTINUE
56349C
56350 IF (SI .EQ. 0.0D0) GOTO 160
56351C
56352 DO 290 I = L, EN
56353 YR = HR(I,EN)
56354 YI = HI(I,EN)
56355 HR(I,EN) = SR * YR - SI * YI
56356 HI(I,EN) = SR * YI + SI * YR
56357 290 CONTINUE
56358C
56359 GOTO 160
56360C .......... A ROOT FOUND ..........
56361 300 WR(EN) = HR(EN,EN) + TR
56362 WI(EN) = HI(EN,EN) + TI
56363 EN = ENM1
56364 GOTO 150
56365C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
56366C CONVERGED AFTER 30*N ITERATIONS ..........
56367 310 IERR = EN
56368 320 RETURN
56369 END
56370
56371C*********************************************************************
56372
56373C...PYCMQ2
56374C...Auxiliary to PYEICG.
56375C
56376C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
56377C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
56378C AND WILKINSON.
56379C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
56380C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
56381C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
56382C
56383C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
56384C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
56385C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
56386C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
56387C THIS GENERAL MATRIX TO HESSENBERG FORM.
56388C
56389C ON INPUT
56390C
56391C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56392C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56393C DIMENSION STATEMENT.
56394C
56395C N IS THE ORDER OF THE MATRIX.
56396C
56397C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56398C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56399C SET LOW=1, IGH=N.
56400C
56401C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
56402C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
56403C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
56404C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
56405C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
56406C
56407C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
56408C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
56409C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
56410C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
56411C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
56412C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
56413C ARBITRARY.
56414C
56415C ON OUTPUT
56416C
56417C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
56418C HAVE BEEN DESTROYED.
56419C
56420C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
56421C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
56422C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
56423C FOR INDICES IERR+1,...,N.
56424C
56425C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56426C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
56427C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
56428C THE EIGENVECTORS HAS BEEN FOUND.
56429C
56430C IERR IS SET TO
56431C ZERO FOR NORMAL RETURN,
56432C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
56433C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
56434C
56435C CALLS PYCDIV FOR COMPLEX DIVISION.
56436C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
56437C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56438C
56439C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56440C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56441C
56442C THIS VERSION DATED OCTOBER 1989.
56443C
56444C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
56445C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
56446C
56447
56448 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
56449
56450 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
56451 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
56452 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
56453 X ORTR(5),ORTI(5)
56454 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
56455 X PYTHAG
56456
56457 IERR = 0
56458C .......... INITIALIZE EIGENVECTOR MATRIX ..........
56459 DO 110 J = 1, N
56460C
56461 DO 100 I = 1, N
56462 ZR(I,J) = 0.0D0
56463 ZI(I,J) = 0.0D0
56464 100 CONTINUE
56465 ZR(J,J) = 1.0D0
56466 110 CONTINUE
56467C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
56468C FROM THE INFORMATION LEFT BY CORTH ..........
56469 IEND = IGH - LOW - 1
56470 IF (IEND.LT.0) GOTO 220
56471 IF (IEND.EQ.0) GOTO 170
56472C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
56473 DO 160 II = 1, IEND
56474 I = IGH - II
56475 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
56476 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
56477C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
56478 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
56479 IP1 = I + 1
56480C
56481 DO 120 K = IP1, IGH
56482 ORTR(K) = HR(K,I-1)
56483 ORTI(K) = HI(K,I-1)
56484 120 CONTINUE
56485C
56486 DO 150 J = I, IGH
56487 SR = 0.0D0
56488 SI = 0.0D0
56489C
56490 DO 130 K = I, IGH
56491 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
56492 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
56493 130 CONTINUE
56494C
56495 SR = SR / NORM
56496 SI = SI / NORM
56497C
56498 DO 140 K = I, IGH
56499 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
56500 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
56501 140 CONTINUE
56502C
56503 150 CONTINUE
56504C
56505 160 CONTINUE
56506C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
56507 170 L = LOW + 1
56508C
56509 DO 210 I = L, IGH
56510 LL = MIN0(I+1,IGH)
56511 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
56512 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
56513 YR = HR(I,I-1) / NORM
56514 YI = HI(I,I-1) / NORM
56515 HR(I,I-1) = NORM
56516 HI(I,I-1) = 0.0D0
56517C
56518 DO 180 J = I, N
56519 SI = YR * HI(I,J) - YI * HR(I,J)
56520 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
56521 HI(I,J) = SI
56522 180 CONTINUE
56523C
56524 DO 190 J = 1, LL
56525 SI = YR * HI(J,I) + YI * HR(J,I)
56526 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
56527 HI(J,I) = SI
56528 190 CONTINUE
56529C
56530 DO 200 J = LOW, IGH
56531 SI = YR * ZI(J,I) + YI * ZR(J,I)
56532 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
56533 ZI(J,I) = SI
56534 200 CONTINUE
56535C
56536 210 CONTINUE
56537C .......... STORE ROOTS ISOLATED BY CBAL ..........
56538 220 DO 230 I = 1, N
56539 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
56540 WR(I) = HR(I,I)
56541 WI(I) = HI(I,I)
56542 230 CONTINUE
56543C
56544 EN = IGH
56545 TR = 0.0D0
56546 TI = 0.0D0
56547 ITN = 30*N
56548C .......... SEARCH FOR NEXT EIGENVALUE ..........
56549 240 IF (EN .LT. LOW) GOTO 430
56550 ITS = 0
56551 ENM1 = EN - 1
56552C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
56553C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
56554 250 DO 260 LL = LOW, EN
56555 L = EN + LOW - LL
56556 IF (L .EQ. LOW) GOTO 270
56557 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
56558 X + DABS(HR(L,L)) + DABS(HI(L,L))
56559 TST2 = TST1 + DABS(HR(L,L-1))
56560 IF (TST2 .EQ. TST1) GOTO 270
56561 260 CONTINUE
56562C .......... FORM SHIFT ..........
56563 270 IF (L .EQ. EN) GOTO 420
56564 IF (ITN .EQ. 0) GOTO 550
56565 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
56566 SR = HR(EN,EN)
56567 SI = HI(EN,EN)
56568 XR = HR(ENM1,EN) * HR(EN,ENM1)
56569 XI = HI(ENM1,EN) * HR(EN,ENM1)
56570 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
56571 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
56572 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
56573 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
56574 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
56575 ZZR = -ZZR
56576 ZZI = -ZZI
56577 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
56578 SR = SR - XR
56579 SI = SI - XI
56580 GOTO 300
56581C .......... FORM EXCEPTIONAL SHIFT ..........
56582 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
56583 SI = 0.0D0
56584C
56585 300 DO 310 I = LOW, EN
56586 HR(I,I) = HR(I,I) - SR
56587 HI(I,I) = HI(I,I) - SI
56588 310 CONTINUE
56589C
56590 TR = TR + SR
56591 TI = TI + SI
56592 ITS = ITS + 1
56593 ITN = ITN - 1
56594C .......... REDUCE TO TRIANGLE (ROWS) ..........
56595 LP1 = L + 1
56596C
56597 DO 330 I = LP1, EN
56598 SR = HR(I,I-1)
56599 HR(I,I-1) = 0.0D0
56600 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
56601 XR = HR(I-1,I-1) / NORM
56602 WR(I-1) = XR
56603 XI = HI(I-1,I-1) / NORM
56604 WI(I-1) = XI
56605 HR(I-1,I-1) = NORM
56606 HI(I-1,I-1) = 0.0D0
56607 HI(I,I-1) = SR / NORM
56608C
56609 DO 320 J = I, N
56610 YR = HR(I-1,J)
56611 YI = HI(I-1,J)
56612 ZZR = HR(I,J)
56613 ZZI = HI(I,J)
56614 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
56615 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
56616 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
56617 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
56618 320 CONTINUE
56619C
56620 330 CONTINUE
56621C
56622 SI = HI(EN,EN)
56623 IF (SI .EQ. 0.0D0) GOTO 350
56624 NORM = PYTHAG(HR(EN,EN),SI)
56625 SR = HR(EN,EN) / NORM
56626 SI = SI / NORM
56627 HR(EN,EN) = NORM
56628 HI(EN,EN) = 0.0D0
56629 IF (EN .EQ. N) GOTO 350
56630 IP1 = EN + 1
56631C
56632 DO 340 J = IP1, N
56633 YR = HR(EN,J)
56634 YI = HI(EN,J)
56635 HR(EN,J) = SR * YR + SI * YI
56636 HI(EN,J) = SR * YI - SI * YR
56637 340 CONTINUE
56638C .......... INVERSE OPERATION (COLUMNS) ..........
56639 350 DO 390 J = LP1, EN
56640 XR = WR(J-1)
56641 XI = WI(J-1)
56642C
56643 DO 370 I = 1, J
56644 YR = HR(I,J-1)
56645 YI = 0.0D0
56646 ZZR = HR(I,J)
56647 ZZI = HI(I,J)
56648 IF (I .EQ. J) GOTO 360
56649 YI = HI(I,J-1)
56650 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
56651 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
56652 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
56653 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
56654 370 CONTINUE
56655C
56656 DO 380 I = LOW, IGH
56657 YR = ZR(I,J-1)
56658 YI = ZI(I,J-1)
56659 ZZR = ZR(I,J)
56660 ZZI = ZI(I,J)
56661 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
56662 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
56663 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
56664 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
56665 380 CONTINUE
56666C
56667 390 CONTINUE
56668C
56669 IF (SI .EQ. 0.0D0) GOTO 250
56670C
56671 DO 400 I = 1, EN
56672 YR = HR(I,EN)
56673 YI = HI(I,EN)
56674 HR(I,EN) = SR * YR - SI * YI
56675 HI(I,EN) = SR * YI + SI * YR
56676 400 CONTINUE
56677C
56678 DO 410 I = LOW, IGH
56679 YR = ZR(I,EN)
56680 YI = ZI(I,EN)
56681 ZR(I,EN) = SR * YR - SI * YI
56682 ZI(I,EN) = SR * YI + SI * YR
56683 410 CONTINUE
56684C
56685 GOTO 250
56686C .......... A ROOT FOUND ..........
56687 420 HR(EN,EN) = HR(EN,EN) + TR
56688 WR(EN) = HR(EN,EN)
56689 HI(EN,EN) = HI(EN,EN) + TI
56690 WI(EN) = HI(EN,EN)
56691 EN = ENM1
56692 GOTO 240
56693C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
56694C VECTORS OF UPPER TRIANGULAR FORM ..........
56695 430 NORM = 0.0D0
56696C
56697 DO 440 I = 1, N
56698C
56699 DO 440 J = I, N
56700 TR = DABS(HR(I,J)) + DABS(HI(I,J))
56701 IF (TR .GT. NORM) NORM = TR
56702 440 CONTINUE
56703C
56704 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
56705C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
56706 DO 500 NN = 2, N
56707 EN = N + 2 - NN
56708 XR = WR(EN)
56709 XI = WI(EN)
56710 HR(EN,EN) = 1.0D0
56711 HI(EN,EN) = 0.0D0
56712 ENM1 = EN - 1
56713C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
56714 DO 490 II = 1, ENM1
56715 I = EN - II
56716 ZZR = 0.0D0
56717 ZZI = 0.0D0
56718 IP1 = I + 1
56719C
56720 DO 450 J = IP1, EN
56721 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
56722 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
56723 450 CONTINUE
56724C
56725 YR = XR - WR(I)
56726 YI = XI - WI(I)
56727 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
56728 TST1 = NORM
56729 YR = TST1
56730 460 YR = 0.01D0 * YR
56731 TST2 = NORM + YR
56732 IF (TST2 .GT. TST1) GOTO 460
56733 470 CONTINUE
56734 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
56735C .......... OVERFLOW CONTROL ..........
56736 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
56737 IF (TR .EQ. 0.0D0) GOTO 490
56738 TST1 = TR
56739 TST2 = TST1 + 1.0D0/TST1
56740 IF (TST2 .GT. TST1) GOTO 490
56741 DO 480 J = I, EN
56742 HR(J,EN) = HR(J,EN)/TR
56743 HI(J,EN) = HI(J,EN)/TR
56744 480 CONTINUE
56745C
56746 490 CONTINUE
56747C
56748 500 CONTINUE
56749C .......... END BACKSUBSTITUTION ..........
56750C .......... VECTORS OF ISOLATED ROOTS ..........
56751 DO 520 I = 1, N
56752 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
56753C
56754 DO 510 J = I, N
56755 ZR(I,J) = HR(I,J)
56756 ZI(I,J) = HI(I,J)
56757 510 CONTINUE
56758C
56759 520 CONTINUE
56760C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
56761C VECTORS OF ORIGINAL FULL MATRIX.
56762C FOR J=N STEP -1 UNTIL LOW DO -- ..........
56763 DO 540 JJ = LOW, N
56764 J = N + LOW - JJ
56765 M = MIN0(J,IGH)
56766C
56767 DO 540 I = LOW, IGH
56768 ZZR = 0.0D0
56769 ZZI = 0.0D0
56770C
56771 DO 530 K = LOW, M
56772 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
56773 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
56774 530 CONTINUE
56775C
56776 ZR(I,J) = ZZR
56777 ZI(I,J) = ZZI
56778 540 CONTINUE
56779C
56780 GOTO 560
56781C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
56782C CONVERGED AFTER 30*N ITERATIONS ..........
56783 550 IERR = EN
56784 560 RETURN
56785 END
56786
56787C*********************************************************************
56788
56789C...PYCDIV
56790C...Auxiliary to PYCMQR
56791C
56792C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
56793C
56794
56795 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
56796
56797 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
56798 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
56799
56800 S = DABS(BR) + DABS(BI)
56801 ARS = AR/S
56802 AIS = AI/S
56803 BRS = BR/S
56804 BIS = BI/S
56805 S = BRS**2 + BIS**2
56806 CR = (ARS*BRS + AIS*BIS)/S
56807 CI = (AIS*BRS - ARS*BIS)/S
56808 RETURN
56809 END
56810
56811C*********************************************************************
56812
56813C...PYCSRT
56814C...Auxiliary to PYCMQR
56815C
56816C (YR,YI) = COMPLEX DSQRT(XR,XI)
56817C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
56818C
56819
56820 SUBROUTINE PYCSRT(XR,XI,YR,YI)
56821
56822 DOUBLE PRECISION XR,XI,YR,YI
56823 DOUBLE PRECISION S,TR,TI,PYTHAG
56824
56825 TR = XR
56826 TI = XI
56827 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
56828 IF (TR .GE. 0.0D0) YR = S
56829 IF (TI .LT. 0.0D0) S = -S
56830 IF (TR .LE. 0.0D0) YI = S
56831 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
56832 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
56833 RETURN
56834 END
56835
56836 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
56837 DOUBLE PRECISION A,B
56838C
56839C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
56840C
56841 DOUBLE PRECISION P,R,S,T,U
56842 P = DMAX1(DABS(A),DABS(B))
56843 IF (P .EQ. 0.0D0) GOTO 110
56844 R = (DMIN1(DABS(A),DABS(B))/P)**2
56845 100 CONTINUE
56846 T = 4.0D0 + R
56847 IF (T .EQ. 4.0D0) GOTO 110
56848 S = R/T
56849 U = 1.0D0 + 2.0D0*S
56850 P = U*P
56851 R = (S/U)**2 * R
56852 GOTO 100
56853 110 PYTHAG = P
56854 RETURN
56855 END
56856
56857C*********************************************************************
56858
56859C...PYCBAL
56860C...Auxiliary to PYEICG
56861C
56862C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56863C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
56864C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56865C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56866C
56867C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
56868C EIGENVALUES WHENEVER POSSIBLE.
56869C
56870C ON INPUT
56871C
56872C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56873C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56874C DIMENSION STATEMENT.
56875C
56876C N IS THE ORDER OF THE MATRIX.
56877C
56878C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56879C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
56880C
56881C ON OUTPUT
56882C
56883C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56884C RESPECTIVELY, OF THE BALANCED MATRIX.
56885C
56886C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
56887C ARE EQUAL TO ZERO IF
56888C (1) I IS GREATER THAN J AND
56889C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
56890C
56891C SCALE CONTAINS INFORMATION DETERMINING THE
56892C PERMUTATIONS AND SCALING FACTORS USED.
56893C
56894C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
56895C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
56896C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
56897C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
56898C SCALE(J) = P(J), FOR J = 1,...,LOW-1
56899C = D(J,J) J = LOW,...,IGH
56900C = P(J) J = IGH+1,...,N.
56901C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
56902C THEN 1 TO LOW-1.
56903C
56904C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
56905C
56906C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
56907C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
56908C K,L HAVE BEEN REVERSED.)
56909C
56910C ARITHMETIC IS REAL THROUGHOUT.
56911C
56912C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56913C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56914C
56915C THIS VERSION DATED AUGUST 1983.
56916C
56917
56918 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
56919
56920 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
56921 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
56922 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
56923 LOGICAL NOCONV
56924
56925 RADIX = 16.0D0
56926C
56927 B2 = RADIX * RADIX
56928 K = 1
56929 L = N
56930 GOTO 150
56931C .......... IN-LINE PROCEDURE FOR ROW AND
56932C COLUMN EXCHANGE ..........
56933 100 SCALE(M) = J
56934 IF (J .EQ. M) GOTO 130
56935C
56936 DO 110 I = 1, L
56937 F = AR(I,J)
56938 AR(I,J) = AR(I,M)
56939 AR(I,M) = F
56940 F = AI(I,J)
56941 AI(I,J) = AI(I,M)
56942 AI(I,M) = F
56943 110 CONTINUE
56944C
56945 DO 120 I = K, N
56946 F = AR(J,I)
56947 AR(J,I) = AR(M,I)
56948 AR(M,I) = F
56949 F = AI(J,I)
56950 AI(J,I) = AI(M,I)
56951 AI(M,I) = F
56952 120 CONTINUE
56953C
56954 130 IF(IEXC.EQ.1) GOTO 140
56955 IF(IEXC.EQ.2) GOTO 180
56956C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
56957C AND PUSH THEM DOWN ..........
56958 140 IF (L .EQ. 1) GOTO 320
56959 L = L - 1
56960C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
56961 150 DO 170 JJ = 1, L
56962 J = L + 1 - JJ
56963C
56964 DO 160 I = 1, L
56965 IF (I .EQ. J) GOTO 160
56966 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
56967 160 CONTINUE
56968C
56969 M = L
56970 IEXC = 1
56971 GOTO 100
56972 170 CONTINUE
56973C
56974 GOTO 190
56975C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
56976C AND PUSH THEM LEFT ..........
56977 180 K = K + 1
56978C
56979 190 DO 210 J = K, L
56980C
56981 DO 200 I = K, L
56982 IF (I .EQ. J) GOTO 200
56983 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
56984 200 CONTINUE
56985C
56986 M = K
56987 IEXC = 2
56988 GOTO 100
56989 210 CONTINUE
56990C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
56991 DO 220 I = K, L
56992 220 SCALE(I) = 1.0D0
56993C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
56994 230 NOCONV = .FALSE.
56995C
56996 DO 310 I = K, L
56997 C = 0.0D0
56998 R = 0.0D0
56999C
57000 DO 240 J = K, L
57001 IF (J .EQ. I) GOTO 240
57002 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
57003 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
57004 240 CONTINUE
57005C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
57006 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
57007 G = R / RADIX
57008 F = 1.0D0
57009 S = C + R
57010 250 IF (C .GE. G) GOTO 260
57011 F = F * RADIX
57012 C = C * B2
57013 GOTO 250
57014 260 G = R * RADIX
57015 270 IF (C .LT. G) GOTO 280
57016 F = F / RADIX
57017 C = C / B2
57018 GOTO 270
57019C .......... NOW BALANCE ..........
57020 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
57021 G = 1.0D0 / F
57022 SCALE(I) = SCALE(I) * F
57023 NOCONV = .TRUE.
57024C
57025 DO 290 J = K, N
57026 AR(I,J) = AR(I,J) * G
57027 AI(I,J) = AI(I,J) * G
57028 290 CONTINUE
57029C
57030 DO 300 J = 1, L
57031 AR(J,I) = AR(J,I) * F
57032 AI(J,I) = AI(J,I) * F
57033 300 CONTINUE
57034C
57035 310 CONTINUE
57036C
57037 IF (NOCONV) GOTO 230
57038C
57039 320 LOW = K
57040 IGH = L
57041 RETURN
57042 END
57043
57044C*********************************************************************
57045
57046C...PYCBA2
57047C...Auxiliary to PYEICG.
57048C
57049C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
57050C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
57051C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
57052C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
57053C
57054C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
57055C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
57056C BALANCED MATRIX DETERMINED BY CBAL.
57057C
57058C ON INPUT
57059C
57060C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
57061C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
57062C DIMENSION STATEMENT.
57063C
57064C N IS THE ORDER OF THE MATRIX.
57065C
57066C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
57067C
57068C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
57069C AND SCALING FACTORS USED BY CBAL.
57070C
57071C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
57072C
57073C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
57074C RESPECTIVELY, OF THE EIGENVECTORS TO BE
57075C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
57076C
57077C ON OUTPUT
57078C
57079C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
57080C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
57081C IN THEIR FIRST M COLUMNS.
57082C
57083C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
57084C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
57085C
57086C THIS VERSION DATED AUGUST 1983.
57087C
57088
57089 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
57090
57091 INTEGER I,J,K,M,N,II,NM,IGH,LOW
57092 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
57093 DOUBLE PRECISION S
57094
57095 IF (M .EQ. 0) GOTO 150
57096 IF (IGH .EQ. LOW) GOTO 120
57097C
57098 DO 110 I = LOW, IGH
57099 S = SCALE(I)
57100C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
57101C IF THE FOREGOING STATEMENT IS REPLACED BY
57102C S=1.0D0/SCALE(I). ..........
57103 DO 100 J = 1, M
57104 ZR(I,J) = ZR(I,J) * S
57105 ZI(I,J) = ZI(I,J) * S
57106 100 CONTINUE
57107C
57108 110 CONTINUE
57109C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
57110C IGH+1 STEP 1 UNTIL N DO -- ..........
57111 120 DO 140 II = 1, N
57112 I = II
57113 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
57114 IF (I .LT. LOW) I = LOW - II
57115 K = SCALE(I)
57116 IF (K .EQ. I) GOTO 140
57117C
57118 DO 130 J = 1, M
57119 S = ZR(I,J)
57120 ZR(I,J) = ZR(K,J)
57121 ZR(K,J) = S
57122 S = ZI(I,J)
57123 ZI(I,J) = ZI(K,J)
57124 ZI(K,J) = S
57125 130 CONTINUE
57126C
57127 140 CONTINUE
57128C
57129 150 RETURN
57130 END
57131
57132C*********************************************************************
57133
57134C...PYCRTH
57135C...Auxiliary to PYEICG.
57136C
57137C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
57138C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
57139C BY MARTIN AND WILKINSON.
57140C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
57141C
57142C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
57143C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
57144C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
57145C UNITARY SIMILARITY TRANSFORMATIONS.
57146C
57147C ON INPUT
57148C
57149C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
57150C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
57151C DIMENSION STATEMENT.
57152C
57153C N IS THE ORDER OF THE MATRIX.
57154C
57155C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
57156C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
57157C SET LOW=1, IGH=N.
57158C
57159C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
57160C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
57161C
57162C ON OUTPUT
57163C
57164C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
57165C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
57166C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
57167C IS STORED IN THE REMAINING TRIANGLES UNDER THE
57168C HESSENBERG MATRIX.
57169C
57170C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
57171C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
57172C
57173C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
57174C
57175C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
57176C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
57177C
57178C THIS VERSION DATED AUGUST 1983.
57179C
57180
57181 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
57182
57183 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
57184 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
57185 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
57186
57187 LA = IGH - 1
57188 KP1 = LOW + 1
57189 IF (LA .LT. KP1) GOTO 210
57190C
57191 DO 200 M = KP1, LA
57192 H = 0.0D0
57193 ORTR(M) = 0.0D0
57194 ORTI(M) = 0.0D0
57195 SCALE = 0.0D0
57196C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
57197 DO 100 I = M, IGH
57198 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
57199C
57200 IF (SCALE .EQ. 0.0D0) GOTO 200
57201 MP = M + IGH
57202C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
57203 DO 110 II = M, IGH
57204 I = MP - II
57205 ORTR(I) = AR(I,M-1) / SCALE
57206 ORTI(I) = AI(I,M-1) / SCALE
57207 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
57208 110 CONTINUE
57209C
57210 G = DSQRT(H)
57211 F = PYTHAG(ORTR(M),ORTI(M))
57212 IF (F .EQ. 0.0D0) GOTO 120
57213 H = H + F * G
57214 G = G / F
57215 ORTR(M) = (1.0D0 + G) * ORTR(M)
57216 ORTI(M) = (1.0D0 + G) * ORTI(M)
57217 GOTO 130
57218C
57219 120 ORTR(M) = G
57220 AR(M,M-1) = SCALE
57221C .......... FORM (I-(U*UT)/H) * A ..........
57222 130 DO 160 J = M, N
57223 FR = 0.0D0
57224 FI = 0.0D0
57225C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
57226 DO 140 II = M, IGH
57227 I = MP - II
57228 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
57229 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
57230 140 CONTINUE
57231C
57232 FR = FR / H
57233 FI = FI / H
57234C
57235 DO 150 I = M, IGH
57236 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
57237 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
57238 150 CONTINUE
57239C
57240 160 CONTINUE
57241C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
57242 DO 190 I = 1, IGH
57243 FR = 0.0D0
57244 FI = 0.0D0
57245C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
57246 DO 170 JJ = M, IGH
57247 J = MP - JJ
57248 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
57249 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
57250 170 CONTINUE
57251C
57252 FR = FR / H
57253 FI = FI / H
57254C
57255 DO 180 J = M, IGH
57256 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
57257 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
57258 180 CONTINUE
57259C
57260 190 CONTINUE
57261C
57262 ORTR(M) = SCALE * ORTR(M)
57263 ORTI(M) = SCALE * ORTI(M)
57264 AR(M,M-1) = -G * AR(M,M-1)
57265 AI(M,M-1) = -G * AI(M,M-1)
57266 200 CONTINUE
57267C
57268 210 RETURN
57269 END
57270
57271C*********************************************************************
57272
57273C...PYLDCM
57274C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
57275C...processes.
57276
57277 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
57278 IMPLICIT NONE
57279 INTEGER N,NP,INDX(N)
57280 REAL*8 D,TINY
57281 COMPLEX*16 A(NP,NP)
57282 PARAMETER (TINY=1.0D-20)
57283 INTEGER I,IMAX,J,K
57284 REAL*8 AAMAX,VV(6),DUM
57285 COMPLEX*16 SUM,DUMC
57286
57287 D=1D0
57288 DO 110 I=1,N
57289 AAMAX=0D0
57290 DO 100 J=1,N
57291 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
57292 100 CONTINUE
57293 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
57294 VV(I)=1D0/AAMAX
57295 110 CONTINUE
57296 DO 180 J=1,N
57297 DO 130 I=1,J-1
57298 SUM=A(I,J)
57299 DO 120 K=1,I-1
57300 SUM=SUM-A(I,K)*A(K,J)
57301 120 CONTINUE
57302 A(I,J)=SUM
57303 130 CONTINUE
57304 AAMAX=0D0
57305 DO 150 I=J,N
57306 SUM=A(I,J)
57307 DO 140 K=1,J-1
57308 SUM=SUM-A(I,K)*A(K,J)
57309 140 CONTINUE
57310 A(I,J)=SUM
57311 DUM=VV(I)*ABS(SUM)
57312 IF (DUM.GE.AAMAX) THEN
57313 IMAX=I
57314 AAMAX=DUM
57315 ENDIF
57316 150 CONTINUE
57317 IF (J.NE.IMAX)THEN
57318 DO 160 K=1,N
57319 DUMC=A(IMAX,K)
57320 A(IMAX,K)=A(J,K)
57321 A(J,K)=DUMC
57322 160 CONTINUE
57323 D=-D
57324 VV(IMAX)=VV(J)
57325 ENDIF
57326 INDX(J)=IMAX
57327 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
57328 IF(J.NE.N)THEN
57329 DO 170 I=J+1,N
57330 A(I,J)=A(I,J)/A(J,J)
57331 170 CONTINUE
57332 ENDIF
57333 180 CONTINUE
57334
57335 RETURN
57336 END
57337
57338C*********************************************************************
57339
57340C...PYBKSB
57341C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
57342C...processes.
57343
57344 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
57345 IMPLICIT NONE
57346 INTEGER N,NP,INDX(N)
57347 COMPLEX*16 A(NP,NP),B(N)
57348 INTEGER I,II,J,LL
57349 COMPLEX*16 SUM
57350
57351 II=0
57352 DO 110 I=1,N
57353 LL=INDX(I)
57354 SUM=B(LL)
57355 B(LL)=B(I)
57356 IF (II.NE.0)THEN
57357 DO 100 J=II,I-1
57358 SUM=SUM-A(I,J)*B(J)
57359 100 CONTINUE
57360 ELSE IF (ABS(SUM).NE.0D0) THEN
57361 II=I
57362 ENDIF
57363 B(I)=SUM
57364 110 CONTINUE
57365 DO 130 I=N,1,-1
57366 SUM=B(I)
57367 DO 120 J=I+1,N
57368 SUM=SUM-A(I,J)*B(J)
57369 120 CONTINUE
57370 B(I)=SUM/A(I,I)
57371 130 CONTINUE
57372 RETURN
57373 END
57374
57375C***********************************************************************
57376
57377C...PYWIDX
57378C...Calculates full and partial widths of resonances.
57379C....copy of PYWIDT, used for techniparticle widths
57380
57381 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
57382
57383C...Double precision and integer declarations.
57384 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57385 IMPLICIT INTEGER(I-N)
57386 INTEGER PYK,PYCHGE,PYCOMP
57387C...Parameter statement to help give large particle numbers.
57388 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57389 &KEXCIT=4000000,KDIMEN=5000000)
57390C...Commonblocks.
57391 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57392 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57393 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
57394 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
57395 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
57396 COMMON/PYINT1/MINT(400),VINT(400)
57397 COMMON/PYINT4/MWID(500),WIDS(500,5)
57398 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57399 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
57400 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
57401 &/PYINT4/,/PYMSSM/,/PYTCSM/
57402C...Local arrays and saved variables.
57403 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
57404 &WID2SV(3,2)
57405 SAVE MOFSV,WIDWSV,WID2SV
57406 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
57407
57408C...Compressed code and sign; mass.
57409 KFLA=IABS(KFLR)
57410 KFLS=ISIGN(1,KFLR)
57411 KC=PYCOMP(KFLA)
57412 SHR=SQRT(SH)
57413 PMR=PMAS(KC,1)
57414
57415C...Reset width information.
57416 DO I=0,400
57417 WDTP(I)=0D0
57418 ENDDO
57419
57420C...Common electroweak and strong constants.
57421 XW=PARU(102)
57422 XWV=XW
57423 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
57424 XW1=1D0-XW
57425 AEM=PYALEM(SH)
57426 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
57427 AS=PYALPS(SH)
57428 RADC=1D0+AS/PARU(1)
57429
57430 IF(KFLA.EQ.23) THEN
57431C...Z0:
57432 XWC=1D0/(16D0*XW*XW1)
57433 FAC=(AEM*XWC/3D0)*SHR
57434 120 CONTINUE
57435 DO 130 I=1,MDCY(KC,3)
57436 IDC=I+MDCY(KC,2)-1
57437 IF(MDME(IDC,1).LT.0) GOTO 130
57438 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
57439 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
57440 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
57441 IF(I.LE.8) THEN
57442C...Z0 -> q + qbar
57443 EF=KCHG(I,1)/3D0
57444 AF=SIGN(1D0,EF+0.1D0)
57445 VF=AF-4D0*EF*XWV
57446 FCOF=3D0*RADC
57447 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
57448 ELSEIF(I.LE.16) THEN
57449C...Z0 -> l+ + l-, nu + nubar
57450 EF=KCHG(I+2,1)/3D0
57451 AF=SIGN(1D0,EF+0.1D0)
57452 VF=AF-4D0*EF*XWV
57453 FCOF=1D0
57454 ENDIF
57455 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
57456 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
57457 & BE34
57458 WDTP(0)=WDTP(0)+WDTP(I)
57459 130 CONTINUE
57460
57461
57462 ELSEIF(KFLA.EQ.24) THEN
57463C...W+/-:
57464 FAC=(AEM/(24D0*XW))*SHR
57465 DO 140 I=1,MDCY(KC,3)
57466 IDC=I+MDCY(KC,2)-1
57467 IF(MDME(IDC,1).LT.0) GOTO 140
57468 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
57469 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
57470 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
57471 WID2=1D0
57472 IF(I.LE.16) THEN
57473C...W+/- -> q + qbar'
57474 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
57475 ELSEIF(I.LE.20) THEN
57476C...W+/- -> l+/- + nu
57477 FCOF=1D0
57478 ENDIF
57479 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
57480 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
57481 WDTP(0)=WDTP(0)+WDTP(I)
57482 140 CONTINUE
57483
57484C.....V8 -> quark anti-quark
57485 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
57486 FAC=AS/6D0*SHR
57487 TANT3=RTCM(21)
57488 IF(ITCM(2).EQ.0) THEN
57489 IMDL=1
57490 ELSEIF(ITCM(2).EQ.1) THEN
57491 IMDL=2
57492 ENDIF
57493 DO 150 I=1,MDCY(KC,3)
57494 IDC=I+MDCY(KC,2)-1
57495 IF(MDME(IDC,1).LT.0) GOTO 150
57496 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
57497 RM1=PM1**2/SH
57498 IF(RM1.GT.0.25D0) GOTO 150
57499 WID2=1D0
57500 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
57501 FMIX=1D0/TANT3**2
57502 ELSE
57503 FMIX=TANT3**2
57504 ENDIF
57505 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
57506 IF(I.EQ.6) WID2=WIDS(6,1)
57507 WDTP(0)=WDTP(0)+WDTP(I)
57508 150 CONTINUE
57509 ENDIF
57510
57511 RETURN
57512 END
57513
57514C*********************************************************************
57515
57516C...PYRVSF
57517C...Calculates R-violating decays of sfermions.
57518C...P. Z. Skands
57519
57520 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
57521
57522C...Double precision and integer declarations.
57523 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57524 IMPLICIT INTEGER(I-N)
57525C...Parameter statement to help give large particle numbers.
57526 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57527 &KEXCIT=4000000,KDIMEN=5000000)
57528C...Commonblocks.
57529 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57530 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57531 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57532 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57533 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57534C...Local variables.
57535 DOUBLE PRECISION XLAM(0:400)
57536 INTEGER IDLAM(400,3), PYCOMP
57537 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
57538
57539C...IS R-VIOLATION ON ?
57540 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57541C...Mass eigenstate counter
57542 ICNT=INT(KFIN/KSUSY1)
57543C...SM KF code of SUSY particle
57544 KFSM=KFIN-ICNT*KSUSY1
57545C...Squared Sparticle Mass
57546 SM=PMAS(PYCOMP(KFIN),1)**2
57547C... Squared mass of top quark
57548 SMT=PMAS(PYCOMP(6),1)**2
57549C...IS L-VIOLATION ON ?
57550 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
57551C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
57552 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
57553 & THEN
57554 K=INT((KFSM-9)/2)
57555 DO 110 I=1,3
57556 DO 100 J=1,3
57557 IF(I.NE.J) THEN
57558C...~e,~mu,~tau -> nu_I + lepton-_J
57559 LKNT = LKNT+1
57560 IDLAM(LKNT,1)= 12 +2*(I-1)
57561 IDLAM(LKNT,2)= 11 +2*(J-1)
57562 IDLAM(LKNT,3)= 0
57563 XLAM(LKNT)=0D0
57564 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57565 IF (IMSS(51).NE.0) XLAM(LKNT) =
57566 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57567C...KINEMATICS CHECK
57568 IF (XLAM(LKNT).EQ.0D0) THEN
57569 LKNT=LKNT-1
57570 ENDIF
57571 ENDIF
57572 100 CONTINUE
57573 110 CONTINUE
57574C...~e,~mu,~tau -> nu_Ibar + lepton-_K
57575 J=INT((KFSM-9)/2)
57576 DO 130 I=1,3
57577 IF(I.NE.J) THEN
57578 DO 120 K=1,3
57579 LKNT = LKNT+1
57580 IDLAM(LKNT,1)=-12 -2*(I-1)
57581 IDLAM(LKNT,2)= 11 +2*(K-1)
57582 IDLAM(LKNT,3)= 0
57583 XLAM(LKNT)=0D0
57584 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57585 IF (IMSS(51).NE.0) XLAM(LKNT) =
57586 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57587C...KINEMATICS CHECK
57588 IF (XLAM(LKNT).EQ.0D0) THEN
57589 LKNT=LKNT-1
57590 ENDIF
57591 120 CONTINUE
57592 ENDIF
57593 130 CONTINUE
57594C...~e,~mu,~tau -> u_Jbar + d_K
57595 I=INT((KFSM-9)/2)
57596 DO 150 J=1,3
57597 DO 140 K=1,3
57598 LKNT = LKNT+1
57599 IDLAM(LKNT,1)=-2 -2*(J-1)
57600 IDLAM(LKNT,2)= 1 +2*(K-1)
57601 IDLAM(LKNT,3)= 0
57602 XLAM(LKNT)=0
57603 IF (IMSS(52).NE.0) THEN
57604C...Use massive top quark
57605 IF (IDLAM(LKNT,1).EQ.-6) THEN
57606 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
57607 & * (SM-SMT)
57608 XLAM(LKNT) =
57609 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
57610C...If no top quark, all decay products massless
57611 ELSE
57612 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57613 XLAM(LKNT) =
57614 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57615 ENDIF
57616C...KINEMATICS CHECK
57617 IF (XLAM(LKNT).EQ.0D0) THEN
57618 LKNT=LKNT-1
57619 ENDIF
57620 ENDIF
57621 140 CONTINUE
57622 150 CONTINUE
57623 ENDIF
57624C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
57625C...No right-handed neutrinos
57626 IF(ICNT.EQ.1) THEN
57627 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
57628 J=INT((KFSM-10)/2)
57629 DO 170 I=1,3
57630 DO 160 K=1,3
57631 IF (I.NE.J) THEN
57632C...~nu_J -> lepton+_I + lepton-_K
57633 LKNT = LKNT+1
57634 IDLAM(LKNT,1)=-11 -2*(I-1)
57635 IDLAM(LKNT,2)= 11 +2*(K-1)
57636 IDLAM(LKNT,3)= 0
57637 XLAM(LKNT)=0D0
57638 RM2=RVLAM(I,J,K)**2 * SM
57639 IF (IMSS(51).NE.0) XLAM(LKNT) =
57640 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57641C...KINEMATICS CHECK
57642 IF (XLAM(LKNT).EQ.0D0) THEN
57643 LKNT=LKNT-1
57644 ENDIF
57645 ENDIF
57646 160 CONTINUE
57647 170 CONTINUE
57648C...~nu_I -> dbar_J + d_K
57649 I=INT((KFSM-10)/2)
57650 DO 190 J=1,3
57651 DO 180 K=1,3
57652 LKNT = LKNT+1
57653 IDLAM(LKNT,1)=-1 -2*(J-1)
57654 IDLAM(LKNT,2)= 1 +2*(K-1)
57655 IDLAM(LKNT,3)= 0
57656 XLAM(LKNT)=0D0
57657 RM2=3*RVLAMP(I,J,K)**2 * SM
57658 IF (IMSS(52).NE.0) XLAM(LKNT) =
57659 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57660C...KINEMATICS CHECK
57661 IF (XLAM(LKNT).EQ.0D0) THEN
57662 LKNT=LKNT-1
57663 ENDIF
57664 180 CONTINUE
57665 190 CONTINUE
57666 ENDIF
57667 ENDIF
57668C * SDOWN -> NU(BAR) + D and LEPTON- + U
57669 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
57670 J=INT((KFSM+1)/2)
57671 DO 210 I=1,3
57672 DO 200 K=1,3
57673C...~d_J -> nu_Ibar + d_K
57674 LKNT = LKNT+1
57675 IDLAM(LKNT,1)=-12 -2*(I-1)
57676 IDLAM(LKNT,2)= 1 +2*(K-1)
57677 IDLAM(LKNT,3)= 0
57678 XLAM(LKNT)=0D0
57679 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57680 IF (IMSS(52).NE.0) XLAM(LKNT) =
57681 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57682C...KINEMATICS CHECK
57683 IF (XLAM(LKNT).EQ.0D0) THEN
57684 LKNT=LKNT-1
57685 ENDIF
57686 200 CONTINUE
57687 210 CONTINUE
57688 K=INT((KFSM+1)/2)
57689 DO 240 I=1,3
57690 DO 230 J=1,3
57691C...~d_K -> nu_I + d_J
57692 LKNT = LKNT+1
57693 IDLAM(LKNT,1)= 12 +2*(I-1)
57694 IDLAM(LKNT,2)= 1 +2*(J-1)
57695 IDLAM(LKNT,3)= 0
57696 XLAM(LKNT)=0D0
57697 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57698 IF (IMSS(52).NE.0) XLAM(LKNT) =
57699 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57700C...KINEMATICS CHECK
57701 IF (XLAM(LKNT).EQ.0D0) THEN
57702 LKNT=LKNT-1
57703 ENDIF
57704C...~d_K -> lepton_I- + u_J
57705 220 LKNT = LKNT+1
57706 IDLAM(LKNT,1)= 11 +2*(I-1)
57707 IDLAM(LKNT,2)= 2 +2*(J-1)
57708 IDLAM(LKNT,3)= 0
57709 XLAM(LKNT)=0D0
57710 IF (IMSS(52).NE.0) THEN
57711C...Use massive top quark
57712 IF (IDLAM(LKNT,2).EQ.6) THEN
57713 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
57714 XLAM(LKNT) =
57715 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
57716C...If no top quark, all decay products massless
57717 ELSE
57718 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57719 XLAM(LKNT) =
57720 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57721 ENDIF
57722C...KINEMATICS CHECK
57723 IF (XLAM(LKNT).EQ.0D0) THEN
57724 LKNT=LKNT-1
57725 ENDIF
57726 ENDIF
57727 230 CONTINUE
57728 240 CONTINUE
57729 ENDIF
57730C * SUP -> LEPTON+ + D
57731 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
57732 J=NINT(KFSM/2.)
57733 DO 260 I=1,3
57734 DO 250 K=1,3
57735C...~u_J -> lepton_I+ + d_K
57736 LKNT = LKNT+1
57737 IDLAM(LKNT,1)=-11 -2*(I-1)
57738 IDLAM(LKNT,2)= 1 +2*(K-1)
57739 IDLAM(LKNT,3)= 0
57740 XLAM(LKNT)=0D0
57741 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57742 IF (IMSS(52).NE.0) XLAM(LKNT) =
57743 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57744C...KINEMATICS CHECK
57745 IF (XLAM(LKNT).EQ.0D0) THEN
57746 LKNT=LKNT-1
57747 ENDIF
57748 250 CONTINUE
57749 260 CONTINUE
57750 ENDIF
57751 ENDIF
57752C...BARYON NUMBER VIOLATING DECAYS
57753 IF (IMSS(53).GE.1) THEN
57754C * SUP -> DBAR + DBAR
57755 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
57756 I = KFSM/2
57757 DO 280 J=1,3
57758 DO 270 K=1,3
57759C...~u_I -> dbar_J + dbar_K
57760 IF (J.LT.K) THEN
57761C...(anti-) symmetry J <-> K.
57762 LKNT = LKNT + 1
57763 IDLAM(LKNT,1) = -1 -2*(J-1)
57764 IDLAM(LKNT,2) = -1 -2*(K-1)
57765 IDLAM(LKNT,3) = 0
57766 XLAM(LKNT) = 0D0
57767 RM2 = 2.*(RVLAMB(I,J,K)**2)
57768 & * SFMIX(KFSM,2*ICNT)**2 * SM
57769 XLAM(LKNT) =
57770 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57771C...KINEMATICS CHECK
57772 IF (XLAM(LKNT).EQ.0D0) THEN
57773 LKNT = LKNT-1
57774 ENDIF
57775 ENDIF
57776 270 CONTINUE
57777 280 CONTINUE
57778 ENDIF
57779C * SDOWN -> UBAR + DBAR
57780 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
57781 K=(KFSM+1)/2
57782 DO 300 I=1,3
57783 DO 290 J=1,3
57784C...LAMB coupling antisymmetric in J and K.
57785 IF (J.NE.K) THEN
57786C...~d_K -> ubar_I + dbar_K
57787 LKNT = LKNT + 1
57788 IDLAM(LKNT,1)= -2 -2*(I-1)
57789 IDLAM(LKNT,2)= -1 -2*(J-1)
57790 IDLAM(LKNT,3)= 0
57791 XLAM(LKNT)=0D0
57792C...Use massive top quark
57793 IF (IDLAM(LKNT,1).EQ.-6) THEN
57794 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
57795 & )
57796 XLAM(LKNT) =
57797 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
57798C...If no top quark, all decay products massless
57799 ELSE
57800 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57801 XLAM(LKNT) =
57802 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57803 ENDIF
57804C...KINEMATICS CHECK
57805 IF (XLAM(LKNT).EQ.0D0) THEN
57806 LKNT=LKNT-1
57807 ENDIF
57808 ENDIF
57809 290 CONTINUE
57810 300 CONTINUE
57811 ENDIF
57812 ENDIF
57813 ENDIF
57814
57815 RETURN
57816 END
57817
57818C*********************************************************************
57819
57820C...PYRVNE
57821C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
57822C...P. Z. Skands
57823
57824 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
57825
57826C...Double precision and integer declarations.
57827 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57828 IMPLICIT INTEGER(I-N)
57829C...Parameter statement to help give large particle numbers.
57830 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57831 &KEXCIT=4000000,KDIMEN=5000000)
57832C...Commonblocks.
57833 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57834 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57835 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57836 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57837 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57838 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57839C...Local variables.
57840 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57841 & ,DCMASS,KFR(3)
57842 DOUBLE PRECISION XLAM(0:400)
57843 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
57844 INTEGER IDLAM(400,3), PYCOMP
57845 LOGICAL DCMASS
57846 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
57847
57848C...R-VIOLATING DECAYS
57849 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57850 KFSM=KFIN-KSUSY1
57851 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
57852C...WHICH NEUTRALINO ?
57853 NCHI=1
57854 IF (KFSM.EQ.23) NCHI=2
57855 IF (KFSM.EQ.25) NCHI=3
57856 IF (KFSM.EQ.35) NCHI=4
57857C...SIGN OF MASS (Opposite convention as HERWIG)
57858 ISM = 1
57859 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
57860
57861C...Useful parameters for the calculation of the A and B constants.
57862 WMASS = PMAS(PYCOMP(24),1)
57863 ECHG = 2*SQRT(PARU(103)*PARU(1))
57864 COSB=1/(SQRT(1+RMSS(5)**2))
57865 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
57866 COSW=SQRT(1-PARU(102))
57867 SINW=SQRT(PARU(102))
57868 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
57869C...Run quark masses to neutralino mass squared (for Higgs-type
57870C...couplings)
57871 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
57872 DO 100 I=1,6
57873 RMQ(I)=PYMRUN(I,SQMCHI)
57874 100 CONTINUE
57875C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
57876 DO 110 NCHJ=1,4
57877 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
57878 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
57879 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
57880 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
57881 110 CONTINUE
57882 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
57883 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
57884 C2=ECHG*ZPMIX(NCHI,1)
57885 C3=GW*ZPMIX(NCHI,2)/COSW
57886 EU=2D0/3D0
57887 ED=-1D0/3D0
57888C... AB(x,y,z):
57889C x=1-2 : Select A or B constant (1:A ; 2:B)
57890C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57891C 11-16:e,nu_e,mu,...)
57892C z=1-2 : Mass eigenstate number
57893C...CALCULATE COUPLINGS
57894 DO 120 I = 11,15,2
57895 CMS=PMAS(PYCOMP(I),1)
57896C...Intermediate sleptons
57897 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
57898 & *(C2-C3*SINW**2))
57899 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
57900 & *(C2-C3*SINW**2))
57901 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
57902 & **2))
57903 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
57904 & **2))
57905C...Inermediate sneutrinos
57906 AB(1,I+1,1)=0D0
57907 AB(2,I+1,1)=5D-1*C3
57908 AB(1,I+1,2)=0D0
57909 AB(2,I+1,2)=0D0
57910C...Inermediate sdown
57911 J=I-10
57912 CMS=RMQ(J)
57913 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
57914 & *ED*(C2-C3*SINW**2))
57915 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
57916 & *ED*(C2-C3*SINW**2))
57917 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
57918 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57919 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
57920 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57921C...Inermediate sup
57922 J=J+1
57923 CMS=RMQ(J)
57924 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
57925 & *EU*(C2-C3*SINW**2))
57926 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
57927 & *EU*(C2-C3*SINW**2))
57928 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
57929 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57930 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
57931 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57932 120 CONTINUE
57933
57934 IF (IMSS(51).GE.1) THEN
57935C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
57936C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
57937C...STEP IN I,J,K USING SINGLE COUNTER
57938 DO 130 ISC=0,26
57939C...LAMBDA COUPLING ASYM IN I,J
57940 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57941 LKNT = LKNT+1
57942 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57943 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57944 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57945 XLAM(LKNT) = 0D0
57946C...Set coupling, and decay product masses on/off
57947 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57948 & ,MOD(ISC,3)+1)**2
57949 DCMASS=.FALSE.
57950 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
57951 & DCMASS = .TRUE.
57952C...Resonance KF codes (1=I,2=J,3=K)
57953 KFR(1)=-IDLAM(LKNT,1)
57954 KFR(2)=-IDLAM(LKNT,2)
57955 KFR(3)=-IDLAM(LKNT,3)
57956C...Calculate width.
57957 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57958 & IDLAM(LKNT,3),XLAM(LKNT))
57959 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57960C...Charge conjugate mode.
57961 LKNT=LKNT+1
57962 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57963 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57964 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57965 XLAM(LKNT)=XLAM(LKNT-1)
57966C...KINEMATICS CHECK
57967 IF (XLAM(LKNT).EQ.0D0) THEN
57968 LKNT=LKNT-2
57969 ENDIF
57970 ENDIF
57971 130 CONTINUE
57972 ENDIF
57973
57974 IF (IMSS(52).GE.1) THEN
57975C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
57976C * CHI0 -> NUBAR_I + DBAR_J + D_K
57977 DO 140 ISC=0,26
57978 LKNT = LKNT+1
57979 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57980 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57981 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57982 XLAM(LKNT) = 0D0
57983C...Set coupling, and decay product masses on/off
57984 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57985 & ,MOD(ISC,3)+1)**2
57986 DCMASS=.FALSE.
57987 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
57988 & DCMASS = .TRUE.
57989C...Resonance KF codes (1=I,2=J,3=K)
57990 KFR(1)=-IDLAM(LKNT,1)
57991 KFR(2)=-IDLAM(LKNT,2)
57992 KFR(3)=-IDLAM(LKNT,3)
57993C...Calculate width.
57994 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57995 & ,XLAM(LKNT))
57996 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57997C...Charge conjugate mode.
57998 LKNT=LKNT+1
57999 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
58000 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
58001 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
58002 XLAM(LKNT)=XLAM(LKNT-1)
58003C...KINEMATICS CHECK
58004 IF (XLAM(LKNT).EQ.0D0) THEN
58005 LKNT=LKNT-2
58006 ENDIF
58007
58008C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
58009 LKNT = LKNT+1
58010 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58011 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
58012 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
58013 XLAM(LKNT) = 0D0
58014C...Set coupling, and decay product masses on/off
58015 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
58016 & ,MOD(ISC,3)+1)**2
58017 DCMASS=.FALSE.
58018 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
58019 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
58020C...Resonance KF codes (1=I,2=J,3=K)
58021 KFR(1)=-IDLAM(LKNT,1)
58022 KFR(2)=-IDLAM(LKNT,2)
58023 KFR(3)=-IDLAM(LKNT,3)
58024C...Calculate width.
58025 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58026 & ,XLAM(LKNT))
58027 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58028C...Charge conjugate mode.
58029 LKNT=LKNT+1
58030 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
58031 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
58032 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
58033 XLAM(LKNT)=XLAM(LKNT-1)
58034C...KINEMATICS CHECK
58035 IF (XLAM(LKNT).EQ.0D0) THEN
58036 LKNT=LKNT-2
58037 ENDIF
58038 140 CONTINUE
58039 ENDIF
58040
58041 IF (IMSS(53).GE.1) THEN
58042C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
58043C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
58044 DO 150 ISC=0,26
58045C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
58046 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
58047 LKNT = LKNT+1
58048 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
58049 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58050 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58051 XLAM(LKNT) = 0D0
58052C...Set coupling, and decay product masses on/off
58053 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
58054 & +1,MOD(ISC,3)+1)**2
58055 DCMASS=.FALSE.
58056 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
58057 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
58058C...Resonance KF codes (1=I,2=J,3=K)
58059 KFR(1) = IDLAM(LKNT,1)
58060 KFR(2) = IDLAM(LKNT,2)
58061 KFR(3) = IDLAM(LKNT,3)
58062C...Calculate width.
58063 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58064 & IDLAM(LKNT,3),XLAM(LKNT))
58065 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58066C...Charge conjugate mode.
58067 LKNT=LKNT+1
58068 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
58069 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
58070 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
58071 XLAM(LKNT)=XLAM(LKNT-1)
58072C...KINEMATICS CHECK
58073 IF (XLAM(LKNT).EQ.0D0) THEN
58074 LKNT=LKNT-2
58075 ENDIF
58076 ENDIF
58077 150 CONTINUE
58078 ENDIF
58079 ENDIF
58080 ENDIF
58081
58082 RETURN
58083 END
58084
58085C*********************************************************************
58086
58087C...PYRVCH
58088C...Calculates R-violating chargino decay widths.
58089C...P. Z. Skands
58090
58091 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
58092
58093C...Double precision and integer declarations.
58094 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58095 IMPLICIT INTEGER(I-N)
58096C...Parameter statement to help give large particle numbers.
58097 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58098 &KEXCIT=4000000,KDIMEN=5000000)
58099C...Commonblocks.
58100 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58101 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58102 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
58103 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58104 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58105 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
58106C...Local variables.
58107 DOUBLE PRECISION XLAM(0:400)
58108 INTEGER IDLAM(400,3), PYCOMP
58109C...Information from main routine to PYRVGW
58110 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58111 & ,DCMASS,KFR(3)
58112C...Auxiliary variables needed for BV (RV Gauge STOre)
58113 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
58114 & ,RVLJKI,RVLJIK
58115C...Running quark masses
58116 DOUBLE PRECISION RMQ(6)
58117C...Decay product masses on/off
58118 LOGICAL DCMASS
58119 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
58120 & /RVGSTO/
58121
58122
58123C...IF R-VIOLATION ON.
58124 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
58125 KFSM=KFIN-KSUSY1
58126 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
58127C...WHICH CHARGINO ?
58128 NCHI = 1
58129 IF (KFSM.EQ.37) NCHI = 2
58130
58131C...Useful parameters for calculating the A and B constants.
58132C...SIGN OF MASS (Opposite convention as HERWIG)
58133 ISM = 1
58134 IF (SMW(NCHI).LT.0D0) ISM = -1
58135 WMASS = PMAS(PYCOMP(24),1)
58136 COSB = 1/(SQRT(1+RMSS(5)**2))
58137 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
58138 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
58139 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
58140 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
58141 C2 = UMIX(NCHI,1)
58142 C3 = VMIX(NCHI,1)
58143C...Running masses at Q^2=MCHI^2.
58144 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
58145 DO 100 I=1,6
58146 RMQ(I)=PYMRUN(I,SQMCHI)
58147 100 CONTINUE
58148
58149C... AB(x,y,z) coefficients:
58150C x=1-2 : A or B coefficient (1:A ; 2:B)
58151C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
58152C 11-16:e,nu_e,mu,...)
58153C z=1-2 : Mass eigenstate number
58154 DO 110 I = 11,15,2
58155C...Intermediate sleptons
58156 AB(1,I,1) = 0D0
58157 AB(1,I,2) = 0D0
58158 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
58159 & SFMIX(I,1)*C2
58160 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
58161 & SFMIX(I,3)*C2
58162C...Intermediate sneutrinos
58163 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
58164 AB(1,I+1,2) = 0D0
58165 AB(2,I+1,1) = ISM*C3
58166 AB(2,I+1,2) = 0D0
58167C...Intermediate sdown
58168 J=I-10
58169 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
58170 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
58171 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
58172 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
58173C...Intermediate sup
58174 J=J+1
58175 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
58176 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
58177 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
58178 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
58179 110 CONTINUE
58180
58181C...LLE TYPE R-VIOLATION
58182 IF (IMSS(51).GE.1) THEN
58183C...LOOP OVER DECAY MODES
58184 DO 140 ISC=0,26
58185
58186C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
58187 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
58188 LKNT = LKNT+1
58189 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
58190 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
58191 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
58192 XLAM(LKNT) = 0D0
58193C...Set coupling, and decay product masses on/off
58194 RVLAMC = GW2 * 5D-1 *
58195 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
58196 & **2
58197 DCMASS=.FALSE.
58198 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
58199C...Resonance KF codes (1=I,2=J,3=K).
58200 KFR(1) = 0
58201 KFR(2) = 0
58202 KFR(3) = -IDLAM(LKNT,3)+1
58203C...Calculate width.
58204 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58205 & IDLAM(LKNT,3),XLAM(LKNT))
58206 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58207C...KINEMATICS CHECK
58208 IF (XLAM(LKNT).EQ.0D0) THEN
58209 LKNT=LKNT-1
58210 ENDIF
58211
58212C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
58213 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
58214 LKNT = LKNT+1
58215 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
58216 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
58217 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
58218 XLAM(LKNT) = 0D0
58219C...Set coupling, and decay product masses on/off
58220 RVLAMC = GW2 * 5D-1 *
58221 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58222C...I,J SYMMETRY => FACTOR 2
58223 RVLAMC=2*RVLAMC
58224 DCMASS=.FALSE.
58225 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
58226C...Resonance KF codes (1=I,2=J,3=K)
58227 KFR(1)=IDLAM(LKNT,1)-1
58228 KFR(2)=IDLAM(LKNT,2)-1
58229 KFR(3)=0
58230C...Calculate width.
58231 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58232 & IDLAM(LKNT,3),XLAM(LKNT))
58233 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58234C...KINEMATICS CHECK
58235 IF (XLAM(LKNT).EQ.0D0) THEN
58236 LKNT=LKNT-1
58237 ENDIF
58238
58239C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K (NOTE: SYMM. IN I AND J)
58240C * 19/04 2010: Bug corrected. Moved channel inside the I < J IF statement
58241C * from above, thanks to N.-E. Bomark.
58242 LKNT = LKNT+1
58243 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58244 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
58245 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
58246 XLAM(LKNT) = 0D0
58247C...Set coupling, and decay product masses on/off
58248 RVLAMC = GW2 * 5D-1 *
58249 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58250C...I,J SYMMETRY => FACTOR 2
58251 RVLAMC=2*RVLAMC
58252 DCMASS=.FALSE.
58253 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
58254 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
58255C...Resonance KF codes (1=I,2=J,3=K)
58256 KFR(1) =-IDLAM(LKNT,1)+1
58257 KFR(2) =-IDLAM(LKNT,2)+1
58258 KFR(3) = 0
58259C...Calculate width.
58260 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58261 & IDLAM(LKNT,3),XLAM(LKNT))
58262 XLAM(LKNT)=XLAM(LKNT)*RVLAMC
58263 & /((2*PARU(1)*RMS(0))**3*32)
58264C...KINEMATICS CHECK
58265 IF (XLAM(LKNT).EQ.0D0) THEN
58266 LKNT=LKNT-1
58267 ENDIF
58268 ENDIF
58269 ENDIF
58270 140 CONTINUE
58271 ENDIF
58272
58273C...LQD TYPE R-VIOLATION
58274 IF (IMSS(52).GE.1) THEN
58275C...LOOP OVER DECAY MODES
58276 DO 180 ISC=0,26
58277
58278C...CHI+ -> NUBAR_I + DBAR_J + U_K
58279 LKNT = LKNT+1
58280 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
58281 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58282 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
58283 XLAM(LKNT) = 0D0
58284C...Set coupling, and decay product masses on/off
58285 RVLAMC = 3. * GW2 * 5D-1 *
58286 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58287 DCMASS=.FALSE.
58288 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
58289 & DCMASS = .TRUE.
58290C...Resonance KF codes (1=I,2=J,3=K)
58291 KFR(1)=0
58292 KFR(2)=0
58293 KFR(3)=-IDLAM(LKNT,3)+1
58294C...Calculate width.
58295 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58296 & ,XLAM(LKNT))
58297 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58298C...KINEMATICS CHECK
58299 IF (XLAM(LKNT).EQ.0D0) THEN
58300 LKNT=LKNT-1
58301 ENDIF
58302
58303C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
58304 150 LKNT = LKNT+1
58305 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58306 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
58307 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
58308 XLAM(LKNT) = 0D0
58309C...Set coupling, and decay product masses on/off
58310 RVLAMC = 3. * GW2 * 5D-1 *
58311 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58312 DCMASS=.FALSE.
58313 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
58314 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
58315C...Resonance KF codes (1=I,2=J,3=K)
58316 KFR(1)=0
58317 KFR(2)=0
58318 KFR(3)=-IDLAM(LKNT,3)+1
58319C...Calculate width.
58320 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58321 & ,XLAM(LKNT))
58322 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58323C...KINEMATICS CHECK
58324 IF (XLAM(LKNT).EQ.0D0) THEN
58325 LKNT=LKNT-1
58326 ENDIF
58327
58328C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
58329 160 LKNT = LKNT+1
58330 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58331 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58332 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
58333 XLAM(LKNT) = 0D0
58334C...Set coupling, and decay product masses on/off
58335 RVLAMC = 3. * GW2 * 5D-1 *
58336 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58337 DCMASS = .FALSE.
58338 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
58339 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
58340C...Resonance KF codes (1=I,2=J,3=K)
58341 KFR(1)=-IDLAM(LKNT,1)+1
58342 KFR(2)=-IDLAM(LKNT,2)+1
58343 KFR(3)=0
58344C...Calculate width.
58345 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58346 & ,XLAM(LKNT))
58347 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58348C...KINEMATICS CHECK
58349 IF (XLAM(LKNT).EQ.0D0) THEN
58350 LKNT=LKNT-1
58351 ENDIF
58352
58353C * CHI+ -> NU_I + U_J + DBAR_K.
58354 170 LKNT = LKNT+1
58355 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
58356 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
58357 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58358 XLAM(LKNT) = 0D0
58359C...Set coupling, and decay product masses on/off
58360 DCMASS = .FALSE.
58361 RVLAMC = 3. * GW2 * 5D-1 *
58362 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58363 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
58364 & DCMASS = .TRUE.
58365C...Resonance KF codes (1=I,2=J,3=K)
58366 KFR(1)=IDLAM(LKNT,1)-1
58367 KFR(2)=IDLAM(LKNT,2)-1
58368 KFR(3)=0
58369C...Calculate width.
58370 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58371 & ,XLAM(LKNT))
58372 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58373C...KINEMATICS CHECK
58374 IF (XLAM(LKNT).EQ.0D0) THEN
58375 LKNT=LKNT-1
58376 ENDIF
58377
58378 180 CONTINUE
58379 ENDIF
58380
58381C...UDD TYPE R-VIOLATION
58382C...These decays need special treatment since more than one BV coupling
58383C...contributes (with interference). Consider e.g. (symbolically)
58384C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
58385C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
58386C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
58387C...The problem is that a single call to PYRVGW would evaluate all
58388C...these terms and sum them, but without the different couplings. The
58389C...way out is to call PYRVGW three times, once for the first line, once
58390C...for the second line, and then once for all the lines (it is
58391C...impossible to get just the last line out) without multiplying by
58392C...couplings. The last line is then obtained as the result of the third
58393C...call minus the results of the two first calls. Each term is then
58394C...multiplied by its respective coupling before the whole thing is
58395C...summed up in XLAM.
58396C...Note that with three interfering resonances, this procedure becomes
58397C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
58398
58399 IF (IMSS(53).GE.1) THEN
58400C...LOOP OVER DECAY MODES
58401 DO 190 ISC=1,25
58402
58403C...CHI+ -> U_I + U_J + D_K
58404C...Decay mode I<->J symmetric.
58405 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
58406 LKNT = LKNT+1
58407 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
58408 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
58409 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
58410 XLAM(LKNT) = 0D0
58411C...Set coupling, and decay product masses on/off
58412 RVLAMC= 6. * GW2 * 5D-1
58413 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
58414 & +1)
58415 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
58416 & +1)
58417 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
58418 & * RVLAMC
58419 DCMASS=.FALSE.
58420 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
58421 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
58422C...Resonance KF codes (1=I,2=J,3=K)
58423 KFR(1) = -IDLAM(LKNT,1)+1
58424 KFR(2) = 0
58425 KFR(3) = 0
58426C...Calculate width.
58427 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58428 & IDLAM(LKNT,3),XRESI)
58429C...Resonance KF codes (1=I,2=J,3=K)
58430 KFR(1) = 0
58431 KFR(2) = -IDLAM(LKNT,2)+1
58432 KFR(3) = 0
58433C...Calculate width.
58434 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58435 & IDLAM(LKNT,3),XRESJ)
58436C...Resonance KF codes (1=I,2=J,3=K)
58437 KFR(1) = -IDLAM(LKNT,1)+1
58438 KFR(2) = -IDLAM(LKNT,2)+1
58439 KFR(3) = 0
58440C...Calculate width.
58441 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58442 & IDLAM(LKNT,3),XRESIJ)
58443 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
58444 XRESIJ = XRESIJ-XRESI-XRESJ
58445 ELSE
58446 XRESIJ = 0D0
58447 ENDIF
58448C...CALCULATE TOTAL WIDTH
58449 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
58450 & + RVLJIK*RVLIJK * XRESIJ
58451 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58452C...KINEMATICS CHECK
58453 IF (XLAM(LKNT).EQ.0D0) THEN
58454 LKNT=LKNT-1
58455 ENDIF
58456 ENDIF
58457C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
58458C...Symmetry I<->J<->K.
58459 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
58460 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
58461 LKNT = LKNT+1
58462 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
58463 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58464 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58465 XLAM(LKNT) = 0D0
58466C...Set coupling, and decay product masses on/off
58467 RVLAMC = 6. * GW2 * 5D-1
58468 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
58469 & +1)
58470 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
58471 & +1)
58472 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
58473 & +1)
58474 DCMASS = .FALSE.
58475 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
58476 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
58477C...Collect symmetry factors
58478 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
58479 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
58480 & RVLAMC = 5D-1 * RVLAMC
58481C...Resonance KF codes (1=I,2=J,3=K)
58482 KFR(1) = IDLAM(LKNT,1)-1
58483 KFR(2) = 0
58484 KFR(3) = 0
58485C...Calculate width.
58486 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58487 & IDLAM(LKNT,3),XRESI)
58488C...Resonance KF codes (1=I,2=J,3=K)
58489 KFR(1) = 0
58490 KFR(2) = IDLAM(LKNT,2)-1
58491 KFR(3) = 0
58492C...Calculate width.
58493 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58494 & IDLAM(LKNT,3),XRESJ)
58495C...Resonance KF codes (1=I,2=J,3=K)
58496 KFR(1) = 0
58497 KFR(2) = 0
58498 KFR(3) = IDLAM(LKNT,3)-1
58499C...Calculate width.
58500 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58501 & IDLAM(LKNT,3),XRESK)
58502C...Resonance KF codes (1=I,2=J,3=K)
58503 KFR(1) = IDLAM(LKNT,1)-1
58504 KFR(2) = IDLAM(LKNT,2)-1
58505 KFR(3) = 0
58506C...Calculate width.
58507 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58508 & IDLAM(LKNT,3),XRESIJ)
58509 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*(XRESI+XRESJ)) THEN
58510 XRESIJ = XRESI+XRESJ-XRESIJ
58511 ELSE
58512 XRESIJ = 0D0
58513 ENDIF
58514C...Resonance KF codes (1=I,2=J,3=K)
58515 KFR(1) = 0
58516 KFR(2) = IDLAM(LKNT,2)-1
58517 KFR(3) = IDLAM(LKNT,3)-1
58518C...Calculate width.
58519 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58520 & IDLAM(LKNT,3),XRESJK)
58521 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*(XRESJ+XRESK)) THEN
58522 XRESJK = XRESJ+XRESK-XRESJK
58523 ELSE
58524 XRESJK = 0D0
58525 ENDIF
58526C...Resonance KF codes (1=I,2=J,3=K)
58527 KFR(1) = IDLAM(LKNT,1)-1
58528 KFR(2) = 0
58529 KFR(3) = IDLAM(LKNT,3)-1
58530C...Calculate width.
58531 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58532 & IDLAM(LKNT,3),XRESIK)
58533 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*(XRESI+XRESK)) THEN
58534 XRESIK = XRESI+XRESK-XRESIK
58535 ELSE
58536 XRESIK = 0D0
58537 ENDIF
58538C...CALCULATE TOTAL WIDTH
58539 XLAM(LKNT) =
58540 & RVLIJK**2 * XRESI
58541 & + RVLJKI**2 * XRESJ
58542 & + RVLKIJ**2 * XRESK
58543 & + RVLIJK*RVLJKI * XRESIJ
58544 & + RVLIJK*RVLKIJ * XRESIK
58545 & + RVLJKI*RVLKIJ * XRESJK
58546 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
58547C...KINEMATICS CHECK
58548 IF (XLAM(LKNT).EQ.0D0) THEN
58549 LKNT=LKNT-1
58550 ENDIF
58551 ENDIF
58552 190 CONTINUE
58553 ENDIF
58554 ENDIF
58555 ENDIF
58556
58557 RETURN
58558 END
58559
58560C*********************************************************************
58561
58562C...PYRVGL
58563C...Calculates R-violating gluino decay widths.
58564C...See BV part of PYRVCH for comments about the way the BV decay width
58565C...is calculated. Same comments apply here.
58566C...P. Z. Skands
58567
58568 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
58569
58570C...Double precision and integer declarations.
58571 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58572 IMPLICIT INTEGER(I-N)
58573C...Parameter statement to help give large particle numbers.
58574 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58575 &KEXCIT=4000000,KDIMEN=5000000)
58576C...Commonblocks.
58577 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58578 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58579 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
58580 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58581 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58582 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
58583C...Local variables.
58584 DOUBLE PRECISION XLAM(0:400)
58585 INTEGER IDLAM(400,3), PYCOMP
58586C...Information from main routine to PYRVGW
58587 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58588 & ,DCMASS,KFR(3)
58589C...Auxiliary variables needed for BV (RV Gauge STOre)
58590 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
58591 & ,RVLJKI,RVLJIK
58592C...Running quark masses
58593 DOUBLE PRECISION RMQ(6)
58594C...Decay product masses on/off
58595 LOGICAL DCMASS
58596 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
58597 & /RVGSTO/
58598
58599C...IF LQD OR UDD TYPE R-VIOLATION ON.
58600 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
58601 KFSM=KFIN-KSUSY1
58602
58603C... AB(x,y,z):
58604C x=1-2 : Select A or B coupling (1:A ; 2:B)
58605C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
58606C 11-16:e,nu_e,mu,... not used here)
58607C z=1-2 : Mass eigenstate number
58608 DO 100 I = 1,6
58609C...A Couplings
58610 AB(1,I,1) = SFMIX(I,2)
58611 AB(1,I,2) = SFMIX(I,4)
58612C...B Couplings
58613 AB(2,I,1) = -SFMIX(I,1)
58614 AB(2,I,2) = -SFMIX(I,3)
58615 100 CONTINUE
58616 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
58617C...LQD DECAYS.
58618 IF (IMSS(52).GE.1) THEN
58619C...STEP IN I,J,K USING SINGLE COUNTER
58620 DO 120 ISC=0,26
58621C * GLUINO -> NUBAR_I + DBAR_J + D_K.
58622 LKNT = LKNT+1
58623 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
58624 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58625 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
58626 XLAM(LKNT)=0D0
58627C...Set coupling, and decay product masses on/off
58628 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58629 & * 5D-1 * GSTR2
58630 DCMASS = .FALSE.
58631 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
58632C...Resonance KF codes (1=I,2=J,3=K)
58633 KFR(1) = 0
58634 KFR(2) = -IDLAM(LKNT,2)
58635 KFR(3) = -IDLAM(LKNT,3)
58636C...Calculate width.
58637 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58638 & ,XLAM(LKNT))
58639C...Normalize
58640 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58641C...Charge conjugate mode.
58642 110 LKNT = LKNT+1
58643 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
58644 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
58645 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
58646 XLAM(LKNT) = XLAM(LKNT-1)
58647C...KINEMATICS CHECK
58648 IF (XLAM(LKNT).EQ.0D0) THEN
58649 LKNT=LKNT-2
58650 ENDIF
58651
58652C * GLUINO -> LEPTON+_I + UBAR_J + D_K
58653 LKNT = LKNT+1
58654 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58655 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
58656 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
58657 XLAM(LKNT)=0D0
58658C...Set coupling, and decay product masses on/off
58659 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
58660 & **2* 5D-1 * GSTR2
58661 DCMASS = .FALSE.
58662 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
58663 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
58664C...Resonance KF codes (1=I,2=J,3=K)
58665 KFR(1) = 0
58666 KFR(2) = -IDLAM(LKNT,2)
58667 KFR(3) = -IDLAM(LKNT,3)
58668C...Calculate width.
58669 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58670 & ,XLAM(LKNT))
58671 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58672C...Charge conjugate mode.
58673 LKNT=LKNT+1
58674 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
58675 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
58676 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
58677 XLAM(LKNT) = XLAM(LKNT-1)
58678C...KINEMATICS CHECK
58679 IF (XLAM(LKNT).EQ.0D0) THEN
58680 LKNT=LKNT-2
58681 ENDIF
58682
58683 120 CONTINUE
58684 ENDIF
58685
58686C...UDD DECAYS.
58687 IF (IMSS(53).GE.1) THEN
58688C...STEP IN I,J,K USING SINGLE COUNTER
58689 DO 130 ISC=0,26
58690C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
58691 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
58692 LKNT = LKNT+1
58693 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
58694 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58695 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58696 XLAM(LKNT)=0D0
58697C...Set coupling, and decay product masses on/off. A factor of 2 for
58698C...(N_C-1) has been used to cancel a factor 0.5.
58699 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
58700 & **2 * GSTR2
58701 DCMASS = .FALSE.
58702 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
58703 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
58704C...Resonance KF codes (1=I,2=J,3=K)
58705 KFR(1) = IDLAM(LKNT,1)
58706 KFR(2) = 0
58707 KFR(3) = 0
58708C...Calculate width.
58709 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58710 & ,XRESI)
58711C...Resonance KF codes (1=I,2=J,3=K)
58712 KFR(1) = 0
58713 KFR(2) = IDLAM(LKNT,2)
58714 KFR(3) = 0
58715C...Calculate width.
58716 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58717 & ,XRESJ)
58718C...Resonance KF codes (1=I,2=J,3=K)
58719 KFR(1) = 0
58720 KFR(2) = 0
58721 KFR(3) = IDLAM(LKNT,3)
58722C...Calculate width.
58723 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58724 & ,XRESK)
58725C...Resonance KF codes (1=I,2=J,3=K)
58726 KFR(1) = IDLAM(LKNT,1)
58727 KFR(2) = IDLAM(LKNT,2)
58728 KFR(3) = 0
58729C...Calculate width.
58730 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58731 & ,XRESIJ)
58732C...Calculate interference function. (Factor -1/2 to make up for factor
58733C...-2 in PYRVGW.
58734 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
58735 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
58736 ELSE
58737 XRESIJ = 0D0
58738 ENDIF
58739C...Resonance KF codes (1=I,2=J,3=K)
58740 KFR(1) = 0
58741 KFR(2) = IDLAM(LKNT,2)
58742 KFR(3) = IDLAM(LKNT,3)
58743C...Calculate width.
58744 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58745 & ,XRESJK)
58746 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*XRESJK) THEN
58747 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
58748 ELSE
58749 XRESJK = 0D0
58750 ENDIF
58751C...Resonance KF codes (1=I,2=J,3=K)
58752 KFR(1) = IDLAM(LKNT,1)
58753 KFR(2) = 0
58754 KFR(3) = IDLAM(LKNT,3)
58755C...Calculate width.
58756 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58757 & ,XRESIK)
58758 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*XRESIK) THEN
58759 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
58760 ELSE
58761 XRESIK = 0D0
58762 ENDIF
58763C...Calculate total width (factor 1/2 from 1/(N_C-1))
58764 XLAM(LKNT) = XRESI + XRESJ + XRESK
58765 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
58766C...Normalize
58767 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58768C...Charge conjugate mode.
58769 LKNT = LKNT+1
58770 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
58771 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
58772 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
58773 XLAM(LKNT) = XLAM(LKNT-1)
58774C...KINEMATICS CHECK
58775 IF (XLAM(LKNT).EQ.0D0) THEN
58776 LKNT=LKNT-2
58777 ENDIF
58778 ENDIF
58779 130 CONTINUE
58780 ENDIF
58781 ENDIF
58782 RETURN
58783 END
58784
58785C*********************************************************************
58786
58787C...PYRVSB
58788C...Auxiliary function to PYRVSF for calculating R-Violating
58789C...sfermion widths. Though the decay products are most often treated
58790C...as massless in the calculation, the kinematical boundary of phase
58791C...space is tested using the true masses.
58792C...MODE = 1: All decay products massive
58793C...MODE = 2: Decay product 1 massless
58794C...MODE = 3: Decay product 2 massless
58795C...MODE = 4: All decay products massless
58796
58797 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
58798
58799 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
58800 IMPLICIT INTEGER (I-N)
58801 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58802 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58803 SAVE /PYDAT1/,/PYDAT2/
58804 DOUBLE PRECISION SM(3)
58805 INTEGER PYCOMP, KC(3)
58806 KC(1)=PYCOMP(KFIN)
58807 KC(2)=PYCOMP(ID1)
58808 KC(3)=PYCOMP(ID2)
58809 SM(1)=PMAS(KC(1),1)**2
58810 SM(2)=PMAS(KC(2),1)**2
58811 SM(3)=PMAS(KC(3),1)**2
58812C...Kinematics check
58813 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
58814 PYRVSB=0D0
58815 RETURN
58816 ENDIF
58817C...CM momenta squared
58818 IF (MODE.EQ.1) THEN
58819 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
58820 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
58821 ELSE IF (MODE.EQ.2) THEN
58822 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
58823 ELSE IF (MODE.EQ.3) THEN
58824 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
58825 ELSE
58826 P2CM=SM(1)/4.
58827 ENDIF
58828C...Calculate Width
58829 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
58830 RETURN
58831 END
58832
58833C*********************************************************************
58834
58835C...PYRVGW
58836C...Generalized Matrix Element for R-Violating 3-body widths.
58837C...P. Z. Skands
58838 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
58839
58840 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
58841 IMPLICIT INTEGER (I-N)
58842 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58843 &KEXCIT=4000000,KDIMEN=5000000)
58844 PARAMETER (EPS=1D-4)
58845 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58846 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58847 & ,DCMASS,KFR(3)
58848 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58849 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58850 DOUBLE PRECISION XLIM(3,3)
58851 INTEGER KC(0:3), PYCOMP
58852 LOGICAL DCMASS, DCHECK(6)
58853 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
58854
58855 XLAM = 0D0
58856
58857 KC(0) = PYCOMP(KFIN)
58858 KC(1) = PYCOMP(ID1)
58859 KC(2) = PYCOMP(ID2)
58860 KC(3) = PYCOMP(ID3)
58861 RMS(0) = PMAS(KC(0),1)
58862 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
58863 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
58864 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
58865C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
58866 XLIM(1,1)=(RMS(1)+RMS(2))**2
58867 XLIM(1,2)=(RMS(0)-RMS(3))**2
58868 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
58869 XLIM(2,1)=(RMS(2)+RMS(3))**2
58870 XLIM(2,2)=(RMS(0)-RMS(1))**2
58871 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
58872 XLIM(3,1)=(RMS(1)+RMS(3))**2
58873 XLIM(3,2)=(RMS(0)-RMS(2))**2
58874 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
58875C...Check Phase Space
58876 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
58877 RETURN
58878 ENDIF
58879
58880C...INITIALIZE RESONANCE INFORMATION
58881 DO 110 JRES = 1,3
58882 DO 100 IMASS = 1,2
58883 IRES = 2*(JRES-1)+IMASS
58884 INTRES(IRES,1) = 0
58885 DCHECK(IRES) =.FALSE.
58886C...NO RIGHT-HANDED NEUTRINOS
58887 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
58888 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
58889 & .KFR(JRES).EQ.0) GOTO 100
58890 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
58891 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
58892 INTRES(IRES,1) = IABS(KFR(JRES))
58893 INTRES(IRES,2) = IMASS
58894 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
58895 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
58896 100 CONTINUE
58897 110 CONTINUE
58898
58899C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
58900
58901C...RESONANCE CONTRIBUTIONS
58902C...(Only sum contributions where the resonance is off shell).
58903C...Store whether diagram on/off in DCHECK.
58904C...LOOP OVER MASS STATES
58905 DO 120 J=1,2
58906 IDR=J
58907 IF(INTRES(IDR,1).NE.0) THEN
58908
58909 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58910 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
58911 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58912 DCHECK(IDR) =.TRUE.
58913 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
58914 ENDIF
58915 ENDIF
58916
58917 IDR=J+2
58918 IF(INTRES(IDR,1).NE.0) THEN
58919 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58920 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58921 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58922 DCHECK(IDR) =.TRUE.
58923 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
58924 ENDIF
58925 ENDIF
58926
58927 IDR=J+4
58928 IF(INTRES(IDR,1).NE.0) THEN
58929 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58930 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58931 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58932 DCHECK(IDR) =.TRUE.
58933 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
58934 ENDIF
58935 ENDIF
58936 120 CONTINUE
58937C... L-R INTERFERENCES
58938C... (Only add contributions where both contributing diagrams
58939C... are non-resonant).
58940 IDR=1
58941 IF (DCHECK(1).AND.DCHECK(2)) THEN
58942C...Bug corrected 11/12 2001. Skands.
58943 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
58944 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
58945 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
58946 ENDIF
58947
58948 IDR=3
58949 IF (DCHECK(3).AND.DCHECK(4)) THEN
58950 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
58951 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
58952 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
58953 ENDIF
58954
58955 IDR=5
58956 IF (DCHECK(5).AND.DCHECK(6)) THEN
58957 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
58958 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
58959 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
58960 ENDIF
58961C... TRUE INTERFERENCES
58962C... (Only add contributions where both contributing diagrams
58963C... are non-resonant).
58964 PREF=-2D0
58965 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
58966 DO 140 IKR1 = 1,2
58967 DO 130 IKR2 = 1,2
58968 IDR = IKR1+2
58969 IDR2 = IKR2
58970 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58971 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
58972 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58973 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58974 ENDIF
58975
58976 IDR = IKR1+4
58977 IDR2 = IKR2
58978 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58979 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
58980 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58981 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58982 ENDIF
58983
58984 IDR = IKR1+4
58985 IDR2 = IKR2+2
58986 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58987 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
58988 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58989 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58990 ENDIF
58991 130 CONTINUE
58992 140 CONTINUE
58993
58994 RETURN
58995 END
58996
58997C*********************************************************************
58998
58999C...PYRVI1
59000C...Function to integrate resonance contributions
59001
59002 FUNCTION PYRVI1(ID1,ID2,ID3)
59003
59004 IMPLICIT NONE
59005 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
59006 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
59007 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
59008 LOGICAL MFLAG,DCMASS
59009 EXTERNAL PYRVG1,PYGAUS
59010 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
59011 & ,DCMASS,KFR(3)
59012 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59013 SAVE/PYRVNV/,/PYRVPM/
59014C...Initialize mass and width information
59015 PYRVI1 = 0D0
59016 RM(0) = RMS(0)
59017 RM(1) = RMS(ID1)
59018 RM(2) = RMS(ID2)
59019 RM(3) = RMS(ID3)
59020 RESM(1)= RES(IDR,1)
59021 RESW(1)= RES(IDR,2)
59022C...A->B and B->A for antisparticles
59023 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59024 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59025C...Integration boundaries and mass flag
59026 LO = (RM(1)+RM(2))**2
59027 HI = (RM(0)-RM(3))**2
59028 MFLAG = DCMASS
59029 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
59030 RETURN
59031 END
59032
59033C*********************************************************************
59034
59035C...PYRVI2
59036C...Function to integrate L-R interference contributions
59037
59038 FUNCTION PYRVI2(ID1,ID2,ID3)
59039
59040 IMPLICIT NONE
59041 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
59042 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
59043 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
59044 LOGICAL MFLAG,DCMASS
59045 EXTERNAL PYRVG2,PYGAUS
59046 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
59047 & ,DCMASS,KFR(3)
59048 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59049 SAVE/PYRVNV/,/PYRVPM/
59050C...Initialize mass and width information
59051 PYRVI2 = 0D0
59052 RM(0) = RMS(0)
59053 RM(1) = RMS(ID1)
59054 RM(2) = RMS(ID2)
59055 RM(3) = RMS(ID3)
59056 RESM(1)= RES(IDR,1)
59057 RESW(1)= RES(IDR,2)
59058 RESM(2)= RES(IDR+1,1)
59059 RESW(2)= RES(IDR+1,2)
59060C...A->B and B->A for antisparticles
59061 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59062 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59063 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
59064 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
59065C...Boundaries and mass flag
59066 LO = (RM(1)+RM(2))**2
59067 HI = (RM(0)-RM(3))**2
59068 MFLAG = DCMASS
59069 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
59070 RETURN
59071 END
59072
59073C*********************************************************************
59074
59075C...PYRVI3
59076C...Function to integrate true interference contributions
59077
59078 FUNCTION PYRVI3(ID1,ID2,ID3)
59079
59080 IMPLICIT NONE
59081 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
59082 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
59083 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
59084 LOGICAL MFLAG,DCMASS
59085 EXTERNAL PYRVG3,PYGAUS
59086 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
59087 & ,DCMASS,KFR(3)
59088 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59089 SAVE/PYRVNV/,/PYRVPM/
59090C...Initialize mass and width information
59091 PYRVI3 = 0D0
59092 RM(0) = RMS(0)
59093 RM(1) = RMS(ID1)
59094 RM(2) = RMS(ID2)
59095 RM(3) = RMS(ID3)
59096 RESM(1)= RES(IDR,1)
59097 RESW(1)= RES(IDR,2)
59098 RESM(2)= RES(IDR2,1)
59099 RESW(2)= RES(IDR2,2)
59100C...A -> B and B -> A for antisparticles
59101 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59102 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59103 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
59104 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
59105C...Boundaries and mass flag
59106 LO = (RM(1)+RM(2))**2
59107 HI = (RM(0)-RM(3))**2
59108 MFLAG = DCMASS
59109 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
59110 RETURN
59111 END
59112
59113C*********************************************************************
59114
59115C...PYRVG1
59116C...Integrand for resonance contributions
59117
59118 FUNCTION PYRVG1(X)
59119
59120 IMPLICIT NONE
59121 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59122 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
59123 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
59124 LOGICAL MFLAG
59125 SAVE/PYRVPM/
59126 RVR = PYRVR(X,RESM(1),RESW(1))
59127 C1 = 2D0*SQRT(MAX(0D0,X))
59128 IF (.NOT.MFLAG) THEN
59129 E2 = X/C1
59130 E3 = (RM(0)**2-X)/C1
59131 DELTAY = 4D0*E2*E3
59132 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
59133 ELSE
59134 E2 = (X-RM(1)**2+RM(2)**2)/C1
59135 E3 = (RM(0)**2-X-RM(3)**2)/C1
59136 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
59137 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
59138 DELTAY = 4D0*SR1*SR2
59139 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
59140 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
59141 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
59142 ENDIF
59143 RETURN
59144 END
59145
59146C*********************************************************************
59147
59148C...PYRVG2
59149C...Integrand for L-R interference contributions
59150
59151 FUNCTION PYRVG2(X)
59152
59153 IMPLICIT NONE
59154 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59155 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
59156 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
59157 LOGICAL MFLAG
59158 SAVE/PYRVPM/
59159 C1 = 2D0*SQRT(MAX(0D0,X))
59160 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
59161 IF (.NOT.MFLAG) THEN
59162 E2 = X/C1
59163 E3 = (RM(0)**2-X)/C1
59164 DELTAY = 4D0*E2*E3
59165 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
59166 ELSE
59167 E2 = (X-RM(1)**2+RM(2)**2)/C1
59168 E3 = (RM(0)**2-X-RM(3)**2)/C1
59169 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
59170 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
59171 DELTAY = 4D0*SR1*SR2
59172 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
59173 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
59174 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
59175 ENDIF
59176 RETURN
59177 END
59178
59179C*********************************************************************
59180
59181C...PYRVG3
59182C...Function to do Y integration over true interference contributions
59183
59184 FUNCTION PYRVG3(X)
59185
59186 IMPLICIT NONE
59187 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59188C...Second Dalitz variable for PYRVG4
59189 COMMON/PYG2DX/X1
59190 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
59191 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
59192 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
59193 LOGICAL MFLAG
59194 EXTERNAL PYGAU2,PYRVG4
59195 SAVE/PYRVPM/,/PYG2DX/
59196 PYRVG3=0D0
59197 C1=2D0*SQRT(MAX(1D-9,X))
59198 X1=X
59199 IF (.NOT.MFLAG) THEN
59200 E2 = X/C1
59201 E3 = (RM(0)**2-X)/C1
59202 YMIN = 0D0
59203 YMAX = 4D0*E2*E3
59204 ELSE
59205 E2 = (X-RM(1)**2+RM(2)**2)/C1
59206 E3 = (RM(0)**2-X-RM(3)**2)/C1
59207 SQ1 = (E2+E3)**2
59208 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
59209 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
59210 YMIN = SQ1-(SR1+SR2)**2
59211 YMAX = SQ1-(SR1-SR2)**2
59212 ENDIF
59213 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
59214 RETURN
59215 END
59216
59217C*********************************************************************
59218
59219C...PYRVG4
59220C...Integrand for true intereference contributions
59221
59222 FUNCTION PYRVG4(Y)
59223
59224 IMPLICIT NONE
59225 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59226 COMMON/PYG2DX/X
59227 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
59228 LOGICAL MFLAG
59229 SAVE /PYRVPM/,/PYG2DX/
59230 PYRVG4=0D0
59231 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
59232 IF (.NOT.MFLAG) THEN
59233 PYRVG4 = RVS*B(1)*B(2)*X*Y
59234 ELSE
59235 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
59236 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
59237 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
59238 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
59239 ENDIF
59240 RETURN
59241 END
59242
59243C*********************************************************************
59244
59245C...PYRVR
59246C...Breit-Wigner for resonance contributions
59247
59248 FUNCTION PYRVR(Mab2,RM,RW)
59249
59250 IMPLICIT NONE
59251 DOUBLE PRECISION Mab2,RM,RW,PYRVR
59252 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
59253 RETURN
59254 END
59255
59256C*********************************************************************
59257
59258C...PYRVS
59259C...Interference function
59260
59261 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
59262
59263 IMPLICIT NONE
59264 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
59265 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
59266 & +W1*W2*M1*M2)
59267 RETURN
59268 END
59269
59270C*********************************************************************
59271
59272C...PY1ENT
59273C...Stores one parton/particle in commonblock PYJETS.
59274
59275 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
59276
59277C...Double precision and integer declarations.
59278 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59279 IMPLICIT INTEGER(I-N)
59280 INTEGER PYK,PYCHGE,PYCOMP
59281C...Commonblocks.
59282 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59283 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59284 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59285 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59286
59287C...Standard checks.
59288 MSTU(28)=0
59289 IF(MSTU(12).NE.12345) CALL PYLIST(0)
59290 IPA=MAX(1,IABS(IP))
59291 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
59292 &'(PY1ENT:) writing outside PYJETS memory')
59293 KC=PYCOMP(KF)
59294 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
59295
59296C...Find mass. Reset K, P and V vectors.
59297 PM=0D0
59298 IF(MSTU(10).EQ.1) PM=P(IPA,5)
59299 IF(MSTU(10).GE.2) PM=PYMASS(KF)
59300 DO 100 J=1,5
59301 K(IPA,J)=0
59302 P(IPA,J)=0D0
59303 V(IPA,J)=0D0
59304 100 CONTINUE
59305
59306C...Store parton/particle in K and P vectors.
59307 K(IPA,1)=1
59308 IF(IP.LT.0) K(IPA,1)=2
59309 K(IPA,2)=KF
59310 P(IPA,5)=PM
59311 P(IPA,4)=MAX(PE,PM)
59312 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
59313 P(IPA,1)=PA*SIN(THE)*COS(PHI)
59314 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
59315 P(IPA,3)=PA*COS(THE)
59316
59317C...Set N. Optionally fragment/decay.
59318 N=IPA
59319 IF(IP.EQ.0) CALL PYEXEC
59320
59321 RETURN
59322 END
59323
59324C*********************************************************************
59325
59326C...PY2ENT
59327C...Stores two partons/particles in their CM frame,
59328C...with the first along the +z axis.
59329
59330 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
59331
59332C...Double precision and integer declarations.
59333 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59334 IMPLICIT INTEGER(I-N)
59335 INTEGER PYK,PYCHGE,PYCOMP
59336C...Commonblocks.
59337 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59338 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59339 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59340 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59341
59342C...Standard checks.
59343 MSTU(28)=0
59344 IF(MSTU(12).NE.12345) CALL PYLIST(0)
59345 IPA=MAX(1,IABS(IP))
59346 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
59347 &'(PY2ENT:) writing outside PYJETS memory')
59348 KC1=PYCOMP(KF1)
59349 KC2=PYCOMP(KF2)
59350 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
59351 &'(PY2ENT:) unknown flavour code')
59352
59353C...Find masses. Reset K, P and V vectors.
59354 PM1=0D0
59355 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
59356 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
59357 PM2=0D0
59358 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
59359 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
59360 DO 110 I=IPA,IPA+1
59361 DO 100 J=1,5
59362 K(I,J)=0
59363 P(I,J)=0D0
59364 V(I,J)=0D0
59365 100 CONTINUE
59366 110 CONTINUE
59367
59368C...Check flavours.
59369 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
59370 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
59371 IF(MSTU(19).EQ.1) THEN
59372 MSTU(19)=0
59373 ELSE
59374 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
59375 & '(PY2ENT:) unphysical flavour combination')
59376 ENDIF
59377 K(IPA,2)=KF1
59378 K(IPA+1,2)=KF2
59379
59380C...Store partons/particles in K vectors for normal case.
59381 IF(IP.GE.0) THEN
59382 K(IPA,1)=1
59383 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
59384 K(IPA+1,1)=1
59385
59386C...Store partons in K vectors for parton shower evolution.
59387 ELSE
59388 K(IPA,1)=3
59389 K(IPA+1,1)=3
59390 K(IPA,4)=MSTU(5)*(IPA+1)
59391 K(IPA,5)=K(IPA,4)
59392 K(IPA+1,4)=MSTU(5)*IPA
59393 K(IPA+1,5)=K(IPA+1,4)
59394 ENDIF
59395
59396C...Check kinematics and store partons/particles in P vectors.
59397 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
59398 &'(PY2ENT:) energy smaller than sum of masses')
59399 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
59400 &(2D0*PECM)
59401 P(IPA,3)=PA
59402 P(IPA,4)=SQRT(PM1**2+PA**2)
59403 P(IPA,5)=PM1
59404 P(IPA+1,3)=-PA
59405 P(IPA+1,4)=SQRT(PM2**2+PA**2)
59406 P(IPA+1,5)=PM2
59407
59408C...Set N. Optionally fragment/decay.
59409 N=IPA+1
59410 IF(IP.EQ.0) CALL PYEXEC
59411
59412 RETURN
59413 END
59414
59415C*********************************************************************
59416
59417C...PY3ENT
59418C...Stores three partons or particles in their CM frame,
59419C...with the first along the +z axis and the third in the (x,z)
59420C...plane with x > 0.
59421
59422 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
59423
59424C...Double precision and integer declarations.
59425 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59426 IMPLICIT INTEGER(I-N)
59427 INTEGER PYK,PYCHGE,PYCOMP
59428C...Commonblocks.
59429 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59430 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59431 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59432 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59433
59434C...Standard checks.
59435 MSTU(28)=0
59436 IF(MSTU(12).NE.12345) CALL PYLIST(0)
59437 IPA=MAX(1,IABS(IP))
59438 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
59439 &'(PY3ENT:) writing outside PYJETS memory')
59440 KC1=PYCOMP(KF1)
59441 KC2=PYCOMP(KF2)
59442 KC3=PYCOMP(KF3)
59443 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
59444 &'(PY3ENT:) unknown flavour code')
59445
59446C...Find masses. Reset K, P and V vectors.
59447 PM1=0D0
59448 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
59449 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
59450 PM2=0D0
59451 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
59452 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
59453 PM3=0D0
59454 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
59455 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
59456 DO 110 I=IPA,IPA+2
59457 DO 100 J=1,5
59458 K(I,J)=0
59459 P(I,J)=0D0
59460 V(I,J)=0D0
59461 100 CONTINUE
59462 110 CONTINUE
59463
59464C...Check flavours.
59465 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
59466 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
59467 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
59468 IF(MSTU(19).EQ.1) THEN
59469 MSTU(19)=0
59470 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
59471 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
59472 & KQ1+KQ3.EQ.4)) THEN
59473 ELSE
59474 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
59475 ENDIF
59476 K(IPA,2)=KF1
59477 K(IPA+1,2)=KF2
59478 K(IPA+2,2)=KF3
59479
59480C...Store partons/particles in K vectors for normal case.
59481 IF(IP.GE.0) THEN
59482 K(IPA,1)=1
59483 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
59484 K(IPA+1,1)=1
59485 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
59486 K(IPA+2,1)=1
59487
59488C...Store partons in K vectors for parton shower evolution.
59489 ELSE
59490 K(IPA,1)=3
59491 K(IPA+1,1)=3
59492 K(IPA+2,1)=3
59493 KCS=4
59494 IF(KQ1.EQ.-1) KCS=5
59495 K(IPA,KCS)=MSTU(5)*(IPA+1)
59496 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
59497 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
59498 K(IPA+1,9-KCS)=MSTU(5)*IPA
59499 K(IPA+2,KCS)=MSTU(5)*IPA
59500 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
59501 ENDIF
59502
59503C...Check kinematics.
59504 MKERR=0
59505 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
59506 &0.5D0*X3*PECM.LE.PM3) MKERR=1
59507 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
59508 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
59509 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
59510 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
59511 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
59512 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
59513 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
59514 IF(MKERR.NE.0) CALL PYERRM(13,
59515 &'(PY3ENT:) unphysical kinematical variable setup')
59516
59517C...Store partons/particles in P vectors.
59518 P(IPA,3)=PA1
59519 P(IPA,4)=SQRT(PA1**2+PM1**2)
59520 P(IPA,5)=PM1
59521 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
59522 P(IPA+2,3)=PA3*CTHE3
59523 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
59524 P(IPA+2,5)=PM3
59525 P(IPA+1,1)=-P(IPA+2,1)
59526 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
59527 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
59528 P(IPA+1,5)=PM2
59529
59530C...Set N. Optionally fragment/decay.
59531 N=IPA+2
59532 IF(IP.EQ.0) CALL PYEXEC
59533
59534 RETURN
59535 END
59536
59537C*********************************************************************
59538
59539C...PY4ENT
59540C...Stores four partons or particles in their CM frame, with
59541C...the first along the +z axis, the last in the xz plane with x > 0
59542C...and the second having y < 0 and y > 0 with equal probability.
59543
59544 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
59545
59546C...Double precision and integer declarations.
59547 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59548 IMPLICIT INTEGER(I-N)
59549 INTEGER PYK,PYCHGE,PYCOMP
59550C...Commonblocks.
59551 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59552 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59553 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59554 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59555
59556C...Standard checks.
59557 MSTU(28)=0
59558 IF(MSTU(12).NE.12345) CALL PYLIST(0)
59559 IPA=MAX(1,IABS(IP))
59560 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
59561 &'(PY4ENT:) writing outside PYJETS momory')
59562 KC1=PYCOMP(KF1)
59563 KC2=PYCOMP(KF2)
59564 KC3=PYCOMP(KF3)
59565 KC4=PYCOMP(KF4)
59566 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
59567 &'(PY4ENT:) unknown flavour code')
59568
59569C...Find masses. Reset K, P and V vectors.
59570 PM1=0D0
59571 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
59572 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
59573 PM2=0D0
59574 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
59575 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
59576 PM3=0D0
59577 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
59578 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
59579 PM4=0D0
59580 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
59581 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
59582 DO 110 I=IPA,IPA+3
59583 DO 100 J=1,5
59584 K(I,J)=0
59585 P(I,J)=0D0
59586 V(I,J)=0D0
59587 100 CONTINUE
59588 110 CONTINUE
59589
59590C...Check flavours.
59591 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
59592 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
59593 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
59594 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
59595 IF(MSTU(19).EQ.1) THEN
59596 MSTU(19)=0
59597 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
59598 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
59599 & KQ1+KQ4.EQ.4)) THEN
59600 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
59601 & THEN
59602 ELSE
59603 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
59604 ENDIF
59605 K(IPA,2)=KF1
59606 K(IPA+1,2)=KF2
59607 K(IPA+2,2)=KF3
59608 K(IPA+3,2)=KF4
59609
59610C...Store partons/particles in K vectors for normal case.
59611 IF(IP.GE.0) THEN
59612 K(IPA,1)=1
59613 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
59614 K(IPA+1,1)=1
59615 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
59616 & K(IPA+1,1)=2
59617 K(IPA+2,1)=1
59618 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
59619 K(IPA+3,1)=1
59620
59621C...Store partons for parton shower evolution from q-g-g-qbar or
59622C...g-g-g-g event.
59623 ELSEIF(KQ1+KQ2.NE.0) THEN
59624 K(IPA,1)=3
59625 K(IPA+1,1)=3
59626 K(IPA+2,1)=3
59627 K(IPA+3,1)=3
59628 KCS=4
59629 IF(KQ1.EQ.-1) KCS=5
59630 K(IPA,KCS)=MSTU(5)*(IPA+1)
59631 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
59632 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
59633 K(IPA+1,9-KCS)=MSTU(5)*IPA
59634 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
59635 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
59636 K(IPA+3,KCS)=MSTU(5)*IPA
59637 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
59638
59639C...Store partons for parton shower evolution from q-qbar-q-qbar event.
59640 ELSE
59641 K(IPA,1)=3
59642 K(IPA+1,1)=3
59643 K(IPA+2,1)=3
59644 K(IPA+3,1)=3
59645 K(IPA,4)=MSTU(5)*(IPA+1)
59646 K(IPA,5)=K(IPA,4)
59647 K(IPA+1,4)=MSTU(5)*IPA
59648 K(IPA+1,5)=K(IPA+1,4)
59649 K(IPA+2,4)=MSTU(5)*(IPA+3)
59650 K(IPA+2,5)=K(IPA+2,4)
59651 K(IPA+3,4)=MSTU(5)*(IPA+2)
59652 K(IPA+3,5)=K(IPA+3,4)
59653 ENDIF
59654
59655C...Check kinematics.
59656 MKERR=0
59657 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
59658 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
59659 &MKERR=1
59660 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
59661 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
59662 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
59663 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
59664 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
59665 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
59666 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
59667 STHE4=SQRT(1D0-CTHE4**2)
59668 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
59669 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
59670 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
59671 STHE2=SQRT(1D0-CTHE2**2)
59672 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
59673 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
59674 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
59675 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
59676 IF(MKERR.EQ.1) CALL PYERRM(13,
59677 &'(PY4ENT:) unphysical kinematical variable setup')
59678
59679C...Store partons/particles in P vectors.
59680 P(IPA,3)=PA1
59681 P(IPA,4)=SQRT(PA1**2+PM1**2)
59682 P(IPA,5)=PM1
59683 P(IPA+3,1)=PA4*STHE4
59684 P(IPA+3,3)=PA4*CTHE4
59685 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
59686 P(IPA+3,5)=PM4
59687 P(IPA+1,1)=PA2*STHE2*CPHI2
59688 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
59689 P(IPA+1,3)=PA2*CTHE2
59690 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
59691 P(IPA+1,5)=PM2
59692 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
59693 P(IPA+2,2)=-P(IPA+1,2)
59694 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
59695 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
59696 P(IPA+2,5)=PM3
59697
59698C...Set N. Optionally fragment/decay.
59699 N=IPA+3
59700 IF(IP.EQ.0) CALL PYEXEC
59701
59702 RETURN
59703 END
59704
59705C*********************************************************************
59706
59707C...PY2FRM
59708C...An interface from a two-fermion generator to include
59709C...parton showers and hadronization.
59710
59711 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
59712
59713C...Double precision and integer declarations.
59714 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59715 IMPLICIT INTEGER(I-N)
59716 INTEGER PYK,PYCHGE,PYCOMP
59717C...Commonblocks.
59718 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59719 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59720 SAVE /PYJETS/,/PYDAT1/
59721C...Local arrays.
59722 DIMENSION IJOIN(2),INTAU(2)
59723
59724C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59725 IF(ICOM.EQ.0) THEN
59726 MSTU(28)=0
59727 CALL PYHEPC(2)
59728 ENDIF
59729
59730C...Loop through entries and pick up all final fermions/antifermions.
59731 I1=0
59732 I2=0
59733 DO 100 I=1,N
59734 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59735 KFA=IABS(K(I,2))
59736 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59737 IF(K(I,2).GT.0) THEN
59738 IF(I1.EQ.0) THEN
59739 I1=I
59740 ELSE
59741 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
59742 ENDIF
59743 ELSE
59744 IF(I2.EQ.0) THEN
59745 I2=I
59746 ELSE
59747 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
59748 ENDIF
59749 ENDIF
59750 ENDIF
59751 100 CONTINUE
59752
59753C...Check that event is arranged according to conventions.
59754 IF(I1.EQ.0.OR.I2.EQ.0) THEN
59755 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
59756 ENDIF
59757 IF(I2.LT.I1) THEN
59758 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
59759 ENDIF
59760
59761C...Check whether fermion pair is quarks or leptons.
59762 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59763 IQL12=1
59764 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59765 IQL12=2
59766 ELSE
59767 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
59768 ENDIF
59769
59770C...Decide whether to allow or not photon radiation in showers.
59771 MSTJ(41)=2
59772 IF(IRAD.EQ.0) MSTJ(41)=1
59773
59774C...Do colour joining and parton showers.
59775 IP1=I1
59776 IP2=I2
59777 IF(IQL12.EQ.1) THEN
59778 IJOIN(1)=IP1
59779 IJOIN(2)=IP2
59780 CALL PYJOIN(2,IJOIN)
59781 ENDIF
59782 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59783 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59784 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59785 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59786 ENDIF
59787
59788C...Do fragmentation and decays. Possibly except tau decay.
59789 IF(ITAU.EQ.0) THEN
59790 NTAU=0
59791 DO 110 I=1,N
59792 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59793 NTAU=NTAU+1
59794 INTAU(NTAU)=I
59795 K(I,1)=11
59796 ENDIF
59797 110 CONTINUE
59798 ENDIF
59799 CALL PYEXEC
59800 IF(ITAU.EQ.0) THEN
59801 DO 120 I=1,NTAU
59802 K(INTAU(I),1)=1
59803 120 CONTINUE
59804 ENDIF
59805
59806C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59807 IF(ICOM.EQ.0) THEN
59808 MSTU(28)=0
59809 CALL PYHEPC(1)
59810 ENDIF
59811
59812 END
59813
59814C*********************************************************************
59815
59816C...PY4FRM
59817C...An interface from a four-fermion generator to include
59818C...parton showers and hadronization.
59819
59820 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
59821
59822C...Double precision and integer declarations.
59823 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59824 IMPLICIT INTEGER(I-N)
59825 INTEGER PYK,PYCHGE,PYCOMP
59826C...Commonblocks.
59827 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59828 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59829 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59830 COMMON/PYINT1/MINT(400),VINT(400)
59831 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
59832C...Local arrays.
59833 DIMENSION IJOIN(2),INTAU(4)
59834
59835C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59836 IF(ICOM.EQ.0) THEN
59837 MSTU(28)=0
59838 CALL PYHEPC(2)
59839 ENDIF
59840
59841C...Loop through entries and pick up all final fermions/antifermions.
59842 I1=0
59843 I2=0
59844 I3=0
59845 I4=0
59846 DO 100 I=1,N
59847 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59848 KFA=IABS(K(I,2))
59849 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59850 IF(K(I,2).GT.0) THEN
59851 IF(I1.EQ.0) THEN
59852 I1=I
59853 ELSEIF(I3.EQ.0) THEN
59854 I3=I
59855 ELSE
59856 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
59857 ENDIF
59858 ELSE
59859 IF(I2.EQ.0) THEN
59860 I2=I
59861 ELSEIF(I4.EQ.0) THEN
59862 I4=I
59863 ELSE
59864 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
59865 ENDIF
59866 ENDIF
59867 ENDIF
59868 100 CONTINUE
59869
59870C...Check that event is arranged according to conventions.
59871 IF(I3.EQ.0.OR.I4.EQ.0) THEN
59872 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
59873 ENDIF
59874 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59875 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
59876 ENDIF
59877
59878C...Check which fermion pairs are quarks and which leptons.
59879 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59880 IQL12=1
59881 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59882 IQL12=2
59883 ELSE
59884 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
59885 ENDIF
59886 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59887 IQL34=1
59888 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59889 IQL34=2
59890 ELSE
59891 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
59892 ENDIF
59893
59894C...Decide whether to allow or not photon radiation in showers.
59895 MSTJ(41)=2
59896 IF(IRAD.EQ.0) MSTJ(41)=1
59897
59898C...Decide on dipole pairing.
59899 IP1=I1
59900 IP2=I2
59901 IP3=I3
59902 IP4=I4
59903 IF(IQL12.EQ.IQL34) THEN
59904 R1SQ=A1SQ
59905 R2SQ=A2SQ
59906 DELTA=ATOTSQ-A1SQ-A2SQ
59907 IF(ISTRAT.EQ.1) THEN
59908 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
59909 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
59910 ELSEIF(ISTRAT.EQ.2) THEN
59911 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
59912 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
59913 ENDIF
59914 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
59915 IP2=I4
59916 IP4=I2
59917 ENDIF
59918 ENDIF
59919
59920C...If colour reconnection then bookkeep W+W- or Z0Z0
59921C...and copy q qbar q qbar consecutively.
59922 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59923 K(N+1,1)=11
59924 K(N+1,3)=IP1
59925 K(N+1,4)=N+3
59926 K(N+1,5)=N+4
59927 K(N+2,1)=11
59928 K(N+2,3)=IP3
59929 K(N+2,4)=N+5
59930 K(N+2,5)=N+6
59931 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
59932 K(N+1,2)=23
59933 K(N+2,2)=23
59934 MINT(1)=22
59935 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
59936 K(N+1,2)=24
59937 K(N+2,2)=-24
59938 MINT(1)=25
59939 ELSE
59940 K(N+1,2)=-24
59941 K(N+2,2)=24
59942 MINT(1)=25
59943 ENDIF
59944 DO 110 J=1,5
59945 K(N+3,J)=K(IP1,J)
59946 K(N+4,J)=K(IP2,J)
59947 K(N+5,J)=K(IP3,J)
59948 K(N+6,J)=K(IP4,J)
59949 P(N+1,J)=P(IP1,J)+P(IP2,J)
59950 P(N+2,J)=P(IP3,J)+P(IP4,J)
59951 P(N+3,J)=P(IP1,J)
59952 P(N+4,J)=P(IP2,J)
59953 P(N+5,J)=P(IP3,J)
59954 P(N+6,J)=P(IP4,J)
59955 V(N+1,J)=V(IP1,J)
59956 V(N+2,J)=V(IP3,J)
59957 V(N+3,J)=V(IP1,J)
59958 V(N+4,J)=V(IP2,J)
59959 V(N+5,J)=V(IP3,J)
59960 V(N+6,J)=V(IP4,J)
59961 110 CONTINUE
59962 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59963 & P(N+1,3)**2))
59964 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59965 & P(N+2,3)**2))
59966 K(N+3,3)=N+1
59967 K(N+4,3)=N+1
59968 K(N+5,3)=N+2
59969 K(N+6,3)=N+2
59970C...Remove original q qbar q qbar and update counters.
59971 K(IP1,1)=K(IP1,1)+10
59972 K(IP2,1)=K(IP2,1)+10
59973 K(IP3,1)=K(IP3,1)+10
59974 K(IP4,1)=K(IP4,1)+10
59975 IW1=N+1
59976 IW2=N+2
59977 NSD1=N+2
59978 IP1=N+3
59979 IP2=N+4
59980 IP3=N+5
59981 IP4=N+6
59982 N=N+6
59983 ENDIF
59984
59985C...Do colour joinings and parton showers.
59986 IF(IQL12.EQ.1) THEN
59987 IJOIN(1)=IP1
59988 IJOIN(2)=IP2
59989 CALL PYJOIN(2,IJOIN)
59990 ENDIF
59991 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59992 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59993 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59994 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59995 ENDIF
59996 NAFT1=N
59997 IF(IQL34.EQ.1) THEN
59998 IJOIN(1)=IP3
59999 IJOIN(2)=IP4
60000 CALL PYJOIN(2,IJOIN)
60001 ENDIF
60002 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
60003 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
60004 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
60005 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
60006 ENDIF
60007
60008C...Optionally do colour reconnection.
60009 MINT(32)=0
60010 MSTI(32)=0
60011 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
60012 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
60013 MSTI(32)=MINT(32)
60014 ENDIF
60015
60016C...Do fragmentation and decays. Possibly except tau decay.
60017 IF(ITAU.EQ.0) THEN
60018 NTAU=0
60019 DO 120 I=1,N
60020 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
60021 NTAU=NTAU+1
60022 INTAU(NTAU)=I
60023 K(I,1)=11
60024 ENDIF
60025 120 CONTINUE
60026 ENDIF
60027 CALL PYEXEC
60028 IF(ITAU.EQ.0) THEN
60029 DO 130 I=1,NTAU
60030 K(INTAU(I),1)=1
60031 130 CONTINUE
60032 ENDIF
60033
60034C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
60035 IF(ICOM.EQ.0) THEN
60036 MSTU(28)=0
60037 CALL PYHEPC(1)
60038 ENDIF
60039
60040 END
60041
60042C*********************************************************************
60043
60044C...PY6FRM
60045C...An interface from a six-fermion generator to include
60046C...parton showers and hadronization.
60047
60048 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
60049
60050C...Double precision and integer declarations.
60051 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60052 IMPLICIT INTEGER(I-N)
60053 INTEGER PYK,PYCHGE,PYCOMP
60054C...Commonblocks.
60055 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60056 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60057 SAVE /PYJETS/,/PYDAT1/
60058C...Local arrays.
60059 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
60060
60061C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
60062 IF(ICOM.EQ.0) THEN
60063 MSTU(28)=0
60064 CALL PYHEPC(2)
60065 ENDIF
60066
60067C...Loop through entries and pick up all final fermions/antifermions.
60068 I1=0
60069 I2=0
60070 I3=0
60071 I4=0
60072 I5=0
60073 I6=0
60074 DO 100 I=1,N
60075 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
60076 KFA=IABS(K(I,2))
60077 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
60078 IF(K(I,2).GT.0) THEN
60079 IF(I1.EQ.0) THEN
60080 I1=I
60081 ELSEIF(I3.EQ.0) THEN
60082 I3=I
60083 ELSEIF(I5.EQ.0) THEN
60084 I5=I
60085 ELSE
60086 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
60087 ENDIF
60088 ELSE
60089 IF(I2.EQ.0) THEN
60090 I2=I
60091 ELSEIF(I4.EQ.0) THEN
60092 I4=I
60093 ELSEIF(I6.EQ.0) THEN
60094 I6=I
60095 ELSE
60096 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
60097 ENDIF
60098 ENDIF
60099 ENDIF
60100 100 CONTINUE
60101
60102C...Check that event is arranged according to conventions.
60103 IF(I5.EQ.0.OR.I6.EQ.0) THEN
60104 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
60105 ENDIF
60106 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
60107 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
60108 ENDIF
60109
60110C...Check which fermion pairs are quarks and which leptons.
60111 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
60112 IQL12=1
60113 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
60114 IQL12=2
60115 ELSE
60116 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
60117 ENDIF
60118 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
60119 IQL34=1
60120 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
60121 IQL34=2
60122 ELSE
60123 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
60124 ENDIF
60125 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
60126 IQL56=1
60127 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
60128 IQL56=2
60129 ELSE
60130 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
60131 ENDIF
60132
60133C...Decide whether to allow or not photon radiation in showers.
60134 MSTJ(41)=2
60135 IF(IRAD.EQ.0) MSTJ(41)=1
60136
60137C...Allow dipole pairings only among leptons and quarks separately.
60138 P12D=P12
60139 P13D=0D0
60140 IF(IQL34.EQ.IQL56) P13D=P13
60141 P21D=0D0
60142 IF(IQL12.EQ.IQL34) P21D=P21
60143 P23D=0D0
60144 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
60145 P31D=0D0
60146 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
60147 P32D=0D0
60148 IF(IQL12.EQ.IQL56) P32D=P32
60149
60150C...Decide whether t+tbar.
60151 ITOP=0
60152 IF(PYR(0).LT.PTOP) THEN
60153 ITOP=1
60154
60155C...If t+tbar: reconstruct t's.
60156 IT=N+1
60157 ITB=N+2
60158 DO 110 J=1,5
60159 K(IT,J)=0
60160 K(ITB,J)=0
60161 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
60162 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
60163 V(IT,J)=0D0
60164 V(ITB,J)=0D0
60165 110 CONTINUE
60166 K(IT,1)=1
60167 K(ITB,1)=1
60168 K(IT,2)=6
60169 K(ITB,2)=-6
60170 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
60171 & P(IT,3)**2))
60172 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
60173 & P(ITB,3)**2))
60174 N=N+2
60175
60176C...If t+tbar: colour join t's and let them shower.
60177 IJOIN(1)=IT
60178 IJOIN(2)=ITB
60179 CALL PYJOIN(2,IJOIN)
60180 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
60181 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
60182 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
60183
60184C...If t+tbar: pick up the t's after shower.
60185 ITNEW=IT
60186 ITBNEW=ITB
60187 DO 120 I=ITB+1,N
60188 IF(K(I,2).EQ.6) ITNEW=I
60189 IF(K(I,2).EQ.-6) ITBNEW=I
60190 120 CONTINUE
60191
60192C...If t+tbar: loop over two top systems.
60193 DO 200 IT1=1,2
60194 IF(IT1.EQ.1) THEN
60195 ITO=IT
60196 ITN=ITNEW
60197 IBO=I1
60198 IW1=I3
60199 IW2=I4
60200 ELSE
60201 ITO=ITB
60202 ITN=ITBNEW
60203 IBO=I2
60204 IW1=I5
60205 IW2=I6
60206 ENDIF
60207 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
60208 & '(PY6FRM:) not b in t decay')
60209
60210C...If t+tbar: find boost from original to new top frame.
60211 DO 130 J=1,3
60212 BETAO(J)=P(ITO,J)/P(ITO,4)
60213 BETAN(J)=P(ITN,J)/P(ITN,4)
60214 130 CONTINUE
60215
60216C...If t+tbar: boost copy of b by t shower and connect it in colour.
60217 N=N+1
60218 IB=N
60219 K(IB,1)=3
60220 K(IB,2)=K(IBO,2)
60221 K(IB,3)=ITN
60222 DO 140 J=1,5
60223 P(IB,J)=P(IBO,J)
60224 V(IB,J)=0D0
60225 140 CONTINUE
60226 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
60227 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
60228 K(IB,4)=MSTU(5)*ITN
60229 K(IB,5)=MSTU(5)*ITN
60230 K(ITN,4)=K(ITN,4)+IB
60231 K(ITN,5)=K(ITN,5)+IB
60232 K(ITN,1)=K(ITN,1)+10
60233 K(IBO,1)=K(IBO,1)+10
60234
60235C...If t+tbar: construct W recoiling against b.
60236 N=N+1
60237 IW=N
60238 DO 150 J=1,5
60239 K(IW,J)=0
60240 V(IW,J)=0D0
60241 150 CONTINUE
60242 K(IW,1)=1
60243 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
60244 IF(IABS(KCHW).EQ.3) THEN
60245 K(IW,2)=ISIGN(24,KCHW)
60246 ELSE
60247 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
60248 ENDIF
60249 K(IW,3)=IW1
60250
60251C...If t+tbar: construct W momentum, including boost by t shower.
60252 DO 160 J=1,4
60253 P(IW,J)=P(IW1,J)+P(IW2,J)
60254 160 CONTINUE
60255 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
60256 & P(IW,3)**2))
60257 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
60258 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
60259
60260C...If t+tbar: boost b and W to top rest frame.
60261 DO 170 J=1,3
60262 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
60263 170 CONTINUE
60264 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60265 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60266
60267C...If t+tbar: let b shower and pick up modified W.
60268 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
60269 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
60270 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
60271 DO 180 I=IW,N
60272 IF(IABS(K(I,2)).EQ.24) IWM=I
60273 180 CONTINUE
60274
60275C...If t+tbar: take copy of W decay products.
60276 DO 190 J=1,5
60277 K(N+1,J)=K(IW1,J)
60278 P(N+1,J)=P(IW1,J)
60279 V(N+1,J)=V(IW1,J)
60280 K(N+2,J)=K(IW2,J)
60281 P(N+2,J)=P(IW2,J)
60282 V(N+2,J)=V(IW2,J)
60283 190 CONTINUE
60284 K(IW1,1)=K(IW1,1)+10
60285 K(IW2,1)=K(IW2,1)+10
60286 K(IWM,1)=K(IWM,1)+10
60287 K(IWM,4)=N+1
60288 K(IWM,5)=N+2
60289 K(N+1,3)=IWM
60290 K(N+2,3)=IWM
60291 IF(IT1.EQ.1) THEN
60292 I3=N+1
60293 I4=N+2
60294 ELSE
60295 I5=N+1
60296 I6=N+2
60297 ENDIF
60298 N=N+2
60299
60300C...If t+tbar: boost W decay products, first by effects of t shower,
60301C...then by those of b shower. b and its shower simple boost back.
60302 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
60303 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
60304 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60305 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
60306 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
60307 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
60308 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
60309 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
60310 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
60311 200 CONTINUE
60312 ENDIF
60313
60314C...Decide on dipole pairing.
60315 IP1=I1
60316 IP3=I3
60317 IP5=I5
60318 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
60319 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
60320 IP2=I2
60321 IP4=I4
60322 IP6=I6
60323 ELSEIF(PRN.LT.P12D+P13D) THEN
60324 IP2=I2
60325 IP4=I6
60326 IP6=I4
60327 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
60328 IP2=I4
60329 IP4=I2
60330 IP6=I6
60331 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
60332 IP2=I4
60333 IP4=I6
60334 IP6=I2
60335 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
60336 IP2=I6
60337 IP4=I2
60338 IP6=I4
60339 ELSE
60340 IP2=I6
60341 IP4=I4
60342 IP6=I2
60343 ENDIF
60344
60345C...Do colour joinings and parton showers
60346C...(except ones already made for t+tbar).
60347 IF(ITOP.EQ.0) THEN
60348 IF(IQL12.EQ.1) THEN
60349 IJOIN(1)=IP1
60350 IJOIN(2)=IP2
60351 CALL PYJOIN(2,IJOIN)
60352 ENDIF
60353 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
60354 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
60355 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
60356 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
60357 ENDIF
60358 ENDIF
60359 IF(IQL34.EQ.1) THEN
60360 IJOIN(1)=IP3
60361 IJOIN(2)=IP4
60362 CALL PYJOIN(2,IJOIN)
60363 ENDIF
60364 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
60365 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
60366 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
60367 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
60368 ENDIF
60369 IF(IQL56.EQ.1) THEN
60370 IJOIN(1)=IP5
60371 IJOIN(2)=IP6
60372 CALL PYJOIN(2,IJOIN)
60373 ENDIF
60374 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
60375 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
60376 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
60377 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
60378 ENDIF
60379
60380C...Do fragmentation and decays. Possibly except tau decay.
60381 IF(ITAU.EQ.0) THEN
60382 NTAU=0
60383 DO 210 I=1,N
60384 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
60385 NTAU=NTAU+1
60386 INTAU(NTAU)=I
60387 K(I,1)=11
60388 ENDIF
60389 210 CONTINUE
60390 ENDIF
60391 CALL PYEXEC
60392 IF(ITAU.EQ.0) THEN
60393 DO 220 I=1,NTAU
60394 K(INTAU(I),1)=1
60395 220 CONTINUE
60396 ENDIF
60397
60398C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
60399 IF(ICOM.EQ.0) THEN
60400 MSTU(28)=0
60401 CALL PYHEPC(1)
60402 ENDIF
60403
60404 END
60405
60406C*********************************************************************
60407
60408C...PY4JET
60409C...An interface from a four-parton generator to include
60410C...parton showers and hadronization.
60411
60412 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
60413
60414C...Double precision and integer declarations.
60415 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60416 IMPLICIT INTEGER(I-N)
60417 INTEGER PYK,PYCHGE,PYCOMP
60418C...Commonblocks.
60419 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60420 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60421 SAVE /PYJETS/,/PYDAT1/
60422C...Local arrays.
60423 DIMENSION IJOIN(2),PTOT(4),BETA(3)
60424
60425C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
60426 IF(ICOM.EQ.0) THEN
60427 MSTU(28)=0
60428 CALL PYHEPC(2)
60429 ENDIF
60430
60431C...Loop through entries and pick up all final partons.
60432 I1=0
60433 I2=0
60434 I3=0
60435 I4=0
60436 DO 100 I=1,N
60437 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
60438 KFA=IABS(K(I,2))
60439 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
60440 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
60441 IF(I1.EQ.0) THEN
60442 I1=I
60443 ELSEIF(I3.EQ.0) THEN
60444 I3=I
60445 ELSE
60446 CALL PYERRM(16,'(PY4JET:) more than two quarks')
60447 ENDIF
60448 ELSEIF(K(I,2).LT.0) THEN
60449 IF(I2.EQ.0) THEN
60450 I2=I
60451 ELSEIF(I4.EQ.0) THEN
60452 I4=I
60453 ELSE
60454 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
60455 ENDIF
60456 ELSE
60457 IF(I3.EQ.0) THEN
60458 I3=I
60459 ELSEIF(I4.EQ.0) THEN
60460 I4=I
60461 ELSE
60462 CALL PYERRM(16,'(PY4JET:) more than two gluons')
60463 ENDIF
60464 ENDIF
60465 ENDIF
60466 100 CONTINUE
60467
60468C...Check that event is arranged according to conventions.
60469 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
60470 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
60471 ENDIF
60472 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
60473 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
60474 ENDIF
60475
60476C...Check whether second pair are quarks or gluons.
60477 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
60478 IQG34=1
60479 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
60480 IQG34=2
60481 ELSE
60482 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
60483 ENDIF
60484
60485C...Boost partons to their cm frame.
60486 DO 110 J=1,4
60487 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
60488 110 CONTINUE
60489 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
60490 DO 120 J=1,3
60491 BETA(J)=PTOT(J)/PTOT(4)
60492 120 CONTINUE
60493 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60494 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60495 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60496 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60497 NSAV=N
60498
60499C...Decide and set up shower history for q qbar q' qbar' events.
60500 IF(IQG34.EQ.1) THEN
60501 W1=PY4JTW(0,I1,I3,I4)
60502 W2=PY4JTW(0,I2,I3,I4)
60503 IF(W1.GT.PYR(0)*(W1+W2)) THEN
60504 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
60505 ELSE
60506 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
60507 ENDIF
60508
60509C...Decide and set up shower history for q qbar g g events.
60510 ELSE
60511 W1=PY4JTW(I1,I3,I2,I4)
60512 W2=PY4JTW(I1,I4,I2,I3)
60513 W3=PY4JTW(0,I3,I1,I4)
60514 W4=PY4JTW(0,I4,I1,I3)
60515 W5=PY4JTW(0,I3,I2,I4)
60516 W6=PY4JTW(0,I4,I2,I3)
60517 W7=PY4JTW(0,I1,I3,I4)
60518 W8=PY4JTW(0,I2,I3,I4)
60519 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
60520 IF(W1.GT.WR) THEN
60521 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
60522 ELSEIF(W1+W2.GT.WR) THEN
60523 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
60524 ELSEIF(W1+W2+W3.GT.WR) THEN
60525 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
60526 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
60527 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
60528 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
60529 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
60530 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
60531 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
60532 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
60533 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
60534 ELSE
60535 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
60536 ENDIF
60537 ENDIF
60538
60539C...Boost back original partons and mark them as deleted.
60540 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
60541 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
60542 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
60543 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
60544 K(I1,1)=K(I1,1)+10
60545 K(I2,1)=K(I2,1)+10
60546 K(I3,1)=K(I3,1)+10
60547 K(I4,1)=K(I4,1)+10
60548
60549C...Rotate shower initiating partons to be along z axis.
60550 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
60551 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
60552 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
60553 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
60554
60555C...Set up copy of shower initiating partons as on mass shell.
60556 DO 140 I=N+1,N+2
60557 DO 130 J=1,5
60558 K(I,J)=0
60559 P(I,J)=0D0
60560 V(I,J)=V(I1,J)
60561 130 CONTINUE
60562 K(I,1)=1
60563 K(I,2)=K(I-6,2)
60564 140 CONTINUE
60565 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
60566 K(N+1,3)=I1
60567 P(N+1,5)=P(I1,5)
60568 K(N+2,3)=I2
60569 P(N+2,5)=P(I2,5)
60570 ELSE
60571 K(N+1,3)=I2
60572 P(N+1,5)=P(I2,5)
60573 K(N+2,3)=I1
60574 P(N+2,5)=P(I1,5)
60575 ENDIF
60576 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
60577 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
60578 P(N+1,3)=PABS
60579 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
60580 P(N+2,3)=-PABS
60581 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
60582 N=N+2
60583
60584C...Decide whether to allow or not photon radiation in showers.
60585C...Connect up colours.
60586 MSTJ(41)=2
60587 IF(IRAD.EQ.0) MSTJ(41)=1
60588 IJOIN(1)=N-1
60589 IJOIN(2)=N
60590 CALL PYJOIN(2,IJOIN)
60591
60592C...Decide on maximum virtuality and do parton shower.
60593 IF(PMAX.LT.PARJ(82)) THEN
60594 PQMAX=QMAX
60595 ELSE
60596 PQMAX=PMAX
60597 ENDIF
60598 CALL PYSHOW(NSAV+1,-100,PQMAX)
60599
60600C...Rotate and boost back system.
60601 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
60602
60603C...Do fragmentation and decays.
60604 CALL PYEXEC
60605
60606C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
60607 IF(ICOM.EQ.0) THEN
60608 MSTU(28)=0
60609 CALL PYHEPC(1)
60610 ENDIF
60611
60612 RETURN
60613 END
60614
60615C*********************************************************************
60616
60617C...PY4JTW
60618C...Auxiliary to PY4JET, to evaluate weight of configuration.
60619
60620 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
60621
60622C...Double precision and integer declarations.
60623 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60624 IMPLICIT INTEGER(I-N)
60625 INTEGER PYK,PYCHGE,PYCOMP
60626C...Commonblocks.
60627 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60628 SAVE /PYJETS/
60629
60630C...First case: when both original partons radiate.
60631C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
60632 IF(IA1.NE.0) THEN
60633 DO 100 J=1,4
60634 P(N+1,J)=P(IA1,J)+P(IA2,J)
60635 P(N+2,J)=P(IA3,J)+P(IA4,J)
60636 100 CONTINUE
60637 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60638 & P(N+1,3)**2))
60639 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
60640 & P(N+2,3)**2))
60641 Z1=P(IA1,4)/P(N+1,4)
60642 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
60643 Z2=P(IA3,4)/P(N+2,4)
60644 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
60645
60646C...Second case: when one original parton radiates to three.
60647C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
60648 ELSE
60649 DO 110 J=1,4
60650 P(N+2,J)=P(IA3,J)+P(IA4,J)
60651 P(N+1,J)=P(N+2,J)+P(IA2,J)
60652 110 CONTINUE
60653 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60654 & P(N+1,3)**2))
60655 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
60656 & P(N+2,3)**2))
60657 IF(K(IA2,2).EQ.21) THEN
60658 Z1=P(N+2,4)/P(N+1,4)
60659 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
60660 & P(IA3,5)**2)
60661 ELSE
60662 Z1=P(IA2,4)/P(N+1,4)
60663 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
60664 & P(IA2,5)**2)
60665 ENDIF
60666 Z2=P(IA3,4)/P(N+2,4)
60667 IF(K(IA2,2).EQ.21) THEN
60668 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
60669 & P(IA3,5)**2)
60670 ELSEIF(K(IA3,2).EQ.21) THEN
60671 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
60672 ELSE
60673 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
60674 ENDIF
60675 ENDIF
60676
60677C...Total weight.
60678 PY4JTW=WT1*WT2
60679
60680 RETURN
60681 END
60682
60683C*********************************************************************
60684
60685C...PY4JTS
60686C...Auxiliary to PY4JET, to set up chosen configuration.
60687
60688 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
60689
60690C...Double precision and integer declarations.
60691 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60692 IMPLICIT INTEGER(I-N)
60693 INTEGER PYK,PYCHGE,PYCOMP
60694C...Commonblocks.
60695 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60696 SAVE /PYJETS/
60697
60698C...Reset info.
60699 DO 110 I=N+1,N+6
60700 DO 100 J=1,5
60701 K(I,J)=0
60702 V(I,J)=V(IA2,J)
60703 100 CONTINUE
60704 K(I,1)=16
60705 110 CONTINUE
60706
60707C...First case: when both original partons radiate.
60708C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
60709 IF(IA1.NE.0) THEN
60710
60711C...Set up flavour and history pointers for new partons.
60712 K(N+1,2)=K(IA1,2)
60713 K(N+2,2)=K(IA3,2)
60714 K(N+3,2)=K(IA1,2)
60715 K(N+4,2)=K(IA2,2)
60716 K(N+5,2)=K(IA3,2)
60717 K(N+6,2)=K(IA4,2)
60718 K(N+1,3)=IA1
60719 K(N+1,4)=N+3
60720 K(N+1,5)=N+4
60721 K(N+2,3)=IA3
60722 K(N+2,4)=N+5
60723 K(N+2,5)=N+6
60724 K(N+3,3)=N+1
60725 K(N+4,3)=N+1
60726 K(N+5,3)=N+2
60727 K(N+6,3)=N+2
60728
60729C...Set up momenta for new partons.
60730 DO 120 J=1,5
60731 P(N+1,J)=P(IA1,J)+P(IA2,J)
60732 P(N+2,J)=P(IA3,J)+P(IA4,J)
60733 P(N+3,J)=P(IA1,J)
60734 P(N+4,J)=P(IA2,J)
60735 P(N+5,J)=P(IA3,J)
60736 P(N+6,J)=P(IA4,J)
60737 120 CONTINUE
60738 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60739 & P(N+1,3)**2))
60740 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
60741 & P(N+2,3)**2))
60742 QMAX=MIN(P(N+1,5),P(N+2,5))
60743
60744C...Second case: q radiates twice.
60745C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
60746C...IA5=N+2 does not radiate.
60747 ELSEIF(K(IA2,2).EQ.21) THEN
60748
60749C...Set up flavour and history pointers for new partons.
60750 K(N+1,2)=K(IA3,2)
60751 K(N+2,2)=K(IA5,2)
60752 K(N+3,2)=K(IA3,2)
60753 K(N+4,2)=K(IA2,2)
60754 K(N+5,2)=K(IA3,2)
60755 K(N+6,2)=K(IA4,2)
60756 K(N+1,3)=IA3
60757 K(N+1,4)=N+3
60758 K(N+1,5)=N+4
60759 K(N+2,3)=IA5
60760 K(N+3,3)=N+1
60761 K(N+3,4)=N+5
60762 K(N+3,5)=N+6
60763 K(N+4,3)=N+1
60764 K(N+5,3)=N+3
60765 K(N+6,3)=N+3
60766
60767C...Set up momenta for new partons.
60768 DO 130 J=1,5
60769 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
60770 P(N+2,J)=P(IA5,J)
60771 P(N+3,J)=P(IA3,J)+P(IA4,J)
60772 P(N+4,J)=P(IA2,J)
60773 P(N+5,J)=P(IA3,J)
60774 P(N+6,J)=P(IA4,J)
60775 130 CONTINUE
60776 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60777 & P(N+1,3)**2))
60778 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
60779 & P(N+3,3)**2))
60780 QMAX=P(N+3,5)
60781
60782C...Third case: q radiates g, g branches.
60783C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
60784C...IA5=N+2 does not radiate.
60785 ELSE
60786
60787C...Set up flavour and history pointers for new partons.
60788 K(N+1,2)=K(IA2,2)
60789 K(N+2,2)=K(IA5,2)
60790 K(N+3,2)=K(IA2,2)
60791 K(N+4,2)=21
60792 K(N+5,2)=K(IA3,2)
60793 K(N+6,2)=K(IA4,2)
60794 K(N+1,3)=IA2
60795 K(N+1,4)=N+3
60796 K(N+1,5)=N+4
60797 K(N+2,3)=IA5
60798 K(N+3,3)=N+1
60799 K(N+4,3)=N+1
60800 K(N+4,4)=N+5
60801 K(N+4,5)=N+6
60802 K(N+5,3)=N+4
60803 K(N+6,3)=N+4
60804
60805C...Set up momenta for new partons.
60806 DO 140 J=1,5
60807 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
60808 P(N+2,J)=P(IA5,J)
60809 P(N+3,J)=P(IA2,J)
60810 P(N+4,J)=P(IA3,J)+P(IA4,J)
60811 P(N+5,J)=P(IA3,J)
60812 P(N+6,J)=P(IA4,J)
60813 140 CONTINUE
60814 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60815 & P(N+1,3)**2))
60816 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
60817 & P(N+4,3)**2))
60818 QMAX=P(N+4,5)
60819
60820 ENDIF
60821 N=N+6
60822
60823 RETURN
60824 END
60825
60826C*********************************************************************
60827
60828C...PYJOIN
60829C...Connects a sequence of partons with colour flow indices,
60830C...as required for subsequent shower evolution (or other operations).
60831
60832 SUBROUTINE PYJOIN(NJOIN,IJOIN)
60833
60834C...Double precision and integer declarations.
60835 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60836 IMPLICIT INTEGER(I-N)
60837 INTEGER PYK,PYCHGE,PYCOMP
60838C...Commonblocks.
60839 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60840 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60841 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60842 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
60843C...Local array.
60844 DIMENSION IJOIN(*)
60845
60846C...Check that partons are of right types to be connected.
60847 IF(NJOIN.LT.2) GOTO 120
60848 KQSUM=0
60849 DO 100 IJN=1,NJOIN
60850 I=IJOIN(IJN)
60851 IF(I.LE.0.OR.I.GT.N) GOTO 120
60852 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
60853 KC=PYCOMP(K(I,2))
60854 IF(KC.EQ.0) GOTO 120
60855 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
60856 IF(KQ.EQ.0) GOTO 120
60857 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
60858 IF(KQ.NE.2) KQSUM=KQSUM+KQ
60859 IF(IJN.EQ.1) KQS=KQ
60860 100 CONTINUE
60861 IF(KQSUM.NE.0) GOTO 120
60862
60863C...Connect the partons sequentially (closing for gluon loop).
60864 KCS=(9-KQS)/2
60865 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
60866 DO 110 IJN=1,NJOIN
60867 I=IJOIN(IJN)
60868 K(I,1)=3
60869 IF(IJN.NE.1) IP=IJOIN(IJN-1)
60870 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
60871 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
60872 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
60873 K(I,KCS)=MSTU(5)*IN
60874 K(I,9-KCS)=MSTU(5)*IP
60875 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
60876 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
60877 110 CONTINUE
60878
60879C...Error exit: no action taken.
60880 RETURN
60881 120 CALL PYERRM(12,
60882 &'(PYJOIN:) given entries can not be joined by one string')
60883
60884 RETURN
60885 END
60886
60887C*********************************************************************
60888
60889C...PYGIVE
60890C...Sets values of commonblock variables.
60891
60892 SUBROUTINE PYGIVE(CHIN)
60893
60894C...Double precision and integer declarations.
60895 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60896 IMPLICIT INTEGER(I-N)
60897 INTEGER PYK,PYCHGE,PYCOMP
60898C...Commonblocks.
60899 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60900 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60901 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60902 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60903 COMMON/PYDAT4/CHAF(500,2)
60904 CHARACTER CHAF*16
60905 COMMON/PYDATR/MRPY(6),RRPY(100)
60906 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
60907 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60908 COMMON/PYINT1/MINT(400),VINT(400)
60909 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
60910 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
60911 COMMON/PYINT4/MWID(500),WIDS(500,5)
60912 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
60913 COMMON/PYINT6/PROC(0:500)
60914 CHARACTER PROC*28
60915 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
60916 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
60917 &XPDIR(-6:6)
60918 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
60919 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
60920 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
60921 COMMON/PYPUED/IUED(0:99),RUED(0:99)
60922 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
60923 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
60924 &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/
60925C...Local arrays and character variables.
60926 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
60927 &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10,
60928 &CHINR*16,CHDIG*10
60929 DIMENSION MSVAR(56,8)
60930
60931C...For each variable to be translated give: name,
60932C...integer/real/character, no. of indices, lower&upper index bounds.
60933 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
60934 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
60935 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
60936 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
60937 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
60938 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
60939 &'ITCM','RTCM','IUED','RUED'/
60940 DATA ((MSVAR(I,J),J=1,8),I=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0,
60941 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
60942 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60943 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
60944 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
60945 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
60946 &1,1,1,6,4*0, 2,1,1,100,4*0,
60947 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
60948 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60949 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
60950 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
60951 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
60952 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
60953 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
60954 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
60955 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
60956 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
60957 &1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
60958 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60959 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
60960
60961C...Length of character variable. Subdivide it into instructions.
60962 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
60963 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
60964 CHBIT=CHIN//' '
60965 LBIT=101
60966 100 LBIT=LBIT-1
60967 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
60968 LTOT=0
60969 DO 110 LCOM=1,LBIT
60970 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
60971 LTOT=LTOT+1
60972 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
60973 110 CONTINUE
60974 LLOW=0
60975 120 LHIG=LLOW+1
60976 130 LHIG=LHIG+1
60977 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
60978 LBIT=LHIG-LLOW-1
60979 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
60980
60981C...Send off decay-mode on/off commands to PYONOF.
60982 IONOF=0
60983 DO 135 LDIG=1,10
60984 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
60985 135 CONTINUE
60986 IF(IONOF.EQ.1) THEN
60987 CALL PYONOF(CHIN)
60988 RETURN
60989 ENDIF
60990
60991C...Peel off any text following exclamation mark.
60992 LHIG2=LBIT
60993 DO 140 LLOW2=LHIG2,1,-1
60994 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
60995 140 CONTINUE
60996 IF(LBIT.EQ.0) RETURN
60997
60998C...Identify commonblock variable.
60999 LNAM=1
61000 150 LNAM=LNAM+1
61001 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
61002 &LNAM.LE.6) GOTO 150
61003 CHNAM=CHBIT(1:LNAM-1)//' '
61004 DO 170 LCOM=1,LNAM-1
61005 DO 160 LALP=1,26
61006 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
61007 & CHALP(2)(LALP:LALP)
61008 160 CONTINUE
61009 170 CONTINUE
61010 IVAR=0
61011 DO 180 IV=1,56
61012 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
61013 180 CONTINUE
61014 IF(IVAR.EQ.0) THEN
61015 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
61016 LLOW=LHIG
61017 IF(LLOW.LT.LTOT) GOTO 120
61018 RETURN
61019 ENDIF
61020
61021C...Identify any indices.
61022 I1=0
61023 I2=0
61024 I3=0
61025 NINDX=0
61026 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
61027 LIND=LNAM
61028 190 LIND=LIND+1
61029 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
61030 CHIND=' '
61031 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
61032 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
61033 & IVAR.EQ.37)) THEN
61034 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
61035 READ(CHIND,'(I8)') KF
61036 I1=PYCOMP(KF)
61037 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
61038 & 'c') THEN
61039 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
61040 & CHNAM)
61041 LLOW=LHIG
61042 IF(LLOW.LT.LTOT) GOTO 120
61043 RETURN
61044 ELSE
61045 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
61046 READ(CHIND,'(I8)') I1
61047 ENDIF
61048 LNAM=LIND
61049 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
61050 NINDX=1
61051 ENDIF
61052 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
61053 LIND=LNAM
61054 200 LIND=LIND+1
61055 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
61056 CHIND=' '
61057 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
61058 READ(CHIND,'(I8)') I2
61059 LNAM=LIND
61060 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
61061 NINDX=2
61062 ENDIF
61063 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
61064 LIND=LNAM
61065 210 LIND=LIND+1
61066 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
61067 CHIND=' '
61068 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
61069 READ(CHIND,'(I8)') I3
61070 LNAM=LIND+1
61071 NINDX=3
61072 ENDIF
61073
61074C...Check that indices allowed.
61075 IERR=0
61076 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
61077 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
61078 &IERR=2
61079 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
61080 &IERR=3
61081 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
61082 &IERR=4
61083 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
61084 IF(IERR.GE.1) THEN
61085 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
61086 & CHBIT(1:LNAM-1))
61087 LLOW=LHIG
61088 IF(LLOW.LT.LTOT) GOTO 120
61089 RETURN
61090 ENDIF
61091
61092C...Save old value of variable.
61093 IF(IVAR.EQ.1) THEN
61094 IOLD=N
61095 ELSEIF(IVAR.EQ.2) THEN
61096 IOLD=K(I1,I2)
61097 ELSEIF(IVAR.EQ.3) THEN
61098 ROLD=P(I1,I2)
61099 ELSEIF(IVAR.EQ.4) THEN
61100 ROLD=V(I1,I2)
61101 ELSEIF(IVAR.EQ.5) THEN
61102 IOLD=MSTU(I1)
61103 ELSEIF(IVAR.EQ.6) THEN
61104 ROLD=PARU(I1)
61105 ELSEIF(IVAR.EQ.7) THEN
61106 IOLD=MSTJ(I1)
61107 ELSEIF(IVAR.EQ.8) THEN
61108 ROLD=PARJ(I1)
61109 ELSEIF(IVAR.EQ.9) THEN
61110 IOLD=KCHG(I1,I2)
61111 ELSEIF(IVAR.EQ.10) THEN
61112 ROLD=PMAS(I1,I2)
61113 ELSEIF(IVAR.EQ.11) THEN
61114 ROLD=PARF(I1)
61115 ELSEIF(IVAR.EQ.12) THEN
61116 ROLD=VCKM(I1,I2)
61117 ELSEIF(IVAR.EQ.13) THEN
61118 IOLD=MDCY(I1,I2)
61119 ELSEIF(IVAR.EQ.14) THEN
61120 IOLD=MDME(I1,I2)
61121 ELSEIF(IVAR.EQ.15) THEN
61122 ROLD=BRAT(I1)
61123 ELSEIF(IVAR.EQ.16) THEN
61124 IOLD=KFDP(I1,I2)
61125 ELSEIF(IVAR.EQ.17) THEN
61126 CHOLD=CHAF(I1,I2)(1:8)
61127 ELSEIF(IVAR.EQ.18) THEN
61128 IOLD=MRPY(I1)
61129 ELSEIF(IVAR.EQ.19) THEN
61130 ROLD=RRPY(I1)
61131 ELSEIF(IVAR.EQ.20) THEN
61132 IOLD=MSEL
61133 ELSEIF(IVAR.EQ.21) THEN
61134 IOLD=MSUB(I1)
61135 ELSEIF(IVAR.EQ.22) THEN
61136 IOLD=KFIN(I1,I2)
61137 ELSEIF(IVAR.EQ.23) THEN
61138 ROLD=CKIN(I1)
61139 ELSEIF(IVAR.EQ.24) THEN
61140 IOLD=MSTP(I1)
61141 ELSEIF(IVAR.EQ.25) THEN
61142 ROLD=PARP(I1)
61143 ELSEIF(IVAR.EQ.26) THEN
61144 IOLD=MSTI(I1)
61145 ELSEIF(IVAR.EQ.27) THEN
61146 ROLD=PARI(I1)
61147 ELSEIF(IVAR.EQ.28) THEN
61148 IOLD=MINT(I1)
61149 ELSEIF(IVAR.EQ.29) THEN
61150 ROLD=VINT(I1)
61151 ELSEIF(IVAR.EQ.30) THEN
61152 IOLD=ISET(I1)
61153 ELSEIF(IVAR.EQ.31) THEN
61154 IOLD=KFPR(I1,I2)
61155 ELSEIF(IVAR.EQ.32) THEN
61156 ROLD=COEF(I1,I2)
61157 ELSEIF(IVAR.EQ.33) THEN
61158 IOLD=ICOL(I1,I2,I3)
61159 ELSEIF(IVAR.EQ.34) THEN
61160 ROLD=XSFX(I1,I2)
61161 ELSEIF(IVAR.EQ.35) THEN
61162 IOLD=ISIG(I1,I2)
61163 ELSEIF(IVAR.EQ.36) THEN
61164 ROLD=SIGH(I1)
61165 ELSEIF(IVAR.EQ.37) THEN
61166 IOLD=MWID(I1)
61167 ELSEIF(IVAR.EQ.38) THEN
61168 ROLD=WIDS(I1,I2)
61169 ELSEIF(IVAR.EQ.39) THEN
61170 IOLD=NGEN(I1,I2)
61171 ELSEIF(IVAR.EQ.40) THEN
61172 ROLD=XSEC(I1,I2)
61173 ELSEIF(IVAR.EQ.41) THEN
61174 CHOLD2=PROC(I1)
61175 ELSEIF(IVAR.EQ.42) THEN
61176 ROLD=SIGT(I1,I2,I3)
61177 ELSEIF(IVAR.EQ.43) THEN
61178 ROLD=XPVMD(I1)
61179 ELSEIF(IVAR.EQ.44) THEN
61180 ROLD=XPANL(I1)
61181 ELSEIF(IVAR.EQ.45) THEN
61182 ROLD=XPANH(I1)
61183 ELSEIF(IVAR.EQ.46) THEN
61184 ROLD=XPBEH(I1)
61185 ELSEIF(IVAR.EQ.47) THEN
61186 ROLD=XPDIR(I1)
61187 ELSEIF(IVAR.EQ.48) THEN
61188 IOLD=IMSS(I1)
61189 ELSEIF(IVAR.EQ.49) THEN
61190 ROLD=RMSS(I1)
61191 ELSEIF(IVAR.EQ.50) THEN
61192 ROLD=RVLAM(I1,I2,I3)
61193 ELSEIF(IVAR.EQ.51) THEN
61194 ROLD=RVLAMP(I1,I2,I3)
61195 ELSEIF(IVAR.EQ.52) THEN
61196 ROLD=RVLAMB(I1,I2,I3)
61197 ELSEIF(IVAR.EQ.53) THEN
61198 IOLD=ITCM(I1)
61199 ELSEIF(IVAR.EQ.54) THEN
61200 ROLD=RTCM(I1)
61201 ELSEIF(IVAR.EQ.55) THEN
61202 IOLD=IUED(I1)
61203 ELSEIF(IVAR.EQ.56) THEN
61204 ROLD=RUED(I1)
61205 ENDIF
61206
61207C...Print current value of variable. Loop back.
61208 IF(LNAM.GE.LBIT) THEN
61209 CHBIT(LNAM:14)=' '
61210 CHBIT(15:60)=' has the value '
61211 IF(MSVAR(IVAR,1).EQ.1) THEN
61212 WRITE(CHBIT(51:60),'(I10)') IOLD
61213 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
61214 WRITE(CHBIT(47:60),'(F14.5)') ROLD
61215 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
61216 CHBIT(53:60)=CHOLD
61217 ELSE
61218 CHBIT(33:60)=CHOLD
61219 ENDIF
61220 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61221 LLOW=LHIG
61222 IF(LLOW.LT.LTOT) GOTO 120
61223 RETURN
61224 ENDIF
61225
61226C...Read in new variable value.
61227 IF(MSVAR(IVAR,1).EQ.1) THEN
61228 CHINI=' '
61229 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
61230 READ(CHINI,'(I10)') INEW
61231 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
61232 CHINR=' '
61233 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
61234 READ(CHINR,*) RNEW
61235 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
61236 CHNEW=CHBIT(LNAM+1:LBIT)//' '
61237 ELSE
61238 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
61239 ENDIF
61240
61241C...Store new variable value.
61242 IF(IVAR.EQ.1) THEN
61243 N=INEW
61244 ELSEIF(IVAR.EQ.2) THEN
61245 K(I1,I2)=INEW
61246 ELSEIF(IVAR.EQ.3) THEN
61247 P(I1,I2)=RNEW
61248 ELSEIF(IVAR.EQ.4) THEN
61249 V(I1,I2)=RNEW
61250 ELSEIF(IVAR.EQ.5) THEN
61251 MSTU(I1)=INEW
61252 ELSEIF(IVAR.EQ.6) THEN
61253 PARU(I1)=RNEW
61254 ELSEIF(IVAR.EQ.7) THEN
61255 MSTJ(I1)=INEW
61256 ELSEIF(IVAR.EQ.8) THEN
61257 PARJ(I1)=RNEW
61258 ELSEIF(IVAR.EQ.9) THEN
61259 KCHG(I1,I2)=INEW
61260 ELSEIF(IVAR.EQ.10) THEN
61261 PMAS(I1,I2)=RNEW
61262 ELSEIF(IVAR.EQ.11) THEN
61263 PARF(I1)=RNEW
61264 ELSEIF(IVAR.EQ.12) THEN
61265 VCKM(I1,I2)=RNEW
61266 ELSEIF(IVAR.EQ.13) THEN
61267 MDCY(I1,I2)=INEW
61268 ELSEIF(IVAR.EQ.14) THEN
61269 MDME(I1,I2)=INEW
61270 ELSEIF(IVAR.EQ.15) THEN
61271 BRAT(I1)=RNEW
61272 ELSEIF(IVAR.EQ.16) THEN
61273 KFDP(I1,I2)=INEW
61274 ELSEIF(IVAR.EQ.17) THEN
61275 CHAF(I1,I2)=CHNEW
61276 ELSEIF(IVAR.EQ.18) THEN
61277 MRPY(I1)=INEW
61278 ELSEIF(IVAR.EQ.19) THEN
61279 RRPY(I1)=RNEW
61280 ELSEIF(IVAR.EQ.20) THEN
61281 MSEL=INEW
61282 ELSEIF(IVAR.EQ.21) THEN
61283 MSUB(I1)=INEW
61284 ELSEIF(IVAR.EQ.22) THEN
61285 KFIN(I1,I2)=INEW
61286 ELSEIF(IVAR.EQ.23) THEN
61287 CKIN(I1)=RNEW
61288 ELSEIF(IVAR.EQ.24) THEN
61289 MSTP(I1)=INEW
61290 ELSEIF(IVAR.EQ.25) THEN
61291 PARP(I1)=RNEW
61292 ELSEIF(IVAR.EQ.26) THEN
61293 MSTI(I1)=INEW
61294 ELSEIF(IVAR.EQ.27) THEN
61295 PARI(I1)=RNEW
61296 ELSEIF(IVAR.EQ.28) THEN
61297 MINT(I1)=INEW
61298 ELSEIF(IVAR.EQ.29) THEN
61299 VINT(I1)=RNEW
61300 ELSEIF(IVAR.EQ.30) THEN
61301 ISET(I1)=INEW
61302 ELSEIF(IVAR.EQ.31) THEN
61303 KFPR(I1,I2)=INEW
61304 ELSEIF(IVAR.EQ.32) THEN
61305 COEF(I1,I2)=RNEW
61306 ELSEIF(IVAR.EQ.33) THEN
61307 ICOL(I1,I2,I3)=INEW
61308 ELSEIF(IVAR.EQ.34) THEN
61309 XSFX(I1,I2)=RNEW
61310 ELSEIF(IVAR.EQ.35) THEN
61311 ISIG(I1,I2)=INEW
61312 ELSEIF(IVAR.EQ.36) THEN
61313 SIGH(I1)=RNEW
61314 ELSEIF(IVAR.EQ.37) THEN
61315 MWID(I1)=INEW
61316 ELSEIF(IVAR.EQ.38) THEN
61317 WIDS(I1,I2)=RNEW
61318 ELSEIF(IVAR.EQ.39) THEN
61319 NGEN(I1,I2)=INEW
61320 ELSEIF(IVAR.EQ.40) THEN
61321 XSEC(I1,I2)=RNEW
61322 ELSEIF(IVAR.EQ.41) THEN
61323 PROC(I1)=CHNEW2
61324 ELSEIF(IVAR.EQ.42) THEN
61325 SIGT(I1,I2,I3)=RNEW
61326 ELSEIF(IVAR.EQ.43) THEN
61327 XPVMD(I1)=RNEW
61328 ELSEIF(IVAR.EQ.44) THEN
61329 XPANL(I1)=RNEW
61330 ELSEIF(IVAR.EQ.45) THEN
61331 XPANH(I1)=RNEW
61332 ELSEIF(IVAR.EQ.46) THEN
61333 XPBEH(I1)=RNEW
61334 ELSEIF(IVAR.EQ.47) THEN
61335 XPDIR(I1)=RNEW
61336 ELSEIF(IVAR.EQ.48) THEN
61337 IMSS(I1)=INEW
61338 ELSEIF(IVAR.EQ.49) THEN
61339 RMSS(I1)=RNEW
61340 ELSEIF(IVAR.EQ.50) THEN
61341 RVLAM(I1,I2,I3)=RNEW
61342 ELSEIF(IVAR.EQ.51) THEN
61343 RVLAMP(I1,I2,I3)=RNEW
61344 ELSEIF(IVAR.EQ.52) THEN
61345 RVLAMB(I1,I2,I3)=RNEW
61346 ELSEIF(IVAR.EQ.53) THEN
61347 ITCM(I1)=INEW
61348 ELSEIF(IVAR.EQ.54) THEN
61349 RTCM(I1)=RNEW
61350 ELSEIF(IVAR.EQ.55) THEN
61351 IUED(I1)=INEW
61352 ELSEIF(IVAR.EQ.56) THEN
61353 RUED(I1)=RNEW
61354 ENDIF
61355
61356C...Write old and new value. Loop back.
61357 CHBIT(LNAM:14)=' '
61358 CHBIT(15:60)=' changed from to '
61359 IF(MSVAR(IVAR,1).EQ.1) THEN
61360 WRITE(CHBIT(33:42),'(I10)') IOLD
61361 WRITE(CHBIT(51:60),'(I10)') INEW
61362 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61363 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
61364 WRITE(CHBIT(29:42),'(F14.5)') ROLD
61365 WRITE(CHBIT(47:60),'(F14.5)') RNEW
61366 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61367 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
61368 CHBIT(35:42)=CHOLD
61369 CHBIT(53:60)=CHNEW
61370 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61371 ELSE
61372 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
61373 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
61374 ENDIF
61375 LLOW=LHIG
61376 IF(LLOW.LT.LTOT) GOTO 120
61377
61378C...Format statement for output on unit MSTU(11) (by default 6).
61379 5000 FORMAT(5X,A60)
61380 5100 FORMAT(5X,A88)
61381
61382 RETURN
61383 END
61384
61385C*********************************************************************
61386
61387C...PYONOF
61388C...Switches on and off decay channel by search for match.
61389
61390 SUBROUTINE PYONOF(CHIN)
61391
61392C...Double precision and integer declarations.
61393 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61394 IMPLICIT INTEGER(I-N)
61395 INTEGER PYK,PYCHGE,PYCOMP
61396C...Commonblocks.
61397 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61398 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
61399 SAVE /PYDAT1/,/PYDAT3/
61400C...Local arrays and character variables.
61401 INTEGER KFCMP(10),KFTMP(10)
61402 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
61403 &CHALP(2)*26
61404 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
61405 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
61406
61407C...Determine length of character variable.
61408 CHTMP=CHIN//' '
61409 LBEG=0
61410 100 LBEG=LBEG+1
61411 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
61412 LEND=LBEG-1
61413 105 LEND=LEND+1
61414 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
61415 110 LEND=LEND-1
61416 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
61417 LEN=1+LEND-LBEG
61418 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
61419
61420C...Find colon separator and particle code.
61421 LCOLON=0
61422 120 LCOLON=LCOLON+1
61423 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
61424 CHCODE=' '
61425 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
61426 READ(CHCODE,'(I8)',ERR=300) KF
61427 KC=PYCOMP(KF)
61428
61429C...Done if unknown code or no decay channels.
61430 IF(KC.EQ.0) THEN
61431 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
61432 RETURN
61433 ENDIF
61434 IDCBEG=MDCY(KC,2)
61435 IDCLEN=MDCY(KC,3)
61436 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
61437 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
61438 RETURN
61439 ENDIF
61440
61441C...Find command name up to blank or equal sign.
61442 LSEP=LCOLON
61443 130 LSEP=LSEP+1
61444 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
61445 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
61446 CHMODE=' '
61447 LMODE=LSEP-LCOLON-1
61448 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
61449
61450C...Convert to uppercase.
61451 DO 150 LCOM=1,LMODE
61452 DO 140 LALP=1,26
61453 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
61454 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
61455 140 CONTINUE
61456 150 CONTINUE
61457
61458C...Identify command. Failed if not identified.
61459 MODE=0
61460 IF(CHMODE.EQ.'ALLOFF') MODE=1
61461 IF(CHMODE.EQ.'ALLON') MODE=2
61462 IF(CHMODE.EQ.'OFFIFANY') MODE=3
61463 IF(CHMODE.EQ.'ONIFANY') MODE=4
61464 IF(CHMODE.EQ.'OFFIFALL') MODE=5
61465 IF(CHMODE.EQ.'ONIFALL') MODE=6
61466 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
61467 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
61468 IF(MODE.EQ.0) THEN
61469 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
61470 RETURN
61471 ENDIF
61472
61473C...Simple cases when all on or all off.
61474 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
61475 WRITE(MSTU(11),1000) KF,CHMODE
61476 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
61477 IF(MDME(IDC,1).LT.0) GOTO 160
61478 MDME(IDC,1)=MODE-1
61479 160 CONTINUE
61480 RETURN
61481 ENDIF
61482
61483C...Identify matching list.
61484 NCMP=0
61485 LBEG=LSEP
61486 170 LBEG=LBEG+1
61487 IF(LBEG.GT.LEN) GOTO 190
61488 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
61489 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
61490 LEND=LBEG-1
61491 180 LEND=LEND+1
61492 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
61493 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
61494 IF(LEND.LT.LEN) LEND=LEND-1
61495 CHCODE=' '
61496 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
61497 READ(CHCODE,'(I8)',ERR=300) KFREAD
61498 NCMP=NCMP+1
61499 KFCMP(NCMP)=IABS(KFREAD)
61500 LBEG=LEND
61501 IF(NCMP.LT.10) GOTO 170
61502 190 CONTINUE
61503 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
61504
61505C...Only one matching required.
61506 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
61507 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
61508 IF(MDME(IDC,1).LT.0) GOTO 220
61509 DO 210 IKF=1,5
61510 KFNOW=IABS(KFDP(IDC,IKF))
61511 IF(KFNOW.EQ.0) GOTO 210
61512 DO 200 ICMP=1,NCMP
61513 IF(KFCMP(ICMP).EQ.KFNOW) THEN
61514 MDME(IDC,1)=MODE-3
61515 GOTO 220
61516 ENDIF
61517 200 CONTINUE
61518 210 CONTINUE
61519 220 CONTINUE
61520 RETURN
61521 ENDIF
61522
61523C...Multiple matchings required.
61524 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
61525 IF(MDME(IDC,1).LT.0) GOTO 260
61526 NTMP=NCMP
61527 DO 230 ITMP=1,NTMP
61528 KFTMP(ITMP)=KFCMP(ITMP)
61529 230 CONTINUE
61530 NFIN=0
61531 DO 250 IKF=1,5
61532 KFNOW=IABS(KFDP(IDC,IKF))
61533 IF(KFNOW.EQ.0) GOTO 250
61534 NFIN=NFIN+1
61535 DO 240 ITMP=1,NTMP
61536 IF(KFTMP(ITMP).EQ.KFNOW) THEN
61537 KFTMP(ITMP)=KFTMP(NTMP)
61538 NTMP=NTMP-1
61539 GOTO 250
61540 ENDIF
61541 240 CONTINUE
61542 250 CONTINUE
61543 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
61544 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
61545 & MDME(IDC,1)=MODE-7
61546 260 CONTINUE
61547 RETURN
61548
61549C...Error exit for impossible read of particle code.
61550 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
61551 &//CHCODE)
61552
61553C...Formats for output.
61554 1000 FORMAT(' Decays for',I8,' set ',A10)
61555 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
61556
61557 RETURN
61558 END
61559C*********************************************************************
61560
61561C...PYTUNE
61562C...Presets for a few specific underlying-event and min-bias tunes
61563C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
61564C...others require particular versions of pythia (e.g. the SCI and GAL
61565C...models). See below for details.
61566 SUBROUTINE PYTUNE(ITUNE)
61567C
61568C ITUNE NAME (detailed descriptions below)
61569C 0 Default : No settings changed => defaults.
61570C
61571C ====== Old UE, Q2-ordered showers ====================================
61572C 100 A : Rick Field's CDF Tune A (Oct 2002)
61573C 101 AW : Rick Field's CDF Tune AW (Apr 2006)
61574C 102 BW : Rick Field's CDF Tune BW (Apr 2006)
61575C 103 DW : Rick Field's CDF Tune DW (Apr 2006)
61576C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006)
61577C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?)
61578C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?)
61579C 107 ACR : Tune A modified with new CR model (Mar 2007)
61580C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?)
61581C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?)
61582C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
61583C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008)
61584C 111 AW-Pro : Tune AW, -"- (Oct 2008)
61585C 112 BW-Pro : Tune BW, -"- (Oct 2008)
61586C 113 DW-Pro : Tune DW, -"- (Oct 2008)
61587C 114 DWT-Pro : Tune DWT, -"- (Oct 2008)
61588C 115 QW-Pro : Tune QW, -"- (Oct 2008)
61589C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008)
61590C 117 ACR-Pro : Tune ACR, -"- (Oct 2008)
61591C 118 D6-Pro : Tune D6, -"- (Oct 2008)
61592C 119 D6T-Pro : Tune D6T, -"- (Oct 2008)
61593C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
61594C 129 Pro-Q2O : Professor Q2-ordered tune (Feb 2009)
61595C
61596C ====== Intermediate and Hybrid Models ================================
61597C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
61598C 201 APT : Tune A w. pT-ordered FSR (Mar 2007)
61599C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008)
61600C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009)
61601C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
61602C
61603C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
61604C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006)
61605C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006)
61606C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006)
61607C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006)
61608C 304 NOCR : New UE "best try" without col. rec. (Apr 2006)
61609C 305 Old : New UE, original (primitive) col. rec. (Aug 2004)
61610C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
61611C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
61612C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008)
61613C 311 S1-Pro : S1 -"- (Oct 2008)
61614C 312 S2-Pro : S2 -"- (Oct 2008)
61615C 313 S0A-Pro : S0A -"- (Oct 2008)
61616C 314 NOCR-Pro : NOCR -"- (Oct 2008)
61617C 315 Old-Pro : Old -"- (Oct 2008)
61618C 316 ATLAS MC08 : pT-ordered showers, CTEQ6L1 (2008)
61619C ---- Peter's Perugia Tunes : 320+ ------------------------------------
61620C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009)
61621C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
61622C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
61623C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
61624C balance & different scaling to LHC & RHIC (Feb 2009)
61625C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009)
61626C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
61627C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
61628C 327 Perugia 10: Alternative to Perugia 0, with more FSR (May 2010)
61629C off ISR, more BR breakup, more strangeness
61630C 328 Perugia K : Alternative to Perugia 2010, with a (May 2010)
61631C K-factor applied to MPI cross sections
61632C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
61633C 329 Pro-pTO : Professor pT-ordered tune w. S0 CR model (Feb 2009)
61634C ---- Tunes introduced in 6.4.23:
61635C 330 ATLAS MC09 : pT-ordered showers, LO* PDFs (2009)
61636C 331 ATLAS MC09c : pT-ordered showers, LO* PDFs, better CR (2009)
61637C 334 Perugia 10 NOCR : Perugia 2010 with no CR, less MPI (Oct 2010)
61638C 335 Pro-pT* : Professor Tune with LO* (Mar 2009)
61639C 336 Pro-pT6 : Professor Tune with CTEQ6LL (Mar 2009)
61640C 339 Pro-pT** : Professor Tune with LO** (Mar 2009)
61641C 340 AMBT1 : First ATLAS tune including 7 TeV data (May 2010)
61642C 341 Z1 : First CMS tune including 7 TeV data (Aug 2010)
61643C 342 Z1-LEP : CMS tune Z1, with improved LEP parameters (Oct 2010)
61644C 343 Z2 : Retune of Z1 by Field w CTEQ6L1 PDFs (2010)
61645C 344 Z2-LEP : Retune of Z1 by Skands w CTEQ6L1 PDFs (Feb 2011)
61646C 350 Perugia 2011 : Retune of Perugia 2010 incl 7-TeV data (Mar 2011)
61647C 351 P2011 radHi : Variation with alphaS(pT/2)
61648C 352 P2011 radLo : Variation with alphaS(2pT)
61649C 353 P2011 mpiHi : Variation with more semi-hard MPI
61650C 354 P2011 noCR : Variation without color reconnections
61651C 355 P2011 LO** : Perugia 2011 using MSTW LO** PDFs (Mar 2011)
61652C 356 P2011 C6 : Perugia 2011 using CTEQ6L1 PDFs (Mar 2011)
61653C 357 P2011 T16 : Variation with PARP(90)=0.32 away from 7 TeV
61654C 358 P2011 T32 : Variation with PARP(90)=0.16 awat from 7 TeV
61655C 359 P2011 TeV : Perugia 2011 optimized for Tevatron (Mar 2011)
61656C 360 S Global : Schulz-Skands Global fit (Mar 2011)
61657C 361 S 7000 : Schulz-Skands at 7000 GeV (Mar 2011)
61658C 362 S 1960 : Schulz-Skands at 1960 GeV (Mar 2011)
61659C 363 S 1800 : Schulz-Skands at 1800 GeV (Mar 2011)
61660C 364 S 900 : Schulz-Skands at 900 GeV (Mar 2011)
61661C 365 S 630 : Schulz-Skands at 630 GeV (Mar 2011)
61662C
61663C ======= The Uppsala models ===========================================
61664C ( NB! must be run with special modified Pythia 6.215 version )
61665C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
61666C 400 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
61667C 401 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
61668C 402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006)
61669C 403 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
61670C
61671C More details;
61672C
61673C Quick Dictionary:
61674C BE : Bose-Einstein
61675C BR : Beam Remnants
61676C CR : Colour Reconnections
61677C HAD: Hadronization
61678C ISR/FSR: Initial-State Radiation / Final-State Radiation
61679C FSI: Final-State Interactions (=CR+BE)
61680C MB : Minimum-bias
61681C MI : Multiple Interactions
61682C UE : Underlying Event
61683C
61684C=======================================================================
61685C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
61686C=======================================================================
61687C
61688C A (100) and AW (101). CTEQ5L parton distributions
61689C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61690C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61691C...Key feature: extensively compared to CDF data (R.D. Field).
61692C...* Large starting scale for ISR (PARP(67)=4)
61693C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
61694C...* See: http://www.phys.ufl.edu/~rfield/cdf/
61695C
61696C BW (102). CTEQ5L parton distributions
61697C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61698C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61699C...Key feature: extensively compared to CDF data (R.D. Field).
61700C...NB: Can also be run with Pythia 6.2 or 6.312+
61701C...* Small starting scale for ISR (PARP(67)=1)
61702C...* BW has more radiation due to smaller mu_R choice in alpha_s.
61703C...* See: http://www.phys.ufl.edu/~rfield/cdf/
61704C
61705C DW (103) and DWT (104). CTEQ5L parton distributions
61706C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61707C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61708C...Key feature: extensively compared to CDF data (R.D. Field).
61709C...NB: Can also be run with Pythia 6.2 or 6.312+
61710C...* Intermediate starting scale for ISR (PARP(67)=2.5)
61711C...* DWT has a different reference energy, the same as the "S" models
61712C... below, leading to more UE activity at the LHC, but less at RHIC.
61713C...* See: http://www.phys.ufl.edu/~rfield/cdf/
61714C
61715C QW (105). CTEQ61 parton distributions
61716C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61717C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61718C...Key feature: uses CTEQ61 (external pdf library must be linked)
61719C
61720C ATLAS-DC2 (106). CTEQ5L parton distributions
61721C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61722C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61723C...Key feature: tune used by the ATLAS collaboration.
61724C
61725C ACR (107). CTEQ5L parton distributions
61726C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
61727C...Key feature: Tune A modified to use annealing CR.
61728C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
61729C
61730C D6 (108) and D6T (109). CTEQ6L parton distributions
61731C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
61732C
61733C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
61734C Old UE model, Q2-ordered showers.
61735C...Key feature: Rick Field's family of tunes revamped with the
61736C...Professor Q2-ordered final-state shower and fragmentation tunes
61737C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
61738C...Key feature: improved descriptions of LEP data.
61739C
61740C Pro-Q2O (129). CTEQ5L parton distributions
61741C Old UE model, Q2-ordered showers.
61742C...Key feature: Complete retune of old model by Professor, including
61743C...large amounts of both LEP and Tevatron data.
61744C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
61745C...extreme in this tune, corresponding to using mu_R = pT/3 .
61746C
61747C=======================================================================
61748C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
61749C=======================================================================
61750C
61751C IM1 (200). Intermediate model, Q2-ordered showers,
61752C CTEQ5L parton distributions
61753C...Key feature: new UE model w Q2-ordered showers and no interleaving.
61754C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
61755C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
61756C
61757C APT (201). Old UE model, pT-ordered final-state showers,
61758C CTEQ5L parton distributions
61759C...Key feature: Rick Field's Tune A, but with new final-state showers
61760C
61761C APT-Pro (211). Old UE model, pT-ordered final-state showers,
61762C CTEQ5L parton distributions
61763C...Key feature: APT revamped with the Professor pT-ordered final-state
61764C...shower and fragmentation tunes presented by Hendrik Hoeth at the
61765C...Perugia MPI workshop in October 2008.
61766C
61767C Perugia-APT (221). Old UE model, pT-ordered final-state showers,
61768C CTEQ5L parton distributions
61769C...Key feature: APT-Pro with final-state showers off the MPI,
61770C...lower ISR renormalization scale to improve agreement with the
61771C...Tevatron Drell-Yan pT measurements and with improved energy scaling
61772C...to min-bias at 630 GeV.
61773C
61774C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
61775C CTEQ6L1 parton distributions.
61776C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
61777C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
61778C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
61779C
61780C=======================================================================
61781C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
61782C=======================================================================
61783C
61784C S0 (300) and S0A (303). CTEQ5L parton distributions
61785C...Key feature: large amount of multiple interactions
61786C...* Somewhat faster than the other colour annealing scenarios.
61787C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
61788C... from Tune A, leading to less UE at the LHC, but more at RHIC.
61789C...* Small amount of radiation.
61790C...* Large amount of low-pT MI
61791C...* Low degree of proton lumpiness (broad matter dist.)
61792C...* CR Type S (driven by free triplets), of medium strength.
61793C...* See: Pythia6402 update notes or later.
61794C
61795C S1 (301). CTEQ5L parton distributions
61796C...Key feature: large amount of radiation.
61797C...* Large amount of low-pT perturbative ISR
61798C...* Large amount of FSR off ISR partons
61799C...* Small amount of low-pT multiple interactions
61800C...* Moderate degree of proton lumpiness
61801C...* Least aggressive CR type (S+S Type I), but with large strength
61802C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
61803C
61804C S2 (302). CTEQ5L parton distributions
61805C...Key feature: very lumpy proton + gg string cluster formation allowed
61806C...* Small amount of radiation
61807C...* Moderate amount of low-pT MI
61808C...* High degree of proton lumpiness (more spiky matter distribution)
61809C...* Most aggressive CR type (S+S Type II), but with small strength
61810C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
61811C
61812C NOCR (304). CTEQ5L parton distributions
61813C...Key feature: no colour reconnections (NB: "Best fit" only).
61814C...* NB: <pT>(Nch) problematic in this tune.
61815C...* Small amount of radiation
61816C...* Small amount of low-pT MI
61817C...* Low degree of proton lumpiness
61818C...* Large BR composite x enhancement factor
61819C...* Most clever colour flow without CR ("Lambda ordering")
61820C
61821C ATLAS-CSC (306). CTEQ6L parton distributions
61822C...Key feature: 11-parameter ATLAS tune of the new framework.
61823C...* Old (pre-annealing) colour reconnections a la 305.
61824C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
61825C
61826C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
61827C...Key feature: the S0 family of tunes revamped with the Professor
61828C...pT-ordered final-state shower and fragmentation tunes presented by
61829C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
61830C...Key feature: improved descriptions of LEP data.
61831C
61832C ATLAS MC08 (316). CTEQ6L1 parton distributions
61833C...Key feature: ATLAS tune of the new framework using CTEQ6L1 PDFs
61834C...* Warning: uses Peterson fragmentation function for heavy quarks
61835C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
61836C
61837C Perugia-0 (320). CTEQ5L parton distributions.
61838C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
61839C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
61840C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
61841C...beam-remnant breakup (more baryon number transport), and suppression
61842C...of CR in high-pT string pieces.
61843C
61844C Perugia-HARD (321). CTEQ5L parton distributions.
61845C...Key feature: More ISR, More FSR, Less MPI, Less BR
61846C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
61847C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
61848C...baryon number transport), and more fragmentation pT.
61849C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
61850C...DY pT spectrum is HARD.
61851C
61852C Perugia-SOFT (322). CTEQ5L parton distributions.
61853C...Key feature: Less ISR, Less FSR, More MPI, More BR
61854C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
61855C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
61856C...number transport), and less fragmentation pT.
61857C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
61858C...DY pT spectrum is SOFT
61859C
61860C Perugia-3 (323). CTEQ5L parton distributions.
61861C...Key feature: variant of Perugia-0 with more extreme energy scaling
61862C...properties while still agreeing with Tevatron data from 630 to 1960.
61863C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
61864C...allows FSR off the active end of dipoles stretched to the remnant.
61865C
61866C Perugia-NOCR (324). CTEQ5L parton distributions.
61867C...Key feature: Retune of NOCR-Pro with better scaling properties to
61868C...lower energies and somewhat better agreement with Tevatron data
61869C...at 1800/1960.
61870C
61871C Perugia-* (325). MRST LO* parton distributions for generators
61872C...Key feature: first attempt at using the LO* distributions
61873C...(external pdf library must be linked).
61874C
61875C Perugia-6 (326). CTEQ6L1 parton distributions
61876C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
61877C
61878C Perugia-2010 (327). CTEQ5L parton distributions
61879C...Key feature: Retune of Perugia 0 to attempt to better describe
61880C...strangeness yields at RHIC and at LEP. Also increased the amount
61881C...of FSR off ISR following the conclusions in arXiv:1001.4082.
61882C...Increased the amount of beam blowup, causing more baryon transport
61883C...into the detector, to further explore this possibility. Using
61884C...a new color-reconnection model that relies on determining a thrust
61885C...axis for the events and then computing reconnection probabilities for
61886C...the individual string pieces based on the actual string densities
61887C...per rapidity interval along that thrust direction.
61888C
61889C Perugia-K (328). CTEQ5L parton distributions
61890C...Key feature: uses a ``K'' factor on the MPI cross sections
61891C...This gives a larger rate of minijets and pushes the underlying-event
61892C...activity towards higher pT. To compensate for the increased activity
61893C...at higher pT, the infared regularization scale is larger for this tune.
61894C
61895C Pro-pTO (329). CTEQ5L parton distributions
61896C...Key feature: Complete retune of new model by Professor, including
61897C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
61898C
61899C ATLAS MC09 (330). LO* parton distributions
61900C...Key feature: Good overall agreement with Tevatron and early LHC data.
61901C...Similar to Perugia *.
61902C
61903C ATLAS MC09c (331). LO* parton distributions
61904C...Key feature: Good overall agreement with Tevatron and 900-GeV LHC data.
61905C...Similar to Perugia *. Retuned CR model with respect to MC09.
61906C
61907C Pro-pT* (335) LO* parton distributions
61908C...Key feature: Retune of Pro-PTO with MRST LO* PDFs.
61909C
61910C Pro-pT6 (336). CTEQ6L1 parton distributions
61911C...Key feature: Retune of Pro-PTO with CTEQ6L1 PDFs.
61912C
61913C Pro-pT** (339). LO** parton distributions
61914C...Key feature: Retune of Pro-PTO with MRST LO** PDFs.
61915C
61916C AMBT1 (340). LO* parton distributions
61917C...Key feature: First ATLAS tune including 7-TeV LHC data.
61918C...Mainly retuned CR and mass distribution with respect to MC09c.
61919C...Note: cannot be run standalone since it uses external PDFs.
61920C
61921C CMSZ1 (341). CTEQ5L parton distributions
61922C...Key feature: First CMS tune including 7-TeV LHC data.
61923C...Uses many of the features of AMBT1, but uses CTEQ5L PDFs,
61924C...has a lower pT0 at the Tevatron, which scales faster with energy.
61925C
61926C Z1-LEP (342). CTEQ5L parton distributions
61927C...Key feature: CMS tune Z1 with improved LEP parameters, mostly
61928C...taken from the Professor/Perugia tunes, with a few minor updates.
61929C
61930C=======================================================================
61931C OTHER TUNES
61932C=======================================================================
61933C
61934C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
61935C...with an unmodified Pythia distribution.
61936C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
61937C
61938C ::: + Future improvements?
61939C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
61940C (problem: K-factor affects everything so only works as
61941C intended for min-bias, not for UE ... probably need a
61942C better long-term solution to handle UE as well. Anyway,
61943C Mark uses MSTP(33) and PARP(31)-PARP(33).)
61944
61945C...Global statements
61946 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61947 INTEGER PYK,PYCHGE,PYCOMP
61948
61949C...Commonblocks.
61950 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61951 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
61952
61953C...SCI and GAL Commonblocks
61954 COMMON /SCIPAR/MSWI(2),PARSCI(2)
61955
61956C...SAVE statements
61957 SAVE /PYDAT1/,/PYPARS/
61958 SAVE /SCIPAR/
61959
61960C...Internal parameters
61961 PARAMETER(MXTUNS=500)
61962 CHARACTER*8 CHDOC
61963 PARAMETER (CHDOC='Mar 2011')
61964 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
61965 CHARACTER*42 CHMSTJ(50), CHMSTP(100), CHPARP(100),
61966 & CHPARJ(100), CHMSTU(101:121), CHPARU(101:121), CH40
61967 CHARACTER*60 CH60
61968 CHARACTER*70 CH70
61969 DATA (CHNAMS(I),I=0,1)/'Default',' '/
61970 DATA (CHNAMS(I),I=100,119)/
61971 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
61972 & 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
61973 1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
61974 1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
61975 1 'Tune D6-Pro','Tune D6T-Pro'/
61976 DATA (CHNAMS(I),I=120,129)/
61977 & 9*' ','Pro-Q2O'/
61978 DATA (CHNAMS(I),I=300,309)/
61979 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
61980 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
61981 DATA (CHNAMS(I),I=310,316)/
61982 & 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
61983 & 'NOCR-Pro','Old-Pro','ATLAS MC08'/
61984 DATA (CHNAMS(I),I=320,329)/
61985 & 'Perugia 0','Perugia HARD','Perugia SOFT',
61986 & 'Perugia 3','Perugia NOCR','Perugia LO*',
61987 & 'Perugia 6','Perugia 10','Perugia K','Pro-pTO'/
61988 DATA (CHNAMS(I),I=330,349)/
61989 & 'ATLAS MC09','ATLAS MC09c',2*' ','Perugia 10 NOCR','Pro-PT*',
61990 & 'Pro-PT6',' ',' ','Pro-PT**',
61991 4 'Tune AMBT1','Tune Z1','Tune Z1-LEP','Tune Z2','Tune Z2-LEP',
61992 4 5*' '/
61993 DATA (CHNAMS(I),I=350,359)/
61994 & 'Perugia 2011','P2011 radHi','P2011 radLo','P2011 mpiHi',
61995 & 'P2011 noCR','P2011 M(LO**)', 'P2011 CTEQ6L1',
61996 & 'P2011 T16','P2011 T32','P2011 Tevatron'/
61997 DATA (CHNAMS(I),I=360,369)/
61998 & 'S Global','S 7000','S 1960','S 1800',
61999 & 'S 900','S 630', 4*' '/
62000 DATA (CHNAMS(I),I=200,229)/
62001 & 'IM Tune 1','Tune APT',8*' ',
62002 & ' ','Tune APT-Pro',8*' ',
62003 & ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
62004 DATA (CHNAMS(I),I=400,409)/
62005 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
62006 DATA (CHMSTJ(I),I=11,20)/
62007 & 'HAD choice of fragmentation function(s)',4*' ',
62008 & 'HAD treatment of small-mass systems',4*' '/
62009 DATA (CHMSTJ(I),I=41,50)/
62010 & 'FSR type (Q2 or pT) for old framework',9*' '/
62011 DATA (CHMSTP(I),I=1,10)/
62012 & 2*' ','INT switch for choice of LambdaQCD',7*' '/
62013 DATA (CHMSTP(I),I=31,40)/
62014 & 2*' ','"K" switch for K-factor on/off & type',7*' '/
62015 DATA (CHMSTP(I),I=51,100)/
62016 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
62017 6 'ISR master switch',2*' ','ISR alphaS type',2*' ',
62018 6 'ISR coherence option for 1st emission',
62019 6 'ISR phase space choice & ME corrections',' ',
62020 7 'ISR IR regularization scheme',' ',
62021 7 'IFSR scheme for non-decay FSR',8*' ',
62022 8 'UE model',
62023 8 'UE hadron transverse mass distribution',5*' ',
62024 8 'BR composite scheme','BR color scheme',
62025 9 'BR primordial kT compensation',
62026 9 'BR primordial kT distribution',
62027 9 'BR energy partitioning scheme',2*' ',
62028 9 'FSI color (re-)connection model',5*' '/
62029 DATA (CHPARP(I),I=1,10)/
62030 & 'ME/UE LambdaQCD',9*' '/
62031 DATA (CHPARP(I),I=31,40)/
62032 & ' ','"K" K-factor',8*' '/
62033 DATA (CHPARP(I),I=61,100)/
62034 6 'ISR LambdaQCD','ISR IR cutoff',' ',
62035 6 'ISR renormalization scale prefactor',
62036 6 2*' ','ISR Q2max factor',3*' ',
62037 7 'IFSR Q2max factor in non-s-channel procs',
62038 7 'IFSR LambdaQCD (outside resonance decays)',4*' ',
62039 7 'FSI color reco high-pT damping strength',
62040 7 'FSI color reconnection strength',
62041 7 'BR composite x enhancement','BR breakup suppression',
62042 8 2*'UE IR cutoff at reference ecm',
62043 8 2*'UE mass distribution parameter',
62044 8 'UE gg color correlated fraction','UE total gg fraction',
62045 8 2*' ',
62046 8 'UE IR cutoff reference ecm',
62047 8 'UE IR cutoff ecm scaling power',
62048 9 'BR primordial kT width <|kT|>',' ',
62049 9 'BR primordial kT UV cutoff',7*' '/
62050 DATA (CHPARJ(I),I=1,30)/
62051 & 'HAD diquark suppression','HAD strangeness suppression',
62052 & 'HAD strange diquark suppression',
62053 & 'HAD vector diquark suppression','HAD P(popcorn)',
62054 & 'HAD extra popcorn B(s)-M-B(s) supp',
62055 & 'HAD extra popcorn B-M(s)-B supp',
62056 & 3*' ',
62057 1 'HAD P(vector meson), u and d only',
62058 1 'HAD P(vector meson), contains s',
62059 1 'HAD P(vector meson), heavy quarks',7*' ',
62060 2 'HAD fragmentation pT',' ',' ',' ',
62061 2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
62062 DATA (CHPARJ(I),I=41,90)/
62063 4 'HAD string parameter a(Meson)','HAD string parameter b',
62064 4 2*' ','HAD string a(Baryon)-a(Meson)',
62065 4 'HAD Lund(=0)-Bowler(=1) rQ (rc)',
62066 4 'HAD Lund(=0)-Bowler(=1) rb',3*' ',
62067 5 3*' ', 'HAD charm parameter','HAD bottom parameter',5*' ',
62068 6 10*' ',10*' ',
62069 8 'FSR LambdaQCD (inside resonance decays)',
62070 & 'FSR IR cutoff',8*' '/
62071 DATA (CHMSTU(I),I=111,120)/
62072 1 ' ','INT n(flavors) for LambdaQCD',8*' '/
62073 DATA (CHPARU(I),I=111,120)/
62074 1 ' ','INT LambdaQCD',8*' '/
62075
62076C...1) Shorthand notation
62077 M13=MSTU(13)
62078 M11=MSTU(11)
62079 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
62080 CHNAME=CHNAMS(ITUNE)
62081 IF (ITUNE.EQ.0) GOTO 9999
62082 ELSE
62083 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
62084 GOTO 9999
62085 ENDIF
62086
62087C...2) Hello World
62088 IF (M13.GE.1) WRITE(M11,5000) CHDOC
62089
62090C...Hardcode some defaults
62091C...Get Lambda from PDF
62092 MSTP(3) = 2
62093C...CTEQ5L1 PDFs
62094 MSTP(52) = 1
62095 MSTP(51) = 7
62096C... No K-factor
62097 MSTP(33) = 0
62098
62099C...3) Tune parameters
62100
62101C=======================================================================
62102C...ATLAS MC08
62103
62104 IF (ITUNE.EQ.316) THEN
62105
62106 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
62107 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62108 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62109 & ' with tune.')
62110 ENDIF
62111
62112C...First set some explicit defaults from 6.4.20
62113C...# Old defaults
62114 MSTJ(11) = 4
62115C...# Old default flavour parameters
62116 PARJ(1) = 0.1
62117 PARJ(2) = 0.3
62118 PARJ(3) = 0.40
62119 PARJ(4) = 0.05
62120 PARJ(11) = 0.5
62121 PARJ(12) = 0.6
62122 PARJ(21) = 0.36
62123 PARJ(41) = 0.30
62124 PARJ(42) = 0.58
62125 PARJ(46) = 1.0
62126 PARJ(82) = 1.0
62127
62128C...PDFs: CTEQ6L1 for 326
62129 MSTP(52)=2
62130 MSTP(51)=10042
62131
62132C...UE and ISR switches
62133 MSTP(81)=21
62134 MSTP(82)=4
62135 MSTP(70)=0
62136 MSTP(72)=1
62137
62138C...CR:
62139 MSTP(95)=2
62140 PARP(78)=0.3
62141 PARP(77)=0.0
62142 PARP(80)=0.1
62143
62144C...Primordial kT
62145 PARP(91)=2.0D0
62146 PARP(93)=5.0D0
62147
62148C...MPI:
62149 PARP(82)=2.1
62150 PARP(83)=0.8
62151 PARP(84)=0.7
62152 PARP(89)=1800.0
62153 PARP(90)=0.16
62154
62155C...FSR inside resonance decays
62156 PARJ(81)=0.29
62157
62158C...Fragmentation (warning: uses Peterson)
62159 MSTJ(11)=3
62160 PARJ(54)=-0.07
62161 PARJ(55)=-0.006
62162 MSTJ(22)=2
62163
62164 IF (M13.GE.1) THEN
62165 CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002'
62166 WRITE(M11,5030) CH60
62167 CH60='Physics model: '//
62168 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
62169 WRITE(M11,5030) CH60
62170 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
62171 WRITE(M11,5030) CH60
62172
62173C...Output
62174 WRITE(M11,5030) ' '
62175 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62176 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62177 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
62178 IF (MSTP(70).EQ.0) THEN
62179 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62180 ENDIF
62181 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
62182 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62183 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
62184 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62185 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62186 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62187 WRITE(M11,5030) CH60
62188 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
62189 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
62190 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62191 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62192 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62193 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
62194 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62195 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62196 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62197 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62198 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62199 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62200 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62201 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
62202 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
62203 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
62204 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
62205 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62206 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62207 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62208 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62209 IF (MSTP(95).GE.1) THEN
62210 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62211 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
62212 ENDIF
62213
62214 ENDIF
62215
62216C=======================================================================
62217C...ATLAS MC09, MC09c, AMBT1
62218C...CMS Z1 (R. Field), Z1-LEP
62219
62220 ELSEIF (ITUNE.EQ.330.OR.ITUNE.EQ.331.OR.ITUNE.EQ.340.OR.
62221 & ITUNE.GE.341.AND.ITUNE.LE.344) THEN
62222
62223 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
62224 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62225 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62226 & ' with tune.')
62227 ENDIF
62228
62229C...First set some explicit defaults from 6.4.20
62230 IF (ITUNE.LE.341.OR.ITUNE.EQ.343) THEN
62231C... # Old defaults
62232 MSTJ(11) = 4
62233C...# Old default flavour parameters
62234 PARJ(1) = 0.1
62235 PARJ(2) = 0.3
62236 PARJ(3) = 0.40
62237 PARJ(4) = 0.05
62238 PARJ(11) = 0.5
62239 PARJ(12) = 0.6
62240 PARJ(21) = 0.36
62241 PARJ(41) = 0.30
62242 PARJ(42) = 0.58
62243 PARJ(46) = 1.0
62244 PARJ(82) = 1.0
62245 ELSE
62246C...# For Zn-LEP tunes, use tuned flavour parameters from Professor/Perugia
62247 PARJ( 1) = 0.08D0
62248 PARJ( 2) = 0.21D0
62249 PARJ(3) = 0.94
62250 PARJ( 4) = 0.04D0
62251 PARJ(11) = 0.35D0
62252 PARJ(12) = 0.35D0
62253 PARJ(13) = 0.54
62254 PARJ(25) = 0.63
62255 PARJ(26) = 0.12
62256C...# Switch on Bowler:
62257 MSTJ(11) = 5
62258C...# Fragmentation
62259 PARJ(21) = 0.34D0
62260 PARJ(41) = 0.35D0
62261 PARJ(42) = 0.80D0
62262 PARJ(47) = 1.0
62263 PARJ(81) = 0.26D0
62264 PARJ(82) = 1.0D0
62265 ENDIF
62266
62267C...PDFs: MRST LO*
62268 MSTP(52)=2
62269 MSTP(51)=20650
62270 IF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN
62271C...Z1 uses CTEQ5L
62272 MSTP(52)=1
62273 MSTP(51)=7
62274 ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN
62275C...Z2 uses CTEQ6L
62276 MSTP(52)=2
62277 MSTP(51)=10042
62278 ENDIF
62279
62280C...UE and ISR switches
62281 MSTP(81)=21
62282 MSTP(82)=4
62283 MSTP(70)=0
62284 MSTP(72)=1
62285
62286C...CR:
62287 MSTP(95)=6
62288 PARP(78)=0.3
62289 PARP(77)=0.0
62290 PARP(80)=0.1
62291 IF (ITUNE.EQ.331) THEN
62292 PARP(78)=0.224
62293 ELSEIF (ITUNE.EQ.340) THEN
62294C...AMBT1
62295 PARP(77)=1.016D0
62296 PARP(78)=0.538D0
62297 ELSEIF (ITUNE.GE.341.AND.ITUNE.LE.344) THEN
62298C...Z1 and Z2 use the AMBT1 CR values
62299 PARP(77)=1.016D0
62300 PARP(78)=0.538D0
62301 ENDIF
62302
62303C...MPI:
62304 PARP(82)=2.3
62305 PARP(83)=0.8
62306 PARP(84)=0.7
62307 PARP(89)=1800.0
62308 PARP(90)=0.25
62309 IF (ITUNE.EQ.331) THEN
62310 PARP(82)=2.315
62311 PARP(90)=0.2487
62312 ELSEIF (ITUNE.EQ.340) THEN
62313 PARP(82)=2.292D0
62314 PARP(83)=0.356D0
62315 PARP(84)=0.651
62316 PARP(90)=0.25D0
62317 ELSEIF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN
62318 PARP(82)=1.932D0
62319 PARP(83)=0.356D0
62320 PARP(84)=0.651
62321 PARP(90)=0.275D0
62322 ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN
62323 PARP(82)=1.832D0
62324 PARP(83)=0.356D0
62325 PARP(84)=0.651
62326 PARP(90)=0.275D0
62327 ENDIF
62328
62329C...Primordial kT
62330 PARP(91)=2.0D0
62331 PARP(93)=5D0
62332 IF (ITUNE.GE.340) THEN
62333 PARP(93)=10D0
62334 ENDIF
62335
62336C...ISR
62337 IF (ITUNE.GE.340) THEN
62338 PARP(62)=1.025
62339 ENDIF
62340
62341C...FSR inside resonance decays
62342 PARJ(81)=0.29
62343
62344C...Fragmentation (org 6.4 defs hardcoded)
62345 MSTJ(11)=4
62346 PARJ(41)=0.3
62347 PARJ(42)=0.58
62348 MSTJ(22)=2
62349C...AMBT1 mentions 46 explicitly, but Z1 doesn't ...
62350 PARJ(46)=0.75
62351 IF (ITUNE.GE.341.AND.ITUNE.LE.344) THEN
62352C...Reset PARJ(46) to org def value for Z1 and Z2
62353 PARJ(46)=1.0
62354 ENDIF
62355
62356 IF (M13.GE.1) THEN
62357 IF (ITUNE.LT.340) THEN
62358 CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002'
62359 ELSEIF (ITUNE.EQ.340) THEN
62360 CH60='Tuned by ATLAS, ATLAS-CONF-2010-031'
62361 ELSEIF (ITUNE.EQ.341) THEN
62362 CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62363 WRITE(M11,5030) CH60
62364 CH60='Z1 variation tuned by R. D. Field (CMS)'
62365 ELSEIF (ITUNE.EQ.342) THEN
62366 CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62367 WRITE(M11,5030) CH60
62368 CH60='Z1 variation retuned by R. D. Field (CMS)'
62369 WRITE(M11,5030) CH60
62370 CH60='Z1-LEP variation retuned by Professor / P. Skands'
62371 ELSEIF (ITUNE.EQ.343) THEN
62372 CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62373 WRITE(M11,5030) CH60
62374 CH60='Z2 variation retuned by R. D. Field (CMS)'
62375 ELSEIF (ITUNE.EQ.344) THEN
62376 CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62377 WRITE(M11,5030) CH60
62378 CH60='Z2 variation retuned by R. D. Field (CMS)'
62379 WRITE(M11,5030) CH60
62380 CH60='Z2-LEP variation retuned by Professor / P. Skands'
62381 ENDIF
62382 WRITE(M11,5030) CH60
62383 CH60='Physics Model: '//
62384 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
62385 WRITE(M11,5030) CH60
62386 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
62387 WRITE(M11,5030) CH60
62388
62389C...Output
62390 WRITE(M11,5030) ' '
62391 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62392 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62393 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
62394 IF (MSTP(70).EQ.0) THEN
62395 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62396 ENDIF
62397 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
62398 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62399 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
62400 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62401 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62402 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62403 WRITE(M11,5030) CH60
62404 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
62405 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
62406 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62407 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62408 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62409 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
62410 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62411 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62412 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62413 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62414 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62415 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62416 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62417 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
62418 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
62419 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
62420 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
62421 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62422 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62423 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62424 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62425 IF (MSTP(95).GE.1) THEN
62426 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62427 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
62428 ENDIF
62429
62430 ENDIF
62431
62432C=======================================================================
62433C...S0, S1, S2, S0A, NOCR, Rap,
62434C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
62435C...Perugia 0, HARD, SOFT, 3, LO*, 6, 2010, K
62436C...Pro-pTO, Pro-PT*, Pro-PT6, Pro-PT**
62437C...Perugia 2011 (incl variations)
62438C...Schulz-Skands tunes
62439 ELSEIF ((ITUNE.GE.300.AND.ITUNE.LE.305)
62440 & .OR.(ITUNE.GE.310.AND.ITUNE.LE.315)
62441 & .OR.(ITUNE.GE.320.AND.ITUNE.LE.329)
62442 & .OR.(ITUNE.GE.334.AND.ITUNE.LE.336).OR.ITUNE.EQ.339
62443 & .OR.(ITUNE.GE.350.AND.ITUNE.LE.365)) THEN
62444 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
62445 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62446 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62447 & ' with tune.')
62448 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.339.AND.ITUNE.NE.324.AND.
62449 & ITUNE.NE.334.AND.
62450 & (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419)))
62451 & THEN
62452 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62453 & ' with tune.')
62454 ELSEIF((ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.GE.350).AND.
62455 & (MSTP(181).LE.5.OR.
62456 & (MSTP(181).EQ.6.AND.MSTP(182).LE.422)))
62457 & THEN
62458 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62459 & ' with tune.')
62460 ENDIF
62461
62462C...Use 327 as base tune for 350-359 (Perugia 2011)
62463 ITUNSV = ITUNE
62464 IF (ITUNE.GE.350.AND.ITUNE.LE.359) ITUNE = 327
62465C...Use 320 as base tune for 360+ (Schulz-Skands)
62466 IF (ITUNE.GE.360) ITUNE = 320
62467
62468C...HAD: Use Professor's LEP pars if ITUNE >= 310
62469C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
62470 IF (ITUNE.LT.310) THEN
62471C...# Old defaults
62472 MSTJ(11) = 4
62473C...# Old default flavour parameters
62474 PARJ(1) = 0.1
62475 PARJ(2) = 0.3
62476 PARJ(3) = 0.40
62477 PARJ(4) = 0.05
62478 PARJ(11) = 0.5
62479 PARJ(12) = 0.6
62480 PARJ(21) = 0.36
62481 PARJ(41) = 0.30
62482 PARJ(42) = 0.58
62483 PARJ(46) = 1.0
62484 PARJ(82) = 1.0
62485
62486 ELSEIF (ITUNE.GE.310) THEN
62487C...# Tuned flavour parameters:
62488 PARJ(1) = 0.073
62489 PARJ(2) = 0.2
62490 PARJ(3) = 0.94
62491 PARJ(4) = 0.032
62492 PARJ(11) = 0.31
62493 PARJ(12) = 0.4
62494 PARJ(13) = 0.54
62495 PARJ(25) = 0.63
62496 PARJ(26) = 0.12
62497C...# Always use pT-ordered shower:
62498 MSTJ(41) = 12
62499C...# Switch on Bowler:
62500 MSTJ(11) = 5
62501C...# Fragmentation
62502 PARJ(21) = 0.313
62503 PARJ(41) = 0.49
62504 PARJ(42) = 1.2
62505 PARJ(47) = 1.0
62506 PARJ(81) = 0.257
62507 PARJ(82) = 0.8
62508
62509C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
62510 IF (ITUNE.EQ.321) PARJ(21)=0.34D0
62511 IF (ITUNE.EQ.322) PARJ(21)=0.28D0
62512
62513C...HAD: P-2010 and P-K use different strangeness parameters
62514C... indicated by LEP and RHIC yields.
62515C...(only 5% different from Professor values, so should be within acceptable
62516C...theoretical uncertainty range)
62517C...(No attempt made to retune other flavor parameters post facto)
62518 IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
62519 PARJ( 1) = 0.08D0
62520 PARJ( 2) = 0.21D0
62521 PARJ( 4) = 0.04D0
62522 PARJ(11) = 0.35D0
62523 PARJ(12) = 0.35D0
62524 PARJ(21) = 0.36D0
62525 PARJ(41) = 0.35D0
62526 PARJ(42) = 0.90D0
62527 PARJ(81) = 0.26D0
62528 PARJ(82) = 1.0D0
62529 ENDIF
62530 ENDIF
62531
62532C...Remove middle digit now for Professor variants, since identical pars
62533 ITUNEB=ITUNE
62534 IF (ITUNE.GE.310.AND.ITUNE.LE.319) THEN
62535 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
62536 ENDIF
62537
62538C...PDFs: all use CTEQ5L as starting point
62539 MSTP(52)=1
62540 MSTP(51)=7
62541 IF (ITUNE.EQ.325.OR.ITUNE.EQ.335) THEN
62542C...MRST LO* for 325 and 335
62543 MSTP(52)=2
62544 MSTP(51)=20650
62545 ELSEIF (ITUNE.EQ.326.OR.ITUNE.EQ.336) THEN
62546C...CTEQ6L1 for 326 and 336
62547 MSTP(52)=2
62548 MSTP(51)=10042
62549 ELSEIF (ITUNE.EQ.339) THEN
62550C...MRST LO** for 339
62551 MSTP(52)=2
62552 MSTP(51)=20651
62553 ENDIF
62554
62555C...LambdaQCD choice: 327 and 328 use hardcoded, others get from PDF
62556 MSTP(3)=2
62557 IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
62558 MSTP(3) = 1
62559C...Hardcode CTEQ5L values for ME and ISR
62560 MSTU(112) = 4
62561 PARU(112) = 0.192D0
62562 PARP(61) = 0.192D0
62563 PARP( 1) = 0.192D0
62564C...but use LEP value also for non-res FSR
62565 PARP(72) = 0.260D0
62566 ENDIF
62567
62568C...ISR: use Lambda_MSbar with default scale for S0(A)
62569 MSTP(64)=2
62570 PARP(64)=1D0
62571 IF (ITUNE.EQ.320.OR.ITUNE.EQ.323.OR.ITUNE.EQ.324.OR.ITUNE.EQ.334
62572 & .OR.ITUNE.EQ.326.OR.ITUNE.EQ.327.OR.ITUNE.EQ.328) THEN
62573C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
62574 MSTP(64)=3
62575 PARP(64)=1D0
62576 ELSEIF (ITUNE.EQ.321) THEN
62577C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
62578 MSTP(64)=3
62579 PARP(64)=0.25D0
62580 ELSEIF (ITUNE.EQ.322) THEN
62581C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
62582 MSTP(64)=2
62583 PARP(64)=2D0
62584 ELSEIF (ITUNE.EQ.325) THEN
62585C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
62586 MSTP(64)=3
62587 PARP(64)=2D0
62588 ELSEIF (ITUNE.EQ.329.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR.
62589 & ITUNE.EQ.339) THEN
62590C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
62591 MSTP(64)=2
62592 PARP(64)=1.3D0
62593 IF (ITUNE.EQ.335) PARP(64)=0.92D0
62594 IF (ITUNE.EQ.336) PARP(64)=0.89D0
62595 IF (ITUNE.EQ.339) PARP(64)=0.97D0
62596 ENDIF
62597
62598C...ISR : power-suppressed power showers above s_color (since 6.4.19)
62599 MSTP(67)=2
62600 PARP(67)=4D0
62601C...Perugia tunes have stronger suppression, except HARD
62602 IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62603 PARP(67)=1D0
62604 IF (ITUNE.EQ.321) PARP(67)=4D0
62605 IF (ITUNE.EQ.322) PARP(67)=0.25D0
62606 ENDIF
62607
62608C...ISR IR cutoff type and FSR off ISR setting:
62609C...Smooth ISR, low FSR-off-ISR
62610 MSTP(70)=2
62611 MSTP(72)=0
62612 IF (ITUNEB.EQ.301) THEN
62613C...S1, S1-Pro: sharp ISR, high FSR
62614 MSTP(70)=0
62615 MSTP(72)=1
62616 ELSEIF (ITUNE.EQ.320.OR.ITUNE.EQ.324.OR.ITUNE.EQ.326
62617 & .OR.ITUNE.EQ.325) THEN
62618C...Perugia default is smooth ISR, high FSR-off-ISR
62619 MSTP(70)=2
62620 MSTP(72)=1
62621 ELSEIF (ITUNE.EQ.321) THEN
62622C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
62623 MSTP(70)=0
62624 PARP(62)=1.25D0
62625 MSTP(72)=1
62626 ELSEIF (ITUNE.EQ.322) THEN
62627C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
62628 MSTP(70)=1
62629 PARP(81)=1.5D0
62630 MSTP(72)=0
62631 ELSEIF (ITUNE.EQ.323) THEN
62632C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
62633 MSTP(70)=0
62634 PARP(62)=1.25D0
62635 MSTP(72)=2
62636 ELSEIF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
62637C...Perugia 2010/K: smooth ISR, high FSR-off-ISR (with dipole-to-BR radiating)
62638 MSTP(70)=2
62639 MSTP(72)=2
62640 ENDIF
62641
62642C...FSR activity: Perugia tunes use a lower PARP(71) as indicated
62643C...by Professor tunes (with HARD and SOFT variations)
62644 PARP(71)=4D0
62645 IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62646 PARP(71)=2D0
62647 IF (ITUNE.EQ.321) PARP(71)=4D0
62648 IF (ITUNE.EQ.322) PARP(71)=1D0
62649 ENDIF
62650 IF (ITUNE.EQ.329) PARP(71)=2D0
62651 IF (ITUNE.EQ.335) PARP(71)=1.29D0
62652 IF (ITUNE.EQ.336) PARP(71)=1.72D0
62653 IF (ITUNE.EQ.339) PARP(71)=1.20D0
62654
62655C...FSR: Lambda_FSR scale (only if not using professor)
62656 IF (ITUNE.LT.310) PARJ(81)=0.23D0
62657 IF (ITUNE.EQ.321) PARJ(81)=0.30D0
62658 IF (ITUNE.EQ.322) PARJ(81)=0.20D0
62659
62660C...K-factor : only 328 uses a K-factor on the UE cross sections
62661 MSTP(33)=0
62662 IF (ITUNE.EQ.328) THEN
62663 MSTP(33)=10
62664 PARP(32)=1.5
62665 ENDIF
62666C...UE on, new model
62667 MSTP(81)=21
62668
62669C...UE: hadron-hadron overlap profile (expOfPow for all)
62670 MSTP(82)=5
62671C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
62672 PARP(83)=1.6D0
62673 IF (ITUNEB.EQ.301) PARP(83)=1.4D0
62674 IF (ITUNEB.EQ.302) PARP(83)=1.2D0
62675C...NOCR variants have very smooth distributions
62676 IF (ITUNEB.EQ.304) PARP(83)=1.8D0
62677 IF (ITUNEB.EQ.305) PARP(83)=2.0D0
62678 IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62679C...Perugia variants have slightly smoother profiles by default
62680C...(to compensate for more tail by added radiation)
62681C...Perugia-SOFT has more peaked distribution, NOCR less peaked
62682 PARP(83)=1.7D0
62683 IF (ITUNE.EQ.322) PARP(83)=1.5D0
62684 IF (ITUNE.EQ.327) PARP(83)=1.5D0
62685 IF (ITUNE.EQ.328) PARP(83)=1.5D0
62686C...NOCR variants have smoother mass profiles
62687 IF (ITUNE.EQ.324) PARP(83)=1.8D0
62688 IF (ITUNE.EQ.334) PARP(83)=1.8D0
62689 ENDIF
62690C...Professor-pT0 also has very smooth distribution
62691 IF (ITUNE.EQ.329) PARP(83)=1.8
62692 IF (ITUNE.EQ.335) PARP(83)=1.68
62693 IF (ITUNE.EQ.336) PARP(83)=1.72
62694 IF (ITUNE.EQ.339) PARP(83)=1.67
62695
62696C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
62697 PARP(82)=1.85D0
62698 IF (ITUNEB.EQ.301) PARP(82)=2.1D0
62699 IF (ITUNEB.EQ.302) PARP(82)=1.9D0
62700 IF (ITUNEB.EQ.304) PARP(82)=2.05D0
62701 IF (ITUNEB.EQ.305) PARP(82)=1.9D0
62702 IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62703C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
62704C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
62705C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
62706C...slightly higher, due to increased activity.
62707 PARP(82)=2.0D0
62708 IF (ITUNE.EQ.321) PARP(82)=2.3D0
62709 IF (ITUNE.EQ.322) PARP(82)=1.9D0
62710 IF (ITUNE.EQ.323) PARP(82)=2.2D0
62711 IF (ITUNE.EQ.324) PARP(82)=1.95D0
62712 IF (ITUNE.EQ.325) PARP(82)=2.2D0
62713 IF (ITUNE.EQ.326) PARP(82)=1.95D0
62714 IF (ITUNE.EQ.327) PARP(82)=2.05D0
62715 IF (ITUNE.EQ.328) PARP(82)=2.45D0
62716 IF (ITUNE.EQ.334) PARP(82)=2.15D0
62717 ENDIF
62718C...Professor-pT0 maintains low pT0 vaue
62719 IF (ITUNE.EQ.329) PARP(82)=1.85D0
62720 IF (ITUNE.EQ.335) PARP(82)=2.10D0
62721 IF (ITUNE.EQ.336) PARP(82)=1.83D0
62722 IF (ITUNE.EQ.339) PARP(82)=2.28D0
62723
62724C...UE: IR cutoff reference energy and default energy scaling pace
62725 PARP(89)=1800D0
62726 PARP(90)=0.16D0
62727C...S0A, S0A-Pro have tune A energy scaling
62728 IF (ITUNEB.EQ.303) PARP(90)=0.25D0
62729 IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62730C...Perugia tunes explicitly include MB at 630 to fix energy scaling
62731 PARP(90)=0.26
62732 IF (ITUNE.EQ.321) PARP(90)=0.30D0
62733 IF (ITUNE.EQ.322) PARP(90)=0.24D0
62734 IF (ITUNE.EQ.323) PARP(90)=0.32D0
62735 IF (ITUNE.EQ.324) PARP(90)=0.24D0
62736C...LO* and CTEQ6L1 tunes have slower energy scaling
62737 IF (ITUNE.EQ.325) PARP(90)=0.23D0
62738 IF (ITUNE.EQ.326) PARP(90)=0.22D0
62739 ENDIF
62740C...Professor-pT0 has intermediate scaling
62741 IF (ITUNE.EQ.329) PARP(90)=0.22D0
62742 IF (ITUNE.EQ.335) PARP(90)=0.20D0
62743 IF (ITUNE.EQ.336) PARP(90)=0.20D0
62744 IF (ITUNE.EQ.339) PARP(90)=0.21D0
62745
62746C...BR: MPI initiator color connections rap-ordered by default
62747C...NOCR variants are Lambda-ordered, Perugia SOFT & 2010 random-ordered
62748 MSTP(89)=1
62749 IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89)=2
62750 IF (ITUNE.EQ.322) MSTP(89)=0
62751 IF (ITUNE.EQ.327) MSTP(89)=0
62752 IF (ITUNE.EQ.328) MSTP(89)=0
62753
62754C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
62755 PARP(80)=0.01D0
62756 IF (ITUNE.GE.320.AND.ITUNE.LE.328) THEN
62757C...Perugia tunes have more beam blowup by default
62758 PARP(80)=0.05D0
62759 IF (ITUNE.EQ.321) PARP(80)=0.01
62760 IF (ITUNE.EQ.323) PARP(80)=0.03
62761 IF (ITUNE.EQ.324) PARP(80)=0.01
62762 IF (ITUNE.EQ.327) PARP(80)=0.1
62763 IF (ITUNE.EQ.328) PARP(80)=0.1
62764 ENDIF
62765
62766C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
62767 MSTP(88)=0
62768 PARP(79)=2D0
62769 IF (ITUNEB.EQ.304) PARP(79)=3D0
62770 IF (ITUNE.EQ.329) PARP(79)=1.18
62771 IF (ITUNE.EQ.335) PARP(79)=1.11
62772 IF (ITUNE.EQ.336) PARP(79)=1.10
62773 IF (ITUNE.EQ.339) PARP(79)=3.69
62774
62775C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
62776 MSTP(91)=1
62777 PARP(91)=2D0
62778 PARP(93)=10D0
62779C...Perugia-HARD only uses 1.0 GeV
62780 IF (ITUNE.EQ.321) PARP(91)=1.0D0
62781C...Perugia-3 only uses 1.5 GeV
62782 IF (ITUNE.EQ.323) PARP(91)=1.5D0
62783C...Professor-pT0 uses 7-GeV cutoff
62784 IF (ITUNE.EQ.329) PARP(93)=7.0
62785 IF (ITUNE.EQ.335) THEN
62786 PARP(91)=2.15
62787 PARP(93)=6.79
62788 ELSEIF (ITUNE.EQ.336) THEN
62789 PARP(91)=1.85
62790 PARP(93)=6.86
62791 ELSEIF (ITUNE.EQ.339) THEN
62792 PARP(91)=2.11
62793 PARP(93)=5.08
62794 ENDIF
62795
62796C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
62797 MSTP(95)=6
62798C...S1, S1-Pro: use S1
62799 IF (ITUNEB.EQ.301) MSTP(95)=2
62800C...S2, S2-Pro: use S2
62801 IF (ITUNEB.EQ.302) MSTP(95)=4
62802C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
62803 IF (ITUNE.EQ.304.OR.ITUNE.EQ.314.OR.ITUNE.EQ.324.OR.
62804 & ITUNE.EQ.334) MSTP(95)=0
62805C..."Old" and "Old"-Pro: use old CR
62806 IF (ITUNEB.EQ.305) MSTP(95)=1
62807C...Perugia 2010 and K use Paquis model
62808 IF (ITUNE.EQ.327.OR.ITUNE.EQ.328) MSTP(95)=8
62809
62810C...FSI: CR strength and high-pT dampening, default is S0
62811 PARP(77)=0D0
62812 IF (ITUNE.LT.320.OR.ITUNE.EQ.329.OR.ITUNE.GE.335) THEN
62813 PARP(78)=0.2D0
62814 IF (ITUNEB.EQ.301) PARP(78)=0.35D0
62815 IF (ITUNEB.EQ.302) PARP(78)=0.15D0
62816 IF (ITUNEB.EQ.304) PARP(78)=0.0D0
62817 IF (ITUNEB.EQ.305) PARP(78)=1.0D0
62818 IF (ITUNE.EQ.329) PARP(78)=0.17D0
62819 IF (ITUNE.EQ.335) PARP(78)=0.14D0
62820 IF (ITUNE.EQ.336) PARP(78)=0.17D0
62821 IF (ITUNE.EQ.339) PARP(78)=0.13D0
62822 ELSE
62823C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
62824 PARP(78)=0.33
62825 PARP(77)=0.9D0
62826 IF (ITUNE.EQ.321) THEN
62827C...HARD has HIGH amount of CR
62828 PARP(78)=0.37D0
62829 PARP(77)=0.4D0
62830 ELSEIF (ITUNE.EQ.322) THEN
62831C...SOFT has LOW amount of CR
62832 PARP(78)=0.15D0
62833 PARP(77)=0.5D0
62834 ELSEIF (ITUNE.EQ.323) THEN
62835C...Scaling variant appears to need slightly more than default
62836 PARP(78)=0.35D0
62837 PARP(77)=0.6D0
62838 ELSEIF (ITUNE.EQ.324.OR.ITUNE.EQ.334) THEN
62839C...NOCR has no CR
62840 PARP(78)=0D0
62841 PARP(77)=0D0
62842 ELSEIF (ITUNE.EQ.327) THEN
62843C...2010
62844 PARP(78)=0.035D0
62845 PARP(77)=1D0
62846 ELSEIF (ITUNE.EQ.328) THEN
62847C...K
62848 PARP(78)=0.033D0
62849 PARP(77)=1D0
62850 ENDIF
62851 ENDIF
62852
62853C================
62854C...Perugia 2011 tunes
62855C...(written as modifications on top of Perugia 2010)
62856C================
62857 IF (ITUNSV.GE.350.AND.ITUNSV.LE.359) THEN
62858 ITUNE = ITUNSV
62859C... Scale setting for matching applications.
62860C... Switch to 5-flavor CMW LambdaQCD = 0.26 for all shower activity
62861C... (equivalent to a 5-flavor MSbar LambdaQCD = 0.26/1.6 = 0.16)
62862 MSTP(64)=2
62863 MSTU(112)=5
62864C... This sets the Lambda scale for ISR, IFSR, and FSR
62865 PARP(61)=0.26D0
62866 PARP(72)=0.26D0
62867 PARJ(81)=0.26D0
62868C... This sets the Lambda scale for QCD hard interactions (important for the
62869C... UE dijet cross sections. Here we still use an MSbar value, rather than
62870C... a CMW one, in order not to hugely increase the UE jettiness. The CTEQ5L
62871C... value corresponds to a Lambda5 of 0.146 for comparison, so quite close.)
62872 PARP(1)=0.16D0
62873 PARU(112)=0.16D0
62874C... For matching applications, PARP(71) and PARP(67) = 1
62875 PARP(67) = 1D0
62876 PARP(71) = 1D0
62877C... Primordial kT: only use 1 GeV
62878 MSTP(91)=1
62879 PARP(91)=1D0
62880C... ADDITIONAL LESSONS WRT PERUGIA 2010
62881C... ALICE taught us: need less baryon transport than SOFT
62882 MSTP(89)=0
62883 PARP(80)=0.015
62884C... Small adjustments at LEP (slightly softer frag functions, esp for baryons)
62885 PARJ(21)=0.33
62886 PARJ(41)=0.35
62887 PARJ(42)=0.8
62888 PARJ(45)=0.55
62889C... Increase Lambda/K ratio and other strange baryon yields
62890 PARJ(1)=0.087D0
62891 PARJ(3)=0.95D0
62892 PARJ(4)=0.043D0
62893 PARJ(6)=1.0D0
62894 PARJ(7)=1.0D0
62895C... Also reduce total strangeness yield a bit, with higher K*/K
62896 PARJ(2)=0.19D0
62897 PARJ(12)=0.40D0
62898C... Perugia 2011 default is sharp ISR, dipoles to BR radiating, pTmax individual
62899 MSTP(70)=0
62900 MSTP(72)=2
62901 PARP(62)=1.5D0
62902C... Holger taught us a smoother proton is preferred at high energies
62903C... Just use a simple Gaussian
62904 MSTP(82)=3
62905C... Scaling of pt0 cutoff
62906 PARP(90)=0.265
62907C... Now retune pT0 to give right UE activity.
62908C... Low CR strength indicated by LHC tunes
62909C... (also keep low to get <pT>(Nch) a bit down for pT>100MeV samples)
62910 PARP(78)=0.036D0
62911C... Choose 7 TeV as new reference scale
62912 PARP(89)=7000.0D0
62913 PARP(82)=2.93D0
62914C================
62915C... P2011 Variations
62916C================
62917 IF (ITUNE.EQ.351) THEN
62918C... radHi: high Lambda scale for ISR, IFSR, and FSR
62919C... ( ca 10% more particles at LEP after retune )
62920 PARP(61)=0.52D0
62921 PARP(72)=0.52D0
62922 PARJ(81)=0.52D0
62923C... Retune cutoff scales to compensate partially
62924C... (though higher cutoff causes faster multiplicity drop at low energies)
62925 PARP(62)=1.75D0
62926 PARJ(82)=1.75D0
62927 PARP(82)=3.00D0
62928C... Needs faster cutoff scaling than nominal variant for same <Nch> scaling
62929C... (since more radiation otherwise generates faster mult growth)
62930 PARP(90)=0.28
62931 ELSEIF (ITUNE.EQ.352) THEN
62932C... radLo: low Lambda scale for ISR, IFSR, and FSR
62933C... ( ca 10% less particles at LEP after retune )
62934 PARP(61)=0.13D0
62935 PARP(72)=0.13D0
62936 PARJ(81)=0.13D0
62937C... Retune cutoff scales to compensate partially
62938 PARP(62)=1.00D0
62939 PARJ(82)=0.75D0
62940 PARP(82)=2.95D0
62941C... Needs slower cutoff scaling than nominal variant for same <Nch> scaling
62942C... (since less radiation otherwise generates slower mult growth)
62943 PARP(90)=0.24
62944 ELSEIF (ITUNE.EQ.353) THEN
62945C... mpiHi: high Lambda scale for MPI
62946 PARP(1)=0.26D0
62947 PARU(112)=0.26D0
62948 PARP(82)=3.35D0
62949 PARP(90)=0.26D0
62950 ELSEIF (ITUNE.EQ.354) THEN
62951 MSTP(95)=0
62952 PARP(82)=3.05D0
62953 ELSEIF (ITUNE.EQ.355) THEN
62954C... LO**
62955 MSTP(52)=2
62956 MSTP(51)=20651
62957 PARP(62)=1.5D0
62958C... Compensate for higher <pT> with less CR
62959 PARP(78)=0.034
62960 PARP(82)=3.40D0
62961C... Need slower energy scaling than CTEQ5L
62962 PARP(90)=0.23D0
62963 ELSEIF (ITUNE.EQ.356) THEN
62964C... CTEQ6L1
62965 MSTP(52)=2
62966 MSTP(51)=10042
62967 PARP(82)=2.65D0
62968C... Need slower cutoff scaling than CTEQ5L
62969 PARP(90)=0.22D0
62970 ELSEIF (ITUNE.EQ.357) THEN
62971C... T16
62972 PARP(90)=0.16
62973 ELSEIF (ITUNE.EQ.358) THEN
62974C... T32
62975 PARP(90)=0.32
62976 ELSEIF (ITUNE.EQ.359) THEN
62977C... Tevatron
62978 PARP(89)=1800D0
62979 PARP(90)=0.28
62980 PARP(82)=2.10
62981 PARP(78)=0.05
62982 ENDIF
62983
62984C================
62985C...Schulz-Skands 2011 tunes
62986C...(written as modifications on top of Perugia 0)
62987C================
62988 ELSEIF (ITUNSV.GE.360.AND.ITUNSV.LE.365) THEN
62989 ITUNE = ITUNSV
62990
62991 IF (ITUNE.EQ.360) THEN
62992 PARP(78)=0.40D0
62993 PARP(82)=2.19D0
62994 PARP(83)=1.45D0
62995 PARP(89)=1800.0D0
62996 PARP(90)=0.27D0
62997 ELSEIF (ITUNE.EQ.361) THEN
62998 PARP(78)=0.20D0
62999 PARP(82)=2.75D0
63000 PARP(83)=1.73D0
63001 PARP(89)=7000.0D0
63002 ELSEIF (ITUNE.EQ.362) THEN
63003 PARP(78)=0.31D0
63004 PARP(82)=1.97D0
63005 PARP(83)=1.98D0
63006 PARP(89)=1960.0D0
63007 ELSEIF (ITUNE.EQ.363) THEN
63008 PARP(78)=0.35D0
63009 PARP(82)=1.91D0
63010 PARP(83)=2.02D0
63011 PARP(89)=1800.0D0
63012 ELSEIF (ITUNE.EQ.364) THEN
63013 PARP(78)=0.33D0
63014 PARP(82)=1.69D0
63015 PARP(83)=1.92D0
63016 PARP(89)=900.0D0
63017 ELSEIF (ITUNE.EQ.365) THEN
63018 PARP(78)=0.47D0
63019 PARP(82)=1.61D0
63020 PARP(83)=1.50D0
63021 PARP(89)=630.0D0
63022 ENDIF
63023
63024 ENDIF
63025
63026C...Switch off trial joinings
63027 MSTP(96)=0
63028
63029C...S0 (300), S0A (303)
63030 IF (ITUNEB.EQ.300.OR.ITUNEB.EQ.303) THEN
63031 IF (M13.GE.1) THEN
63032 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
63033 WRITE(M11,5030) CH60
63034 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
63035 WRITE(M11,5030) CH60
63036 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63037 WRITE(M11,5030) CH60
63038 IF (ITUNE.GE.310) THEN
63039 CH60='LEP parameters tuned by Professor,'//
63040 & ' hep-ph/0907.2973'
63041 WRITE(M11,5030) CH60
63042 ENDIF
63043 ENDIF
63044
63045C...S1 (301)
63046 ELSEIF(ITUNEB.EQ.301) THEN
63047 IF (M13.GE.1) THEN
63048 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
63049 WRITE(M11,5030) CH60
63050 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63051 WRITE(M11,5030) CH60
63052 IF (ITUNE.GE.310) THEN
63053 CH60='LEP parameters tuned by Professor,'//
63054 & ' hep-ph/0907.2973'
63055 WRITE(M11,5030) CH60
63056 ENDIF
63057 ENDIF
63058
63059C...S2 (302)
63060 ELSEIF(ITUNEB.EQ.302) THEN
63061 IF (M13.GE.1) THEN
63062 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
63063 WRITE(M11,5030) CH60
63064 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63065 WRITE(M11,5030) CH60
63066 IF (ITUNE.GE.310) THEN
63067 CH60='LEP parameters tuned by Professor,'//
63068 & ' hep-ph/0907.2973'
63069 WRITE(M11,5030) CH60
63070 ENDIF
63071 ENDIF
63072
63073C...NOCR (304)
63074 ELSEIF(ITUNEB.EQ.304) THEN
63075 IF (M13.GE.1) THEN
63076 CH60='"best try" without colour reconnections'
63077 WRITE(M11,5030) CH60
63078 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
63079 WRITE(M11,5030) CH60
63080 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63081 WRITE(M11,5030) CH60
63082 IF (ITUNE.GE.310) THEN
63083 CH60='LEP parameters tuned by Professor,'//
63084 & ' hep-ph/0907.2973'
63085 WRITE(M11,5030) CH60
63086 ENDIF
63087 ENDIF
63088
63089C..."Lo FSR" retune (305)
63090 ELSEIF(ITUNEB.EQ.305) THEN
63091 IF (M13.GE.1) THEN
63092 CH60='"Lo FSR retune" with primitive colour reconnections'
63093 WRITE(M11,5030) CH60
63094 CH60='see T. Sjostrand & P. Skands, hep-ph/0408302'
63095 WRITE(M11,5030) CH60
63096 IF (ITUNE.GE.310) THEN
63097 CH60='LEP parameters tuned by Professor,'//
63098 & ' hep-ph/0907.2973'
63099 WRITE(M11,5030) CH60
63100 ENDIF
63101 ENDIF
63102
63103C...Perugia Tunes (320-328 and 334)
63104 ELSEIF((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
63105 IF (M13.GE.1) THEN
63106 CH60='Tuned by P. Skands, hep-ph/1005.3457'
63107 WRITE(M11,5030) CH60
63108 CH60='Physics Model: '//
63109 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63110 WRITE(M11,5030) CH60
63111 IF (ITUNE.LE.326) THEN
63112 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
63113 WRITE(M11,5030) CH60
63114 CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
63115 WRITE(M11,5030) CH60
63116 ENDIF
63117 IF (ITUNE.EQ.325) THEN
63118 CH70='NB! This tune requires MRST LO* pdfs to be '//
63119 & 'externally linked'
63120 WRITE(M11,5035) CH70
63121 ELSEIF (ITUNE.EQ.326) THEN
63122 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
63123 & 'externally linked'
63124 WRITE(M11,5035) CH70
63125 ELSEIF (ITUNE.EQ.321) THEN
63126 CH60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
63127 WRITE(M11,5030) CH60
63128 ELSEIF (ITUNE.EQ.322) THEN
63129 CH60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
63130 WRITE(M11,5030) CH60
63131 ENDIF
63132 ENDIF
63133
63134C...Professor-pTO (329)
63135 ELSEIF(ITUNE.EQ.329.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR.
63136 & ITUNE.EQ.339) THEN
63137 IF (M13.GE.1) THEN
63138 CH60='Tuned by Professor, hep-ph/0907.2973'
63139 WRITE(M11,5030) CH60
63140 CH60='Physics Model: '//
63141 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63142 WRITE(M11,5030) CH60
63143 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
63144 WRITE(M11,5030) CH60
63145 ENDIF
63146
63147C...Perugia 2011 Tunes (350-359)
63148 ELSEIF(ITUNE.GE.350.AND.ITUNE.LE.359) THEN
63149 IF (M13.GE.1) THEN
63150 CH60='Tuned by P. Skands, hep-ph/1005.3457'
63151 WRITE(M11,5030) CH60
63152 CH60='Physics Model: '//
63153 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63154 WRITE(M11,5030) CH60
63155 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
63156 WRITE(M11,5030) CH60
63157 IF (ITUNE.EQ.355) THEN
63158 CH70='NB! This tune requires MRST LO** pdfs to be '//
63159 & 'externally linked'
63160 WRITE(M11,5035) CH70
63161 ELSEIF (ITUNE.EQ.356) THEN
63162 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
63163 & 'externally linked'
63164 WRITE(M11,5035) CH70
63165 ENDIF
63166 ENDIF
63167
63168C...Schulz-Skands Tunes (360-365)
63169 ELSEIF(ITUNE.GE.360.AND.ITUNE.LE.365) THEN
63170 IF (M13.GE.1) THEN
63171 CH60='Tuned by H. Schulz & P. Skands, MCNET-11-07'
63172 WRITE(M11,5030) CH60
63173 CH60='Based on Perugia 0, hep-ph/1005.3457'
63174 WRITE(M11,5030) CH60
63175 CH60='Physics Model: '//
63176 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63177 WRITE(M11,5030) CH60
63178 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
63179 WRITE(M11,5030) CH60
63180 ENDIF
63181
63182 ENDIF
63183
63184C...Output
63185 IF (M13.GE.1) THEN
63186 WRITE(M11,5030) ' '
63187 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63188 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63189 IF (MSTP(33).GE.10) THEN
63190 WRITE(M11,5050) 32, PARP(32), CHPARP(32)
63191 ENDIF
63192 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63193 IF (MSTP(3).EQ.1) THEN
63194 WRITE(M11,6100) 112, MSTU(112), CHMSTU(112)
63195 WRITE(M11,6110) 112, PARU(112), CHPARU(112)
63196 WRITE(M11,5050) 1, PARP(1) , CHPARP( 1)
63197 ENDIF
63198 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63199 IF (MSTP(3).EQ.1)
63200 & WRITE(M11,5050) 72, PARP(72) , CHPARP( 72)
63201 IF (MSTP(3).EQ.1) THEN
63202 WRITE(M11,5050) 61, PARP(61) , CHPARP( 61)
63203 ENDIF
63204 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
63205 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63206 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
63207 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63208 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63209 WRITE(M11,5030) CH60
63210 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63211 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
63212 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63213 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
63214 IF (MSTP(70).EQ.0) THEN
63215 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63216 ELSEIF (MSTP(70).EQ.1) THEN
63217 WRITE(M11,5050) 81, PARP(81), CHPARP(62)
63218 CH60='(Note: PARP(81) replaces PARP(62).)'
63219 WRITE(M11,5030) CH60
63220 ENDIF
63221 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
63222 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63223 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63224 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63225 IF (MSTP(70).EQ.2) THEN
63226 CH60='(Note: PARP(82) replaces PARP(62).)'
63227 WRITE(M11,5030) CH60
63228 ENDIF
63229 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63230 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63231 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63232 IF (MSTP(82).EQ.5) THEN
63233 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63234 ELSEIF (MSTP(82).EQ.4) THEN
63235 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63236 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
63237 ENDIF
63238 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
63239 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
63240 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
63241 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
63242 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
63243 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
63244 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63245 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
63246 IF (MSTP(95).GE.1) THEN
63247 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
63248 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
63249 ENDIF
63250
63251 ENDIF
63252
63253C=======================================================================
63254C...ATLAS-CSC 11-parameter tune (By A. Moraes)
63255 ELSEIF (ITUNE.EQ.306) THEN
63256 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
63257 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
63258 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63259 & ' with tune.')
63260 ENDIF
63261
63262C...PDFs
63263 MSTP(52)=2
63264 MSTP(54)=2
63265 MSTP(51)=10042
63266 MSTP(53)=10042
63267C...ISR
63268C PARP(64)=1D0
63269C...UE on, new model.
63270 MSTP(81)=21
63271C...Energy scaling
63272 PARP(89)=1800D0
63273 PARP(90)=0.22D0
63274C...Switch off trial joinings
63275 MSTP(96)=0
63276C...Primordial kT cutoff
63277
63278 IF (M13.GE.1) THEN
63279 CH60='see presentations by A. Moraes (ATLAS),'
63280 WRITE(M11,5030) CH60
63281 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63282 WRITE(M11,5030) CH60
63283 WRITE(M11,5030) ' '
63284 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
63285 & 'externally linked'
63286 WRITE(M11,5035) CH70
63287 ENDIF
63288C...Smooth ISR, low FSR
63289 MSTP(70)=2
63290 MSTP(72)=0
63291C...pT0
63292 PARP(82)=1.9D0
63293C...Transverse density profile.
63294 MSTP(82)=4
63295 PARP(83)=0.3D0
63296 PARP(84)=0.5D0
63297C...ISR & FSR in interactions after the first (default)
63298 MSTP(84)=1
63299 MSTP(85)=1
63300C...No double-counting (default)
63301 MSTP(86)=2
63302C...Companion quark parent gluon (1-x) power
63303 MSTP(87)=4
63304C...Primordial kT compensation along chaings (default = 0 : uniform)
63305 MSTP(90)=1
63306C...Colour Reconnections
63307 MSTP(95)=1
63308 PARP(78)=0.2D0
63309C...Lambda_FSR scale.
63310 PARJ(81)=0.23D0
63311C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
63312 MSTP(89)=1
63313 MSTP(88)=0
63314C PARP(79)=2D0
63315 PARP(80)=0.01D0
63316C...Peterson charm frag, and c and b hadr parameters
63317 MSTJ(11)=3
63318 PARJ(54)=-0.07
63319 PARJ(55)=-0.006
63320C... Output
63321 IF (M13.GE.1) THEN
63322 WRITE(M11,5030) ' '
63323 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63324 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63325 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63326 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63327 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63328 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63329 WRITE(M11,5030) CH60
63330 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
63331 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
63332 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63333 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63334 CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
63335 WRITE(M11,5030) CH60
63336 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63337 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63338 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63339 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63340 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63341 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63342 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63343 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
63344 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
63345 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
63346 WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
63347 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
63348 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
63349 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63350 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
63351 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
63352
63353 ENDIF
63354
63355C=======================================================================
63356C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
63357C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
63358C...A-Pro, DW-Pro, etc (100-119), and Pro-Q2O (129)
63359 ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
63360 & ITUNE.EQ.109.OR.(ITUNE.GE.110.AND.ITUNE.LE.116).OR.
63361 & ITUNE.EQ.118.OR.ITUNE.EQ.119.OR.ITUNE.EQ.129) THEN
63362 IF (M13.GE.1.AND.ITUNE.NE.106.AND.ITUNE.NE.129) THEN
63363 WRITE(M11,5010) ITUNE, CHNAME
63364 CH60='see R.D. Field, in hep-ph/0610012'
63365 WRITE(M11,5030) CH60
63366 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
63367 WRITE(M11,5030) CH60
63368 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
63369 CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
63370 WRITE(M11,5030) CH60
63371 ENDIF
63372 ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN
63373 WRITE(M11,5010) ITUNE, CHNAME
63374 CH60='Tuned by Professor, hep-ph/0907.2973'
63375 WRITE(M11,5030) CH60
63376 CH60='Physics Model: '//
63377 & 'T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
63378 WRITE(M11,5030) CH60
63379 ENDIF
63380
63381C...Make sure we start from old default fragmentation parameters
63382 PARJ(81) = 0.29
63383 PARJ(82) = 1.0
63384
63385C...Use Professor's LEP pars if ITUNE >= 110
63386C...(i.e., for A-Pro, DW-Pro etc)
63387 IF (ITUNE.LT.110) THEN
63388C...# Old defaults
63389 MSTJ(11) = 4
63390 PARJ(1) = 0.1
63391 PARJ(2) = 0.3
63392 PARJ(3) = 0.40
63393 PARJ(4) = 0.05
63394 PARJ(11) = 0.5
63395 PARJ(12) = 0.6
63396 PARJ(21) = 0.36
63397 PARJ(41) = 0.30
63398 PARJ(42) = 0.58
63399 PARJ(46) = 1.0
63400 PARJ(81) = 0.29
63401 PARJ(82) = 1.0
63402 ELSE
63403C...# Tuned flavour parameters:
63404 PARJ(1) = 0.073
63405 PARJ(2) = 0.2
63406 PARJ(3) = 0.94
63407 PARJ(4) = 0.032
63408 PARJ(11) = 0.31
63409 PARJ(12) = 0.4
63410 PARJ(13) = 0.54
63411 PARJ(25) = 0.63
63412 PARJ(26) = 0.12
63413C...# Switch on Bowler:
63414 MSTJ(11) = 5
63415C...# Fragmentation
63416 PARJ(21) = 0.325
63417 PARJ(41) = 0.5
63418 PARJ(42) = 0.6
63419 PARJ(47) = 0.67
63420 PARJ(81) = 0.29
63421 PARJ(82) = 1.65
63422 ENDIF
63423
63424C...Remove middle digit now for Professor variants, since identical pars
63425 ITUNEB=ITUNE
63426 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
63427 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
63428 ENDIF
63429
63430C...Multiple interactions on, old framework
63431 MSTP(81)=1
63432C...Fast IR cutoff energy scaling by default
63433 PARP(89)=1800D0
63434 PARP(90)=0.25D0
63435C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
63436 MSTP(51)=7
63437 MSTP(52)=1
63438 IF (ITUNEB.EQ.105) THEN
63439 MSTP(51)=10150
63440 MSTP(52)=2
63441 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
63442 MSTP(52)=2
63443 MSTP(54)=2
63444 MSTP(51)=10042
63445 MSTP(53)=10042
63446 ENDIF
63447C...Double Gaussian matter distribution.
63448 MSTP(82)=4
63449 PARP(83)=0.5D0
63450 PARP(84)=0.4D0
63451C...FSR activity.
63452 PARP(71)=4D0
63453C...Fragmentation functions and c and b parameters
63454C...(only if not using Professor)
63455 IF (ITUNE.LE.109) THEN
63456 MSTJ(11)=4
63457 PARJ(54)=-0.05
63458 PARJ(55)=-0.005
63459 ENDIF
63460
63461C...Tune A and AW
63462 IF(ITUNEB.EQ.100.OR.ITUNEB.EQ.101) THEN
63463C...pT0.
63464 PARP(82)=2.0D0
63465c...String drawing almost completely minimizes string length.
63466 PARP(85)=0.9D0
63467 PARP(86)=0.95D0
63468C...ISR cutoff, muR scale factor, and phase space size
63469 PARP(62)=1D0
63470 PARP(64)=1D0
63471 PARP(67)=4D0
63472C...Intrinsic kT, size, and max
63473 MSTP(91)=1
63474 PARP(91)=1D0
63475 PARP(93)=5D0
63476C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
63477 IF (ITUNEB.EQ.101) THEN
63478 PARP(62)=1.25D0
63479 PARP(64)=0.2D0
63480 PARP(91)=2.1D0
63481 PARP(92)=15.0D0
63482 ENDIF
63483
63484C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
63485 ELSEIF (ITUNEB.EQ.102) THEN
63486C...pT0.
63487 PARP(82)=1.9D0
63488c...String drawing completely minimizes string length.
63489 PARP(85)=1.0D0
63490 PARP(86)=1.0D0
63491C...ISR cutoff, muR scale factor, and phase space size
63492 PARP(62)=1.25D0
63493 PARP(64)=0.2D0
63494 PARP(67)=1D0
63495C...Intrinsic kT, size, and max
63496 MSTP(91)=1
63497 PARP(91)=2.1D0
63498 PARP(93)=15D0
63499
63500C...Tune DW
63501 ELSEIF (ITUNEB.EQ.103) THEN
63502C...pT0.
63503 PARP(82)=1.9D0
63504c...String drawing completely minimizes string length.
63505 PARP(85)=1.0D0
63506 PARP(86)=1.0D0
63507C...ISR cutoff, muR scale factor, and phase space size
63508 PARP(62)=1.25D0
63509 PARP(64)=0.2D0
63510 PARP(67)=2.5D0
63511C...Intrinsic kT, size, and max
63512 MSTP(91)=1
63513 PARP(91)=2.1D0
63514 PARP(93)=15D0
63515
63516C...Tune DWT
63517 ELSEIF (ITUNEB.EQ.104) THEN
63518C...pT0.
63519 PARP(82)=1.9409D0
63520C...Run II ref scale and slow scaling
63521 PARP(89)=1960D0
63522 PARP(90)=0.16D0
63523c...String drawing completely minimizes string length.
63524 PARP(85)=1.0D0
63525 PARP(86)=1.0D0
63526C...ISR cutoff, muR scale factor, and phase space size
63527 PARP(62)=1.25D0
63528 PARP(64)=0.2D0
63529 PARP(67)=2.5D0
63530C...Intrinsic kT, size, and max
63531 MSTP(91)=1
63532 PARP(91)=2.1D0
63533 PARP(93)=15D0
63534
63535C...Tune QW
63536 ELSEIF(ITUNEB.EQ.105) THEN
63537 IF (M13.GE.1) THEN
63538 WRITE(M11,5030) ' '
63539 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
63540 & 'externally linked'
63541 WRITE(M11,5035) CH70
63542 ENDIF
63543C...pT0.
63544 PARP(82)=1.1D0
63545c...String drawing completely minimizes string length.
63546 PARP(85)=1.0D0
63547 PARP(86)=1.0D0
63548C...ISR cutoff, muR scale factor, and phase space size
63549 PARP(62)=1.25D0
63550 PARP(64)=0.2D0
63551 PARP(67)=2.5D0
63552C...Intrinsic kT, size, and max
63553 MSTP(91)=1
63554 PARP(91)=2.1D0
63555 PARP(93)=15D0
63556
63557C...Tune D6 and D6T
63558 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
63559 IF (M13.GE.1) THEN
63560 WRITE(M11,5030) ' '
63561 CH70='NB! This tune requires CTEQ6L pdfs to be '//
63562 & 'externally linked'
63563 WRITE(M11,5035) CH70
63564 ENDIF
63565C...The "Rick" proton, double gauss with 0.5/0.4
63566 MSTP(82)=4
63567 PARP(83)=0.5D0
63568 PARP(84)=0.4D0
63569c...String drawing completely minimizes string length.
63570 PARP(85)=1.0D0
63571 PARP(86)=1.0D0
63572 IF (ITUNEB.EQ.108) THEN
63573C...D6: pT0, Run I ref scale, and fast energy scaling
63574 PARP(82)=1.8D0
63575 PARP(89)=1800D0
63576 PARP(90)=0.25D0
63577 ELSE
63578C...D6T: pT0, Run II ref scale, and slow energy scaling
63579 PARP(82)=1.8387D0
63580 PARP(89)=1960D0
63581 PARP(90)=0.16D0
63582 ENDIF
63583C...ISR cutoff, muR scale factor, and phase space size
63584 PARP(62)=1.25D0
63585 PARP(64)=0.2D0
63586 PARP(67)=2.5D0
63587C...Intrinsic kT, size, and max
63588 MSTP(91)=1
63589 PARP(91)=2.1D0
63590 PARP(93)=15D0
63591
63592C...Old ATLAS-DC2 5-parameter tune
63593 ELSEIF(ITUNEB.EQ.106) THEN
63594 IF (M13.GE.1) THEN
63595 WRITE(M11,5010) ITUNE, CHNAME
63596 CH60='see A. Moraes et al., SN-ATLAS-2006-057,'
63597 WRITE(M11,5030) CH60
63598 CH60=' R. Field in hep-ph/0610012,'
63599 WRITE(M11,5030) CH60
63600 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
63601 WRITE(M11,5030) CH60
63602 ENDIF
63603C... pT0.
63604 PARP(82)=1.8D0
63605C... Different ref and rescaling pacee
63606 PARP(89)=1000D0
63607 PARP(90)=0.16D0
63608C... Parameters of mass distribution
63609 PARP(83)=0.5D0
63610 PARP(84)=0.5D0
63611C... Old default string drawing
63612 PARP(85)=0.33D0
63613 PARP(86)=0.66D0
63614C... ISR, phase space equivalent to Tune B
63615 PARP(62)=1D0
63616 PARP(64)=1D0
63617 PARP(67)=1D0
63618C... FSR
63619 PARP(71)=4D0
63620C... Intrinsic kT
63621 MSTP(91)=1
63622 PARP(91)=1D0
63623 PARP(93)=5D0
63624
63625C...Professor's Pro-Q2O Tune
63626 ELSEIF(ITUNE.EQ.129) THEN
63627 PARP(62)=2.9
63628 PARP(64)=0.14
63629 PARP(67)=2.65
63630 PARP(82)=1.9
63631 PARP(83)=0.83
63632 PARP(84)=0.6
63633 PARP(85)=0.86
63634 PARP(86)=0.93
63635 PARP(89)=1800D0
63636 PARP(90)=0.22
63637 MSTP(91)=1
63638 PARP(91)=2.1
63639 PARP(93)=5.0
63640
63641 ENDIF
63642
63643C... Output
63644 IF (M13.GE.1) THEN
63645 WRITE(M11,5030) ' '
63646 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63647 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63648 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63649 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63650 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63651 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63652 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63653 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63654 WRITE(M11,5030) CH60
63655 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63656 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63657 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
63658 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63659 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63660 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63661 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63662 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63663 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63664 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63665 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
63666 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
63667 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
63668 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
63669 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
63670 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63671
63672 ENDIF
63673
63674C=======================================================================
63675C... ACR, tune A with new CR (107)
63676 ELSEIF(ITUNE.EQ.107.OR.ITUNE.EQ.117) THEN
63677 IF (M13.GE.1) THEN
63678 WRITE(M11,5010) ITUNE, CHNAME
63679 CH60='Tune A modified with new colour reconnections'
63680 WRITE(M11,5030) CH60
63681 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
63682 WRITE(M11,5030) CH60
63683 CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
63684 WRITE(M11,5030) CH60
63685 CH60=' R. Field, in hep-ph/0610012 (Tune A),'
63686 WRITE(M11,5030) CH60
63687 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
63688 WRITE(M11,5030) CH60
63689 IF (ITUNE.EQ.117) THEN
63690 CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
63691 WRITE(M11,5030) CH60
63692 ENDIF
63693 ENDIF
63694 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
63695 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63696 & ' with tune. Using defaults.')
63697 GOTO 100
63698 ENDIF
63699
63700C...Make sure we start from old default fragmentation parameters
63701 PARJ(81) = 0.29
63702 PARJ(82) = 1.0
63703
63704C...Use Professor's LEP pars if ITUNE >= 110
63705C...(i.e., for A-Pro, DW-Pro etc)
63706 IF (ITUNE.LT.110) THEN
63707C...# Old defaults
63708 MSTJ(11) = 4
63709C...# Old default flavour parameters
63710 PARJ(21) = 0.36
63711 PARJ(41) = 0.30
63712 PARJ(42) = 0.58
63713 PARJ(46) = 1.0
63714 PARJ(82) = 1.0
63715 ELSE
63716C...# Tuned flavour parameters:
63717 PARJ(1) = 0.073
63718 PARJ(2) = 0.2
63719 PARJ(3) = 0.94
63720 PARJ(4) = 0.032
63721 PARJ(11) = 0.31
63722 PARJ(12) = 0.4
63723 PARJ(13) = 0.54
63724 PARJ(25) = 0.63
63725 PARJ(26) = 0.12
63726C...# Switch on Bowler:
63727 MSTJ(11) = 5
63728C...# Fragmentation
63729 PARJ(21) = 0.325
63730 PARJ(41) = 0.5
63731 PARJ(42) = 0.6
63732 PARJ(47) = 0.67
63733 PARJ(81) = 0.29
63734 PARJ(82) = 1.65
63735 ENDIF
63736
63737 MSTP(81)=1
63738 PARP(89)=1800D0
63739 PARP(90)=0.25D0
63740 MSTP(82)=4
63741 PARP(83)=0.5D0
63742 PARP(84)=0.4D0
63743 MSTP(51)=7
63744 MSTP(52)=1
63745 PARP(71)=4D0
63746 PARP(82)=2.0D0
63747 PARP(85)=0.0D0
63748 PARP(86)=0.66D0
63749 PARP(62)=1D0
63750 PARP(64)=1D0
63751 PARP(67)=4D0
63752 MSTP(91)=1
63753 PARP(91)=1D0
63754 PARP(93)=5D0
63755 MSTP(95)=6
63756C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
63757 PARP(78)=0.09D0
63758C...Frag functions (only if not using Professor)
63759 IF (ITUNE.LE.109) THEN
63760 MSTJ(11)=4
63761 PARJ(54)=-0.05
63762 PARJ(55)=-0.005
63763 ENDIF
63764
63765C...Output
63766 IF (M13.GE.1) THEN
63767 WRITE(M11,5030) ' '
63768 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63769 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63770 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63771 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63772 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63773 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63774 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63775 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63776 WRITE(M11,5030) CH60
63777 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63778 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63779 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
63780 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63781 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63782 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63783 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63784 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63785 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63786 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63787 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
63788 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
63789 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
63790 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
63791 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
63792 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63793 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
63794 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
63795
63796 ENDIF
63797
63798C=======================================================================
63799C...Intermediate model. Rap tune
63800C...(retuned to post-6.406 IR factorization)
63801 ELSEIF(ITUNE.EQ.200) THEN
63802 IF (M13.GE.1) THEN
63803 WRITE(M11,5010) ITUNE, CHNAME
63804 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
63805 WRITE(M11,5030) CH60
63806 ENDIF
63807 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
63808 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63809 & ' with tune.')
63810 ENDIF
63811C...PDF
63812 MSTP(51)=7
63813 MSTP(52)=1
63814C...ISR
63815 PARP(62)=1D0
63816 PARP(64)=1D0
63817 PARP(67)=4D0
63818C...FSR
63819 PARP(71)=4D0
63820 PARJ(81)=0.29D0
63821C...UE
63822 MSTP(81)=11
63823 PARP(82)=2.25D0
63824 PARP(89)=1800D0
63825 PARP(90)=0.25D0
63826C... ExpOfPow(1.8) overlap profile
63827 MSTP(82)=5
63828 PARP(83)=1.8D0
63829C... Valence qq
63830 MSTP(88)=0
63831C... Rap Tune
63832 MSTP(89)=1
63833C... Default diquark, BR-g-BR supp
63834 PARP(79)=2D0
63835 PARP(80)=0.01D0
63836C... Final state reconnect.
63837 MSTP(95)=1
63838 PARP(78)=0.55D0
63839C...Fragmentation functions and c and b parameters
63840 MSTJ(11)=4
63841 PARJ(54)=-0.05
63842 PARJ(55)=-0.005
63843C... Output
63844 IF (M13.GE.1) THEN
63845 WRITE(M11,5030) ' '
63846 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63847 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63848 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63849 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63850 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63851 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63852 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63853 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63854 WRITE(M11,5030) CH60
63855 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63856 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63857 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63858 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63859 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63860 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63861 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63862 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63863 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63864 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
63865 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
63866 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
63867 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
63868 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63869 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
63870 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
63871
63872 ENDIF
63873
63874C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
63875C...Old model for ISR and UE, new pT-ordered model for FSR
63876 ELSEIF(ITUNE.EQ.201.OR.ITUNE.EQ.211.OR.ITUNE.EQ.221.OR
63877 & .ITUNE.EQ.226) THEN
63878 IF (M13.GE.1) THEN
63879 WRITE(M11,5010) ITUNE, CHNAME
63880 CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
63881 WRITE(M11,5030) CH60
63882 CH60=' R.D. Field, in hep-ph/0610012 (Tune A)'
63883 WRITE(M11,5030) CH60
63884 CH60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
63885 WRITE(M11,5030) CH60
63886 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63887 WRITE(M11,5030) CH60
63888 IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN
63889 CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
63890 WRITE(M11,5030) CH60
63891 ENDIF
63892 ENDIF
63893 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
63894 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63895 & ' with tune.')
63896 ENDIF
63897C...First set as if Pythia tune A
63898C...Multiple interactions on, old framework
63899 MSTP(81)=1
63900C...Fast IR cutoff energy scaling by default
63901 PARP(89)=1800D0
63902 PARP(90)=0.25D0
63903C...Default CTEQ5L (internal)
63904 MSTP(51)=7
63905 MSTP(52)=1
63906C...Double Gaussian matter distribution.
63907 MSTP(82)=4
63908 PARP(83)=0.5D0
63909 PARP(84)=0.4D0
63910C...FSR activity.
63911 PARP(71)=4D0
63912c...String drawing almost completely minimizes string length.
63913 PARP(85)=0.9D0
63914 PARP(86)=0.95D0
63915C...ISR cutoff, muR scale factor, and phase space size
63916 PARP(62)=1D0
63917 PARP(64)=1D0
63918 PARP(67)=4D0
63919C...Intrinsic kT, size, and max
63920 MSTP(91)=1
63921 PARP(91)=1D0
63922 PARP(93)=5D0
63923C...Use 2 GeV of primordial kT for "Perugia" version
63924 IF (ITUNE.EQ.221) THEN
63925 PARP(91)=2D0
63926 PARP(93)=10D0
63927 ENDIF
63928C...Use pT-ordered FSR
63929 MSTJ(41)=12
63930C...Lambda_FSR scale for pT-ordering
63931 PARJ(81)=0.23D0
63932C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
63933 PARP(82)=2.05D0
63934C...Fragmentation functions and c and b parameters
63935C...(overwritten for 211, i.e., if using Professor pars)
63936 PARJ(54)=-0.05
63937 PARJ(55)=-0.005
63938
63939C...Use Professor's LEP pars if ITUNE == 211, 221, 226
63940 IF (ITUNE.LT.210) THEN
63941C...# Old defaults
63942 MSTJ(11) = 4
63943C...# Old default flavour parameters
63944 PARJ(21) = 0.36
63945 PARJ(41) = 0.30
63946 PARJ(42) = 0.58
63947 PARJ(46) = 1.0
63948 PARJ(82) = 1.0
63949 ELSE
63950C...# Tuned flavour parameters:
63951 PARJ(1) = 0.073
63952 PARJ(2) = 0.2
63953 PARJ(3) = 0.94
63954 PARJ(4) = 0.032
63955 PARJ(11) = 0.31
63956 PARJ(12) = 0.4
63957 PARJ(13) = 0.54
63958 PARJ(25) = 0.63
63959 PARJ(26) = 0.12
63960C...# Always use pT-ordered shower:
63961 MSTJ(41) = 12
63962C...# Switch on Bowler:
63963 MSTJ(11) = 5
63964C...# Fragmentation
63965 PARJ(21) = 3.1327e-01
63966 PARJ(41) = 4.8989e-01
63967 PARJ(42) = 1.2018e+00
63968 PARJ(47) = 1.0000e+00
63969 PARJ(81) = 2.5696e-01
63970 PARJ(82) = 8.0000e-01
63971 ENDIF
63972
63973C...221, 226 : Perugia-APT and Perugia-APT6
63974 IF (ITUNE.EQ.221.OR.ITUNE.EQ.226) THEN
63975
63976 PARP(64)=0.5D0
63977 PARP(82)=2.05D0
63978 PARP(90)=0.26D0
63979 PARP(91)=2.0D0
63980C...The Perugia variants use Steve's showers off the old MPI
63981 MSTP(152)=1
63982C...And use a lower PARP(71) as suggested by Professor tunings
63983C...(although not certain that applies to Q2-pT2 hybrid)
63984 PARP(71)=2.5D0
63985
63986C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
63987 IF (ITUNE.EQ.226) THEN
63988 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
63989 & 'externally linked'
63990 WRITE(M11,5035) CH70
63991 MSTP(52)=2
63992 MSTP(51)=10042
63993 PARP(82)=1.95D0
63994 ENDIF
63995
63996 ENDIF
63997
63998C... Output
63999 IF (M13.GE.1) THEN
64000 WRITE(M11,5030) ' '
64001 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
64002 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
64003 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
64004 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
64005 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
64006 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
64007 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
64008 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
64009 WRITE(M11,5030) CH60
64010 WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
64011 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
64012 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
64013 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
64014 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64015 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64016 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
64017 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
64018 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64019 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64020 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
64021 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
64022 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
64023 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
64024 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
64025 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
64026
64027 ENDIF
64028
64029C======================================================================
64030C...Uppsala models: Generalized Area Law and Soft Colour Interactions
64031 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
64032 IF (M13.GE.1) THEN
64033 WRITE(M11,5010) ITUNE, CHNAME
64034 CH60='see J. Rathsman, PLB452(1999)364'
64035 WRITE(M11,5030) CH60
64036C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
64037C ? WRITE(M11,5030)
64038 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64039 WRITE(M11,5030) CH60
64040 WRITE(M11,5030) ' '
64041 CH70='NB! The GAL model must be run with modified '//
64042 & 'Pythia v6.215:'
64043 WRITE(M11,5035) CH70
64044 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
64045 WRITE(M11,5035) CH70
64046 WRITE(M11,5030) ' '
64047 ENDIF
64048C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
64049 MSWI(2) = 3
64050 PARSCI(2) = 0.10
64051 MSWI(1) = 2
64052 PARSCI(1) = 0.44
64053 MSTJ(16) = 0
64054 PARJ(42) = 0.45
64055 PARJ(82) = 2.0
64056 PARP(62) = 2.0
64057 MSTP(81) = 1
64058 MSTP(82) = 1
64059 PARP(81) = 1.9
64060 MSTP(92) = 1
64061 IF(CHNAME.EQ.'GAL Tune 1') THEN
64062C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
64063 MSTP(82)=4
64064 PARP(83)=0.25D0
64065 PARP(84)=0.5D0
64066 PARP(82) = 1.75
64067 IF (M13.GE.1) THEN
64068 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64069 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64070 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64071 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64072 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
64073 ENDIF
64074 ELSE
64075 IF (M13.GE.1) THEN
64076 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64077 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
64078 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64079 ENDIF
64080 ENDIF
64081C...Output
64082 IF (M13.GE.1) THEN
64083 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
64084 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
64085 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
64086 CH40='FSI SCI/GAL selection'
64087 WRITE(M11,6040) 1, MSWI(1), CH40
64088 CH40='FSI SCI/GAL sea quark treatment'
64089 WRITE(M11,6040) 2, MSWI(2), CH40
64090 CH40='FSI SCI/GAL sea quark treatment parm'
64091 WRITE(M11,6050) 1, PARSCI(1), CH40
64092 CH40='FSI SCI/GAL string reco probability R_0'
64093 WRITE(M11,6050) 2, PARSCI(2), CH40
64094 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
64095 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
64096 ENDIF
64097 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
64098 IF (M13.GE.1) THEN
64099 WRITE(M11,5010) ITUNE, CHNAME
64100 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
64101 WRITE(M11,5030) CH60
64102 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64103 WRITE(M11,5030) CH60
64104 WRITE(M11,5030) ' '
64105 CH70='NB! The SCI model must be run with modified '//
64106 & 'Pythia v6.215:'
64107 WRITE(M11,5035) CH70
64108 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
64109 WRITE(M11,5035) CH70
64110 WRITE(M11,5030) ' '
64111 ENDIF
64112C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
64113 MSTP(81)=1
64114 MSTP(82)=1
64115 PARP(81)=2.2
64116 MSTP(92)=1
64117 MSWI(2)=2
64118 PARSCI(2)=0.50
64119 MSWI(1)=2
64120 PARSCI(1)=0.44
64121 MSTJ(16)=0
64122 IF (CHNAME.EQ.'SCI Tune 1') THEN
64123C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
64124 MSTP(81) = 1
64125 MSTP(82) = 3
64126 PARP(82) = 2.4
64127 PARP(83) = 0.5D0
64128 PARP(62) = 1.5
64129 PARP(84)=0.25D0
64130 IF (M13.GE.1) THEN
64131 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64132 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64133 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64134 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64135 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
64136 ENDIF
64137 ELSE
64138 IF (M13.GE.1) THEN
64139 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64140 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
64141 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64142 ENDIF
64143 ENDIF
64144C...Output
64145 IF (M13.GE.1) THEN
64146 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
64147 CH40='FSI SCI/GAL selection'
64148 WRITE(M11,6040) 1, MSWI(1), CH40
64149 CH40='FSI SCI/GAL sea quark treatment'
64150 WRITE(M11,6040) 2, MSWI(2), CH40
64151 CH40='FSI SCI/GAL sea quark treatment parm'
64152 WRITE(M11,6050) 1, PARSCI(1), CH40
64153 CH40='FSI SCI/GAL string reco probability R_0'
64154 WRITE(M11,6050) 2, PARSCI(2), CH40
64155 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
64156 ENDIF
64157
64158 ELSE
64159 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
64160
64161 ENDIF
64162
64163C...Output of LEP parameters, common to all models
64164 IF (M13.GE.1) THEN
64165 WRITE(M11,5080)
64166 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
64167 IF (MSTJ(11).EQ.3) THEN
64168 CH60='Warning: using Peterson fragmentation function'
64169 WRITE(M11,5030) CH60
64170 ENDIF
64171
64172 WRITE(M11,5060) 1, PARJ( 1), CHPARJ( 1)
64173 WRITE(M11,5060) 2, PARJ( 2), CHPARJ( 2)
64174 WRITE(M11,5060) 3, PARJ( 3), CHPARJ( 3)
64175 WRITE(M11,5060) 4, PARJ( 4), CHPARJ( 4)
64176 WRITE(M11,5060) 5, PARJ( 5), CHPARJ( 5)
64177 WRITE(M11,5060) 6, PARJ( 6), CHPARJ( 6)
64178 WRITE(M11,5060) 7, PARJ( 7), CHPARJ( 7)
64179
64180 WRITE(M11,5060) 11, PARJ(11), CHPARJ(11)
64181 WRITE(M11,5060) 12, PARJ(12), CHPARJ(12)
64182 WRITE(M11,5060) 13, PARJ(13), CHPARJ(13)
64183
64184 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
64185
64186 WRITE(M11,5060) 25, PARJ(25), CHPARJ(25)
64187 WRITE(M11,5060) 26, PARJ(26), CHPARJ(26)
64188
64189 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
64190 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
64191 WRITE(M11,5060) 45, PARJ(45), CHPARJ(45)
64192
64193 IF (MSTJ(11).LE.3) THEN
64194 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
64195 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
64196 ELSE
64197 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
64198 ENDIF
64199 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
64200 ENDIF
64201
64202 100 IF (MSTU(13).GE.1) WRITE(M11,6000)
64203
64204 9999 RETURN
64205
64206 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE : ',
64207 & 'Presets for underlying-event (and min-bias)',21x,'*'/' *',
64208 & 12x,'Last Change : ',A8,' - P. Skands',30x,'*'/' *',76x,'*')
64209 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
64210 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
64211 5030 FORMAT(' *',3x,10x,A60,3x,'*')
64212 5035 FORMAT(' *',3x,A70,3x,'*')
64213 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
64214 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
64215 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
64216 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
64217 5080 FORMAT(' *',3x,'----------------------------',42('-'),3x,'*')
64218 6100 FORMAT(' *',5x,'MSTU(',I3,')= ',I12,3x,A42,3x,'*')
64219 6110 FORMAT(' *',5x,'PARU(',I3,')= ',F12.4,3x,A42,3x,'*')
64220C 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
64221C 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
64222 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
64223 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
64224 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
64225
64226 END
64227
64228C*********************************************************************
64229
64230C...PYEXEC
64231C...Administrates the fragmentation and decay chain.
64232
64233 SUBROUTINE PYEXEC
64234
64235C...Double precision and integer declarations.
64236 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64237 IMPLICIT INTEGER(I-N)
64238 INTEGER PYK,PYCHGE,PYCOMP
64239C...Commonblocks.
64240 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64241 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64242 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64243 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
64244 COMMON/PYINT1/MINT(400),VINT(400)
64245 COMMON/PYINT4/MWID(500),WIDS(500,5)
64246 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
64247C...Local array.
64248 DIMENSION PS(2,6),IJOIN(100)
64249
64250C...Initialize and reset.
64251 MSTU(24)=0
64252 IF(MSTU(12).NE.12345) CALL PYLIST(0)
64253 MSTU(29)=0
64254 MSTU(31)=MSTU(31)+1
64255 MSTU(1)=0
64256 MSTU(2)=0
64257 MSTU(3)=0
64258 IF(MSTU(17).LE.0) MSTU(90)=0
64259 MCONS=1
64260
64261C...Sum up momentum, energy and charge for starting entries.
64262 NSAV=N
64263 DO 110 I=1,2
64264 DO 100 J=1,6
64265 PS(I,J)=0D0
64266 100 CONTINUE
64267 110 CONTINUE
64268 DO 130 I=1,N
64269 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
64270 DO 120 J=1,4
64271 PS(1,J)=PS(1,J)+P(I,J)
64272 120 CONTINUE
64273 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
64274 130 CONTINUE
64275 PARU(21)=PS(1,4)
64276
64277C...Start by all decays of coloured resonances involved in shower.
64278 NORIG=N
64279 DO 140 I=1,NORIG
64280 IF(K(I,1).EQ.3) THEN
64281 KC=PYCOMP(K(I,2))
64282 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
64283 ENDIF
64284 140 CONTINUE
64285
64286C...Prepare system for subsequent fragmentation/decay.
64287 CALL PYPREP(0)
64288 IF(MINT(51).NE.0) RETURN
64289
64290C...Loop through jet fragmentation and particle decays.
64291 MBE=0
64292 150 MBE=MBE+1
64293 IP=0
64294 160 IP=IP+1
64295 KC=0
64296 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
64297 IF(KC.EQ.0) THEN
64298
64299C...Deal with any remaining undecayed resonance
64300C...(normally the task of PYEVNT, so seldom used).
64301 ELSEIF(MWID(KC).NE.0) THEN
64302 IBEG=IP
64303 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
64304 IBEG=IP+1
64305 170 IBEG=IBEG-1
64306 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
64307 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
64308 IEND=IP-1
64309 180 IEND=IEND+1
64310 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
64311 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
64312 NJOIN=0
64313 DO 190 I=IBEG,IEND
64314 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
64315 NJOIN=NJOIN+1
64316 IJOIN(NJOIN)=I
64317 ENDIF
64318 190 CONTINUE
64319 ENDIF
64320 CALL PYRESD(IP)
64321 CALL PYPREP(IBEG)
64322 IF(MINT(51).NE.0) RETURN
64323
64324C...Particle decay if unstable and allowed. Save long-lived particle
64325C...decays until second pass after Bose-Einstein effects.
64326 ELSEIF(KCHG(KC,2).EQ.0) THEN
64327 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
64328 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
64329 & CALL PYDECY(IP)
64330
64331C...Decay products may develop a shower.
64332 IF(MSTJ(92).GT.0) THEN
64333 IP1=MSTJ(92)
64334 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
64335 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
64336 MINT(33)=0
64337 CALL PYSHOW(IP1,IP1+1,QMAX)
64338 CALL PYPREP(IP1)
64339 IF(MINT(51).NE.0) RETURN
64340 MSTJ(92)=0
64341 ELSEIF(MSTJ(92).LT.0) THEN
64342 IP1=-MSTJ(92)
64343 MINT(33)=0
64344 CALL PYSHOW(IP1,-3,P(IP,5))
64345 CALL PYPREP(IP1)
64346 IF(MINT(51).NE.0) RETURN
64347 MSTJ(92)=0
64348 ENDIF
64349
64350C...Jet fragmentation: string or independent fragmentation.
64351 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
64352 MFRAG=MSTJ(1)
64353 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
64354 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
64355 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
64356 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
64357 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
64358 ENDIF
64359 ENDIF
64360 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
64361 IF(MFRAG.EQ.2) CALL PYINDF(IP)
64362 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
64363 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
64364 ENDIF
64365
64366C...Loop back if enough space left in PYJETS and no error abort.
64367 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
64368 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
64369 GOTO 160
64370 ELSEIF(IP.LT.N) THEN
64371 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
64372 ENDIF
64373
64374C...Include simple Bose-Einstein effect parametrization if desired.
64375 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
64376 CALL PYBOEI(NSAV)
64377 GOTO 150
64378 ENDIF
64379
64380C...Check that momentum, energy and charge were conserved.
64381 DO 210 I=1,N
64382 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
64383 DO 200 J=1,4
64384 PS(2,J)=PS(2,J)+P(I,J)
64385 200 CONTINUE
64386 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
64387 210 CONTINUE
64388 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
64389 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
64390 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
64391 &'(PYEXEC:) four-momentum was not conserved')
64392 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
64393 &'(PYEXEC:) charge was not conserved')
64394
64395 RETURN
64396 END
64397
64398C*********************************************************************
64399
64400C...PYPREP
64401C...Rearranges partons along strings.
64402C...Special considerations for systems with junctions, with
64403C...possibility of junction-antijunction annihilation.
64404C...Allows small systems to collapse into one or two particles.
64405C...Checks flavours and colour singlet invariant masses.
64406
64407 SUBROUTINE PYPREP(IP)
64408
64409C...Double precision and integer declarations.
64410 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64411 INTEGER PYK,PYCHGE,PYCOMP
64412C...Commonblocks.
64413 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64414 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64415 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
64416 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64417 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
64418 COMMON/PYINT1/MINT(400),VINT(400)
64419C...The common block of colour tags.
64420 COMMON/PYCTAG/NCT,MCT(4000,2)
64421 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
64422 &/PYPARS/
64423 DATA NERRPR/0/
64424 SAVE NERRPR
64425C...Local arrays.
64426 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
64427 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
64428 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
64429 &IJCP(0:6),TJUOLD(5)
64430 CHARACTER CHTMP*6
64431
64432C...Function to give four-product.
64433 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)
64434
64435C...Rearrange parton shower product listing along strings: begin loop.
64436 MSTU(24)=0
64437 NOLD=N
64438 I1=N
64439 NJUNC=0
64440 NPIECE=0
64441 NJJSTR=0
64442 MSTU32=MSTU(32)+1
64443 DO 100 I=MAX(1,IP),N
64444C...First store junction positions.
64445 IF(K(I,1).EQ.42) THEN
64446 NJUNC=NJUNC+1
64447 IJUNC(NJUNC,0)=I
64448 IJUNC(NJUNC,4)=0
64449 ENDIF
64450 100 CONTINUE
64451
64452 DO 250 MQGST=1,3
64453 DO 240 I=MAX(1,IP),N
64454C...Special treatment for junctions
64455 IF (K(I,1).LE.0) GOTO 240
64456 IF(K(I,1).EQ.42) THEN
64457C...MQGST=2: Look for junction-junction strings (not detected in the
64458C...main search below).
64459 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
64460 IF (NJJSTR.EQ.0) THEN
64461 NJJSTR = (3*NJUNC-NPIECE)/2
64462 ENDIF
64463C...Check how many already identified strings end on this junction
64464 ILC=0
64465 DO 110 J=1,NPIECE
64466 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
64467 110 CONTINUE
64468C...If less than 3, remaining must be to another junction
64469 IF (ILC.LT.3) THEN
64470 IF (ILC.NE.2) THEN
64471C...Multiple j-j connections not handled yet.
64472 CALL PYERRM(2,
64473 & '(PYPREP:) Too many junction-junction strings.')
64474 MINT(51)=1
64475 RETURN
64476 ENDIF
64477C...The colour information in the junction is unreadable for the
64478C...colour space search further down in this routine, so we must
64479C...start on the colour mother of this junction and then "artificially"
64480C...prevent the colour mother from connecting here again.
64481 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
64482 KCS=4
64483 IF (MOD(ITJUNC,2).EQ.0) KCS=5
64484C...Switch colour if the junction-junction leg is presumably a
64485C...junction mother leg rather than a junction daughter leg.
64486 IF (ITJUNC.GE.3) KCS=9-KCS
64487 IF (MINT(33).EQ.0) THEN
64488C...Find the unconnected leg and reorder junction daughter pointers so
64489C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
64490C...piece.
64491 IA=MOD(K(I,4),MSTU(5))
64492 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
64493 ITMP=MOD(K(I,5),MSTU(5))
64494 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
64495 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
64496 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
64497 ELSE
64498 K(I,5)=K(I,5)+(IA-ITMP)
64499 ENDIF
64500 K(I,4)=K(I,4)+(ITMP-IA)
64501 IA=ITMP
64502 ENDIF
64503 IF (ITJUNC.LE.2) THEN
64504C...Beam baryon junction
64505 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
64506 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
64507C...Else 1 -> 2 decay junction
64508 ELSE
64509 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
64510 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
64511 ENDIF
64512 I1BEG = I1
64513 NSTP = 0
64514 GOTO 170
64515C...Alternatively use colour tag information.
64516 ELSE
64517C...Find a final state parton with appropriate dangling colour tag.
64518 JCT=0
64519 IA=0
64520 IJUMO=K(I,3)
64521 DO 140 J1=MAX(1,IP),N
64522 IF (K(J1,1).NE.3) GOTO 140
64523C...Check for matching final-state colour tag
64524 IMATCH=0
64525 DO 120 J2=MAX(1,IP),N
64526 IF (K(J2,1).NE.3) GOTO 120
64527 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
64528 120 CONTINUE
64529 IF (IMATCH.EQ.1) GOTO 140
64530C...Check whether this colour tag belongs to the present junction
64531C...by seeing whether any parton with this colour tag has the same
64532C...mother as the junction.
64533 JCT=MCT(J1,KCS-3)
64534 IMATCH=0
64535 DO 130 J2=MINT(84)+1,N
64536 IMO2=K(J2,3)
64537C...First scattering partons have IMO1 = 3 and 4.
64538 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
64539 & IMO2=IMO2-2
64540 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
64541 & IMATCH=1
64542 130 CONTINUE
64543 IF (IMATCH.EQ.0) GOTO 140
64544 IA=J1
64545 140 CONTINUE
64546C...Check for junction-junction strings without intermediate final state
64547C...glue (not detected above).
64548 IF (IA.EQ.0) THEN
64549 DO 160 MJU=1,NJUNC
64550 IJU2=IJUNC(MJU,0)
64551 IF (IJU2.EQ.I) GOTO 160
64552 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
64553C...Only opposite types of junctions can connect to each other.
64554 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
64555 IS=0
64556 DO 150 J=1,NPIECE
64557 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
64558 150 CONTINUE
64559 IF (IS.EQ.3) GOTO 160
64560 IB=I
64561 IA=IJU2
64562 160 CONTINUE
64563 ENDIF
64564C...Switch to other side of adjacent parton and step from there.
64565 KCS=9-KCS
64566 I1BEG = I1
64567 NSTP = 0
64568 GOTO 170
64569 ENDIF
64570 ELSE IF (ILC.NE.3) THEN
64571 ENDIF
64572 ENDIF
64573 ENDIF
64574
64575C...Look for coloured string endpoint, or (later) leftover gluon.
64576 IF(K(I,1).NE.3) GOTO 240
64577 KC=PYCOMP(K(I,2))
64578 IF(KC.EQ.0) GOTO 240
64579 KQ=KCHG(KC,2)
64580 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
64581
64582C...Pick up loose string end.
64583 KCS=4
64584 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
64585 IA=I
64586 IB=I
64587 I1BEG=I1
64588 NSTP=0
64589 170 NSTP=NSTP+1
64590 IF(NSTP.GT.4*N) THEN
64591 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
64592 MINT(51)=1
64593 RETURN
64594 ENDIF
64595
64596C...Copy undecayed parton. Finished if reached string endpoint.
64597 IF(K(IA,1).EQ.3) THEN
64598 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
64599 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
64600 MINT(51)=1
64601 MSTU(24)=1
64602 RETURN
64603 ENDIF
64604 I1=I1+1
64605 K(I1,1)=2
64606 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
64607 K(I1,2)=K(IA,2)
64608 K(I1,3)=IA
64609 K(I1,4)=0
64610 K(I1,5)=0
64611 DO 180 J=1,5
64612 P(I1,J)=P(IA,J)
64613 V(I1,J)=V(IA,J)
64614 180 CONTINUE
64615 K(IA,1)=K(IA,1)+10
64616 IF(K(I1,1).EQ.1) GOTO 240
64617 ENDIF
64618
64619C...Also finished (for now) if reached junction; then copy to end.
64620 IF(K(IA,1).EQ.42) THEN
64621 NCOPY=I1-I1BEG
64622 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
64623 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
64624 MINT(51)=1
64625 MSTU(24)=1
64626 RETURN
64627 ENDIF
64628 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
64629 DO 200 ICOPY=1,NCOPY
64630 DO 190 J=1,5
64631 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
64632 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
64633 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
64634 190 CONTINUE
64635 200 CONTINUE
64636 ENDIF
64637C...For junction-junction strings, find end leg and reorder junction
64638C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
64639C...junction-junction string piece.
64640 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
64641 ITMP=MOD(K(IA,4),MSTU(5))
64642 IF (ITMP.NE.IB) THEN
64643 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
64644 K(IA,5)=K(IA,5)+(ITMP-IB)
64645 ELSE
64646 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
64647 ENDIF
64648 K(IA,4)=K(IA,4)+(IB-ITMP)
64649 ENDIF
64650 ENDIF
64651 NPIECE=NPIECE+1
64652C...IPIECE:
64653C...0: endpoint in original ER
64654C...1:
64655C...2:
64656C...3: Parton immediately next to junction
64657C...4: Junction
64658 IPIECE(NPIECE,0)=I
64659 IPIECE(NPIECE,1)=MSTU32+1
64660 IPIECE(NPIECE,2)=MSTU32+NCOPY
64661 IPIECE(NPIECE,3)=IB
64662 IPIECE(NPIECE,4)=IA
64663 MSTU32=MSTU32+NCOPY
64664 I1=I1BEG
64665 GOTO 240
64666 ENDIF
64667
64668C...GOTO next parton in colour space.
64669 IB=IA
64670 IF (MINT(33).EQ.0) THEN
64671 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
64672 & )).NE.0) THEN
64673 IA=MOD(K(IB,KCS),MSTU(5))
64674 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
64675 MREV=0
64676 ELSE
64677 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
64678 & MSTU(5)).EQ.0) KCS=9-KCS
64679 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
64680 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
64681 MREV=1
64682 ENDIF
64683 IF(IA.LE.0.OR.IA.GT.N) THEN
64684 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
64685 IF(NERRPR.LT.5) THEN
64686 NERRPR=NERRPR+1
64687 WRITE(MSTU(11),*) 'started at:', I
64688 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
64689 WRITE(MSTU(11),*) 'MQGST =',MQGST
64690 CALL PYLIST(4)
64691 ENDIF
64692 MINT(51)=1
64693 RETURN
64694 ENDIF
64695 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
64696 & ,MSTU(5)).EQ.IB) THEN
64697 IF(MREV.EQ.1) KCS=9-KCS
64698 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
64699 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
64700 ELSE
64701 IF(MREV.EQ.0) KCS=9-KCS
64702 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
64703 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
64704 ENDIF
64705 IF(IA.NE.I) GOTO 170
64706C...Use colour tag information
64707 ELSE
64708C...First create colour tags starting on IB if none already present.
64709 IF (MCT(IB,KCS-3).EQ.0) THEN
64710 CALL PYCTTR(IB,KCS,IB)
64711 IF(MINT(51).NE.0) RETURN
64712 ENDIF
64713 JCT=MCT(IB,KCS-3)
64714 IFOUND=0
64715C...Find final state tag partner
64716 DO 210 IT=MAX(1,IP),N
64717 IF (IT.EQ.IB) GOTO 210
64718 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
64719 & .0) THEN
64720 IFOUND=IFOUND+1
64721 IA=IT
64722 ENDIF
64723 210 CONTINUE
64724C...Just copy and goto next if exactly one partner found.
64725 IF (IFOUND.EQ.1) THEN
64726 GOTO 170
64727C...When no match found, match is presumably junction.
64728 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
64729C...Check whether this colour tag matches a junction
64730C...by seeing whether any parton with this colour tag has the same
64731C...mother as a junction.
64732C...NB: Only type 1 and 2 junctions handled presently.
64733 DO 230 IJU=1,NJUNC
64734 IJUMO=K(IJUNC(IJU,0),3)
64735 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
64736C...Colours only connect to junctions, anti-colours to antijunctions:
64737 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
64738 IMATCH=0
64739 DO 220 J1=MAX(1,IP),N
64740 IF (K(J1,1).LE.0) GOTO 220
64741C...First scattering partons have IMO1 = 3 and 4.
64742 IMO=K(J1,3)
64743 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
64744 & IMO=IMO-2
64745 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
64746 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
64747 & IMATCH=1
64748C...Attempt at handling type > 3 junctions also. Not tested.
64749 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
64750 & .IJUMO) IMATCH=1
64751 220 CONTINUE
64752 IF (IMATCH.EQ.0) GOTO 230
64753 IA=IJUNC(IJU,0)
64754 IFOUND=IFOUND+1
64755 230 CONTINUE
64756
64757 IF (IFOUND.EQ.1) THEN
64758 GOTO 170
64759 ELSEIF (IFOUND.EQ.0) THEN
64760 WRITE(CHTMP,'(I6)') JCT
64761 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
64762 & //CHTMP)
64763 IF(NERRPR.LT.5) THEN
64764 NERRPR=NERRPR+1
64765 CALL PYLIST(4)
64766 ENDIF
64767 MINT(51)=1
64768 RETURN
64769 ENDIF
64770 ELSEIF (IFOUND.GE.2) THEN
64771 WRITE(CHTMP,'(I6)') JCT
64772 CALL PYERRM(12
64773 & ,'(PYPREP:) too many occurences of colour line: '//
64774 & CHTMP)
64775 IF(NERRPR.LT.5) THEN
64776 NERRPR=NERRPR+1
64777 CALL PYLIST(4)
64778 ENDIF
64779 MINT(51)=1
64780 RETURN
64781 ENDIF
64782 ENDIF
64783 K(I1,1)=1
64784 240 CONTINUE
64785 250 CONTINUE
64786
64787C...Junction systems remain.
64788 IJU=0
64789 IJUS=0
64790 IJUCNT=0
64791 MREV=0
64792 IJJSTR=0
64793 260 IJUCNT=IJUCNT+1
64794 IF (IJUCNT.LE.NJUNC) THEN
64795C...If we are not processing a j-j string, treat this junction as new.
64796 IF (IJJSTR.EQ.0) THEN
64797 IJU=IJUNC(IJUCNT,0)
64798 MREV=0
64799C...If junction has already been read, ignore it.
64800 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
64801C...If we are on a j-j string, goto second j-j junction.
64802 ELSE
64803 IJUCNT=IJUCNT-1
64804 IJU=IJUS
64805 ENDIF
64806C...Mark selected junction read.
64807 DO 270 J=1,NJUNC
64808 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
64809 270 CONTINUE
64810C...Determine junction type
64811 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
64812C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
64813C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
64814C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
64815 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
64816 IHK=0
64817 280 IHK=IHK+1
64818C...Find which quarks belong to given junction.
64819 IHF=0
64820 DO 290 IPC=1,NPIECE
64821 IF (IPIECE(IPC,4).EQ.IJU) THEN
64822 IHF=IHF+1
64823 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
64824 ENDIF
64825 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
64826 290 CONTINUE
64827C...IHK = 3 is special. Either normal string piece, or j-j string.
64828 IF(IHK.EQ.3) THEN
64829 IF (MREV.NE.1) THEN
64830 DO 300 IPC=1,NPIECE
64831C...If there is a j-j string starting on the present junction which has
64832C...zero length, insert next junction immediately.
64833 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
64834 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
64835 IJJSTR = 1
64836 GOTO 340
64837 ENDIF
64838 300 CONTINUE
64839 MREV = 1
64840C...If MREV is 1 and IHK is 3 we are finished with this system.
64841 ELSE
64842 MREV=0
64843 GOTO 260
64844 ENDIF
64845 ENDIF
64846
64847C...If we've gotten this far, then either IHK < 3, or
64848C...an interjunction string exists, or just a third normal string.
64849 IJUNC(IJUCNT,IHK)=0
64850 IJJSTR = 0
64851C..Order pieces belonging to this junction. Also look for j-j.
64852 DO 310 IPC=1,NPIECE
64853 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
64854 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
64855 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
64856 IJUNC(IJUCNT,IHK)=IPC
64857 IJJSTR = 1
64858 MREV = 0
64859 ENDIF
64860 310 CONTINUE
64861C...Copy back chains in proper order. MREV=0/1 : descending/ascending
64862 IPC=IJUNC(IJUCNT,IHK)
64863C...Temporary solution to cover for bug.
64864 IF(IPC.LE.0) THEN
64865 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
64866 MINT(51)=1
64867 RETURN
64868 ENDIF
64869 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
64870 I1=I1+1
64871 DO 320 J=1,5
64872 K(I1,J)=K(MSTU(4)-ICP,J)
64873 P(I1,J)=P(MSTU(4)-ICP,J)
64874 V(I1,J)=V(MSTU(4)-ICP,J)
64875 320 CONTINUE
64876 330 CONTINUE
64877 K(I1,1)=2
64878C...Mark last quark.
64879 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
64880C...Do not insert junctions at wrong places.
64881 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
64882C...Insert junction.
64883 340 IJUS = IJU
64884 IF (IHK.EQ.3) THEN
64885C...Shift to end junction if a j-j string has been processed.
64886 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
64887 MREV= 1
64888 ENDIF
64889 I1=I1+1
64890 DO 350 J=1,5
64891 K(I1,J)=0
64892 P(I1,J)=0.
64893 V(I1,J)=0.
64894 350 CONTINUE
64895 K(I1,1)=41
64896 K(IJUS,1)=K(IJUS,1)+10
64897 K(I1,2)=K(IJUS,2)
64898 K(I1,3)=IJUS
64899 360 IF (IHK.LT.3) GOTO 280
64900 ELSE
64901 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
64902 MINT(51)=1
64903 RETURN
64904 ENDIF
64905 IF (IJUCNT.NE.NJUNC) GOTO 260
64906 ENDIF
64907 N=I1
64908
64909C...Rearrange three strings from junction, e.g. in case one has been
64910C...shortened by shower, so the last is the largest-energy one.
64911 IF(NJUNC.GE.1) THEN
64912C...Find systems with exactly one junction.
64913 MJUN1=0
64914 NBEG=NOLD+1
64915 DO 470 I=NOLD+1,N
64916 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
64917 ELSEIF(K(I,1).EQ.41) THEN
64918 MJUN1=MJUN1+1
64919 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
64920 MJUN1=0
64921 NBEG=I+1
64922 ELSE
64923 NEND=I
64924C...Sum up energy-momentum in each junction string.
64925 DO 370 J=1,5
64926 PJU(1,J)=0D0
64927 PJU(2,J)=0D0
64928 PJU(3,J)=0D0
64929 370 CONTINUE
64930 NJU=0
64931 DO 390 I1=NBEG,NEND
64932 IF(K(I1,2).NE.21) THEN
64933 NJU=NJU+1
64934 IJUR(NJU)=I1
64935 ENDIF
64936 DO 380 J=1,5
64937 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
64938 380 CONTINUE
64939 390 CONTINUE
64940C...Find which of them has highest energy (minus mass) in rest frame.
64941 DO 400 J=1,5
64942 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
64943 400 CONTINUE
64944 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
64945 & PJU(4,3)**2))
64946 DO 410 I2=1,3
64947 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
64948 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
64949 410 CONTINUE
64950 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
64951C...Decide how to rearrange so that new last has highest energy.
64952 IF(PJU(1,6).LT.PJU(2,6)) THEN
64953 IRNG(1,1)=IJUR(1)
64954 IRNG(1,2)=IJUR(2)-1
64955 IRNG(2,1)=IJUR(4)
64956 IRNG(2,2)=IJUR(3)+1
64957 IRNG(4,1)=IJUR(3)-1
64958 IRNG(4,2)=IJUR(2)
64959 ELSE
64960 IRNG(1,1)=IJUR(4)
64961 IRNG(1,2)=IJUR(3)+1
64962 IRNG(2,1)=IJUR(2)
64963 IRNG(2,2)=IJUR(3)-1
64964 IRNG(4,1)=IJUR(2)-1
64965 IRNG(4,2)=IJUR(1)
64966 ENDIF
64967 IRNG(3,1)=IJUR(3)
64968 IRNG(3,2)=IJUR(3)
64969C...Copy in correct order below bottom of current event record.
64970 I2=N
64971 DO 440 II=1,4
64972 DO 430 I1=IRNG(II,1),IRNG(II,2),
64973 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
64974 I2=I2+1
64975 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
64976 CALL PYERRM(11,
64977 & '(PYPREP:) no more memory left in PYJETS')
64978 MINT(51)=1
64979 MSTU(24)=1
64980 RETURN
64981 ENDIF
64982 DO 420 J=1,5
64983 K(I2,J)=K(I1,J)
64984 P(I2,J)=P(I1,J)
64985 V(I2,J)=V(I1,J)
64986 420 CONTINUE
64987 IF(K(I2,1).EQ.1) K(I2,1)=2
64988 430 CONTINUE
64989 440 CONTINUE
64990 K(I2,1)=1
64991C...Copy back up, overwriting but now in correct order.
64992 DO 460 I1=NBEG,NEND
64993 I2=I1-NBEG+N+1
64994 DO 450 J=1,5
64995 K(I1,J)=K(I2,J)
64996 P(I1,J)=P(I2,J)
64997 V(I1,J)=V(I2,J)
64998 450 CONTINUE
64999 460 CONTINUE
65000 ENDIF
65001 MJUN1=0
65002 NBEG=I+1
65003 ENDIF
65004 470 CONTINUE
65005
65006C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
65007C...to two q-qbar systems.
65008C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
65009 IF (MSTJ(19).NE.1) THEN
65010 MJUN1 = 0
65011 JJGLUE = 0
65012 NBEG = NOLD+1
65013C...Force collapse when MSTJ(19)=2.
65014 IF (MSTJ(19).EQ.2) THEN
65015 DELMJJ = 1D9
65016 DELMQQ = 0D0
65017 ENDIF
65018C...Find systems with exactly two junctions.
65019 DO 700 I=NOLD+1,N
65020C...Count junctions
65021 IF (K(I,1).EQ.41) THEN
65022 MJUN1 = MJUN1+1
65023C...Check for interjunction gluons
65024 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
65025 JJGLUE = 1
65026 ENDIF
65027 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
65028C...If end of system reached with either zero or one junction, restart
65029C...with next system.
65030 MJUN1 = 0
65031 JJGLUE = 0
65032 NBEG = I+1
65033 ELSEIF(K(I,1).EQ.1) THEN
65034C...If end of system reached with exactly two junctions, compute string
65035C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
65036C...length measure for the (q-qbar)(q-qbar) topology.
65037 NEND=I
65038C...Loop down through chain.
65039 ISID=0
65040 DO 480 I1=NBEG,NEND
65041C...Store string piece division locations in event record
65042 IF (K(I1,2).NE.21) THEN
65043 ISID = ISID+1
65044 IJCP(ISID) = I1
65045 ENDIF
65046 480 CONTINUE
65047C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
65048 ISW=0
65049 IF (PYR(0).LT.0.5D0) ISW=1
65050C...Randomly choose which qqbar string gets the jj gluons.
65051 IGS=1
65052 IF (PYR(0).GT.0.5D0) IGS=2
65053C...Only compute string lengths when no topology forced.
65054 IF (MSTJ(19).EQ.0) THEN
65055C...Repeat following for each junction
65056 DO 570 IJU=1,2
65057C...Initialize iterative procedure for finding JRF
65058 IJRFIT=0
65059 DO 490 IX=1,3
65060 TJUOLD(IX)=0D0
65061 490 CONTINUE
65062 TJUOLD(4)=1D0
65063C...Start iteration. Sum up momenta in string pieces
65064 500 DO 540 IJS=1,3
65065C...JD=-1 for first junction, +1 for second junction.
65066C...Find out where piece starts and ends and which direction to go.
65067 JD=2*IJU-3
65068 IF (IJS.LE.2) THEN
65069 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
65070 IB = IJCP((IJU-1)*7 - JD*IJS)
65071 ELSEIF (IJS.EQ.3) THEN
65072 JD =-JD
65073 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
65074 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
65075 ENDIF
65076C...Initialize junction pull 4-vector.
65077 DO 510 J=1,5
65078 PUL(IJS,J)=0D0
65079 510 CONTINUE
65080C...Initialize weight
65081 PWT = 0D0
65082 PWTOLD = 0D0
65083C...Sum up (weighted) momenta along each string piece
65084 DO 530 ISP=IA,IB,JD
65085C...If present parton not last in chain
65086 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
65087C...If last parton was a junction, store present weight
65088 IF (K(ISP-JD,2).EQ.88) THEN
65089 PWTOLD = PWT
65090C...If last parton was a quark, reset to stored weight.
65091 ELSEIF (K(ISP-JD,2).NE.21) THEN
65092 PWT = PWTOLD
65093 ENDIF
65094 ENDIF
65095C...Skip next parton if weight already large
65096 IF (PWT.GT.10D0) GOTO 530
65097C...Compute momentum in TJUOLD frame:
65098 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
65099 & )*P(ISP,3)
65100 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
65101 DO 520 J=1,3
65102 TMP=P(ISP,J)+TJUOLD(J)*BFC
65103 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
65104 520 CONTINUE
65105C...Boosted energy
65106 TMP=TJUOLD(4)*P(ISP,4)+TDP
65107 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
65108C...Update weight
65109 PWT=PWT+TMP/PARJ(48)
65110C...Put |p| rather than m in 5th slot
65111 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
65112 & +PUL(IJS,3)**2)
65113 530 CONTINUE
65114 540 CONTINUE
65115C...Compute boost
65116 IJRFIT=IJRFIT+1
65117 CALL PYJURF(PUL,T)
65118C...Combine new boost (T) with old boost (TJUOLD)
65119 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
65120 DO 550 IX=1,3
65121 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
65122 & ))
65123 550 CONTINUE
65124 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
65125 & **2)
65126C...If last boost small, accept JRF, else iterate.
65127C...Also prevent possibility of infinite loop.
65128 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
65129 & IJRFIT.LT.MSTJ(18))THEN
65130 GOTO 500
65131 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
65132 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
65133 ENDIF
65134C...Store final boost, with change of sign since TJJ motion vector.
65135 DO 560 IX=1,3
65136 TJJ(IJU,IX)=-TJUOLD(IX)
65137 560 CONTINUE
65138 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
65139 & +TJJ(IJU,3)**2)
65140 570 CONTINUE
65141C...String length measure for (q-qbar)(q-qbar) topology.
65142C...Note only momenta of nearest partons used (since rest of system
65143C...identical).
65144 IF (JJGLUE.EQ.0) THEN
65145 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
65146 & -1,IJCP(5-ISW)+1)
65147 ELSE
65148C...Put jj gluons on selected string (IGS selected randomly above).
65149 IF (IGS.EQ.1) THEN
65150 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
65151 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
65152 ELSE
65153 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
65154 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
65155 & ,IJCP(5-ISW)+1)
65156 ENDIF
65157 ENDIF
65158C...String length measure for q-q-j-j-q-q topology.
65159 T1G1=0D0
65160 T2G2=0D0
65161 T1T2=0D0
65162 T1P1=0D0
65163 T1P2=0D0
65164 T2P3=0D0
65165 T2P4=0D0
65166 ISGN=-1
65167C...Note only momenta of nearest partons used (since rest of system
65168C...identical).
65169 DO 580 IX=1,4
65170 IF (IX.EQ.4) ISGN=1
65171 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
65172 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
65173 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
65174 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
65175 IF (JJGLUE.EQ.0) THEN
65176C...Junction motion vector dot product gives length when inter-junction
65177C...gluons absent.
65178 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
65179 ELSE
65180C...Junction motion vector dot products with gluon momenta give length
65181C...when inter-junction gluons present.
65182 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
65183 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
65184 ENDIF
65185 580 CONTINUE
65186 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
65187 IF (JJGLUE.EQ.0) THEN
65188 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
65189 ELSE
65190 DELMJJ=DELMJJ*4D0*T1G1*T2G2
65191 ENDIF
65192 ENDIF
65193C...If delmjj > delmqq collapse string system to q-qbar q-qbar
65194C...(Always the case for MSTJ(19)=2 due to initialization above)
65195 IF (DELMJJ.GT.DELMQQ) THEN
65196C...Put new system at end of event record
65197 NCOP=N
65198 DO 650 IST=1,2
65199 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
65200 NCOP=NCOP+1
65201 DO 590 IX=1,5
65202 P(NCOP,IX)=P(ICOP,IX)
65203 K(NCOP,IX)=K(ICOP,IX)
65204 590 CONTINUE
65205 600 CONTINUE
65206 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
65207C...Insert inter-junction gluon string piece (reversed)
65208 NJJGL=0
65209 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
65210 NJJGL=NJJGL+1
65211 NCOP=NCOP+1
65212 DO 610 IX=1,5
65213 P(NCOP,IX)=P(ICOP,IX)
65214 K(NCOP,IX)=K(ICOP,IX)
65215 610 CONTINUE
65216 620 CONTINUE
65217 ENDIF
65218 IFC=-2*IST+3
65219 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
65220 NCOP=NCOP+1
65221 DO 630 IX=1,5
65222 P(NCOP,IX)=P(ICOP,IX)
65223 K(NCOP,IX)=K(ICOP,IX)
65224 630 CONTINUE
65225 640 CONTINUE
65226 K(NCOP,1)=1
65227 650 CONTINUE
65228C...Copy system back in right order
65229 DO 670 ICOP=NBEG,NEND-2
65230 DO 660 IX=1,5
65231 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
65232 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
65233 660 CONTINUE
65234 670 CONTINUE
65235C...Shift down rest of event record
65236 DO 690 ICOP=NEND+1,N
65237 DO 680 IX=1,5
65238 P(ICOP-2,IX)=P(ICOP,IX)
65239 K(ICOP-2,IX)=K(ICOP,IX)
65240 680 CONTINUE
65241 690 CONTINUE
65242C...Update length of event record.
65243 N=N-2
65244 ENDIF
65245 MJUN1=0
65246 NBEG=I+1
65247 ENDIF
65248 700 CONTINUE
65249 ENDIF
65250 ENDIF
65251
65252C...Done if no checks on small-mass systems.
65253 IF(MSTJ(14).LT.0) RETURN
65254 IF(MSTJ(14).EQ.0) GOTO 1140
65255
65256C...Find lowest-mass colour singlet jet system.
65257 NS=N
65258 710 NSIN=N-NS
65259 PDMIN=1D0+PARJ(32)
65260 IC=0
65261 DO 770 I=MAX(1,IP),N
65262 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
65263 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
65264 NSIN=NSIN+1
65265 IC=I
65266 DO 720 J=1,4
65267 DPS(J)=P(I,J)
65268 720 CONTINUE
65269 MSTJ(93)=1
65270 DPS(5)=PYMASS(K(I,2))
65271 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
65272 DO 730 J=1,4
65273 DPS(J)=DPS(J)+P(I,J)
65274 730 CONTINUE
65275 MSTJ(93)=1
65276 DPS(5)=DPS(5)+PYMASS(K(I,2))
65277 ELSEIF(K(I,1).EQ.2) THEN
65278 DO 740 J=1,4
65279 DPS(J)=DPS(J)+P(I,J)
65280 740 CONTINUE
65281 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
65282 DO 750 J=1,4
65283 DPS(J)=DPS(J)+P(I,J)
65284 750 CONTINUE
65285 MSTJ(93)=1
65286 DPS(5)=DPS(5)+PYMASS(K(I,2))
65287 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
65288 & DPS(5)
65289 IF(PD.LT.PDMIN) THEN
65290 PDMIN=PD
65291 DO 760 J=1,5
65292 DPC(J)=DPS(J)
65293 760 CONTINUE
65294 IC1=IC
65295 IC2=I
65296 ENDIF
65297 IC=0
65298 ELSE
65299 NSIN=NSIN+1
65300 ENDIF
65301 770 CONTINUE
65302
65303C...Done if lowest-mass system above threshold for string frag.
65304 IF(PDMIN.GE.PARJ(32)) GOTO 1140
65305
65306C...Fill small-mass system as cluster.
65307 NSAV=N
65308 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
65309 K(N+1,1)=11
65310 K(N+1,2)=91
65311 K(N+1,3)=IC1
65312 P(N+1,1)=DPC(1)
65313 P(N+1,2)=DPC(2)
65314 P(N+1,3)=DPC(3)
65315 P(N+1,4)=DPC(4)
65316 P(N+1,5)=PECM
65317
65318C...Set up history, assuming cluster -> 2 hadrons.
65319 NBODY=2
65320 K(N+1,4)=N+2
65321 K(N+1,5)=N+3
65322 K(N+2,1)=1
65323 K(N+3,1)=1
65324 IF(MSTU(16).NE.2) THEN
65325 K(N+2,3)=N+1
65326 K(N+3,3)=N+1
65327 ELSE
65328 K(N+2,3)=IC1
65329 K(N+3,3)=IC2
65330 ENDIF
65331 K(N+2,4)=0
65332 K(N+3,4)=0
65333 K(N+2,5)=0
65334 K(N+3,5)=0
65335 V(N+1,5)=0D0
65336 V(N+2,5)=0D0
65337 V(N+3,5)=0D0
65338
65339C...Find total flavour content - complicated by presence of junctions.
65340 NQ=0
65341 NDIQ=0
65342 DO 780 I=IC1,IC2
65343 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
65344 NQ=NQ+1
65345 KFQ(NQ)=K(I,2)
65346 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
65347 ENDIF
65348 780 CONTINUE
65349
65350C...If several diquarks, split up one to give even number of flavours.
65351 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
65352 I1=3
65353 IF(IABS(KFQ(3)).LT.1000) I1=1
65354 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
65355 KFQ(I1)=KFQ(I1)/1000
65356 NQ=4
65357 NDIQ=NDIQ-1
65358 ENDIF
65359
65360C...If four quark ends, join two to diquark.
65361 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
65362 I1=1
65363 I2=2
65364 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
65365 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
65366 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
65367 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
65368 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
65369 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
65370 KFQ(I2)=KFQ(4)
65371 NQ=3
65372 NDIQ=1
65373 ENDIF
65374
65375C...If two quark ends, plus quark or diquark, join quarks to diquark.
65376 IF(NQ.EQ.3) THEN
65377 I1=1
65378 I2=2
65379 IF(IABS(KFQ(I1)).GT.1000) I1=3
65380 IF(IABS(KFQ(I2)).GT.1000) I2=3
65381 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
65382 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
65383 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
65384 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
65385 KFQ(I2)=KFQ(3)
65386 NQ=2
65387 NDIQ=NDIQ+1
65388 ENDIF
65389
65390C...Form two particles from flavours of lowest-mass system, if feasible.
65391 NTRY = 0
65392 790 NTRY = NTRY + 1
65393
65394C...Open string with two specified endpoint flavours.
65395 IF(NQ.EQ.2) THEN
65396 KC1=PYCOMP(KFQ(1))
65397 KC2=PYCOMP(KFQ(2))
65398 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
65399 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
65400 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
65401 IF(KQ1+KQ2.NE.0) GOTO 1140
65402C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
65403 800 K1=KFQ(1)
65404 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
65405 MSTU(125)=0
65406 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
65407 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
65408 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
65409
65410C...Open string with four specified flavours.
65411 ELSEIF(NQ.EQ.4) THEN
65412 KC1=PYCOMP(KFQ(1))
65413 KC2=PYCOMP(KFQ(2))
65414 KC3=PYCOMP(KFQ(3))
65415 KC4=PYCOMP(KFQ(4))
65416 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
65417 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
65418 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
65419 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
65420 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
65421 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
65422C...Combine flavours pairwise to form two hadrons.
65423 810 I1=1
65424 I2=2
65425 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
65426 & IABS(KFQ(2)).GT.1000)) I2=3
65427 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
65428 & IABS(KFQ(3)).GT.1000))) I2=4
65429 I3=3
65430 IF(I2.EQ.3) I3=2
65431 I4=10-I1-I2-I3
65432 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
65433 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
65434 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
65435
65436C...Closed string.
65437 ELSE
65438 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
65439C...No room for popcorn mesons in closed string -> 2 hadrons.
65440 MSTU(125)=0
65441 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
65442 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
65443 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
65444 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
65445 ENDIF
65446 P(N+2,5)=PYMASS(K(N+2,2))
65447 P(N+3,5)=PYMASS(K(N+3,2))
65448
65449C...If it does not work: try again (a number of times), give up (if no
65450C...place to shuffle momentum or too many flavours), or form one hadron.
65451 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
65452 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
65453 GOTO 790
65454 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
65455 GOTO 1140
65456 ELSE
65457 GOTO 890
65458 END IF
65459 END IF
65460
65461C...Perform two-particle decay of jet system.
65462C...First step: find reference axis in decaying system rest frame.
65463C...(Borrow slot N+2 for temporary direction.)
65464 DO 830 J=1,4
65465 P(N+2,J)=P(IC1,J)
65466 830 CONTINUE
65467 DO 850 I=IC1+1,IC2-1
65468 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
65469 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
8ff9ce7d 65470 IF (ABS(FOUR(IC1,I)+FOUR(IC2,I)).GT.0.D0) THEN
65471 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
65472 ELSE
65473 FRAC1 = 1.D0
65474 ENDIF
92e27c01 65475 DO 840 J=1,4
65476 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
65477 840 CONTINUE
65478 ENDIF
65479 850 CONTINUE
65480 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
65481 &-DPC(3)/DPC(4))
65482 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
65483 PHI1=PYANGL(P(N+2,1),P(N+2,2))
65484
65485C...Second step: generate isotropic/anisotropic decay.
65486 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
65487 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
65488 860 UE(3)=PYR(0)
65489 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
65490 PT2=(1D0-UE(3)**2)*PA**2
65491 IF(MSTJ(16).LE.0) THEN
65492 PREV=0.5D0
65493 ELSE
65494 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
65495 PR1=P(N+2,5)**2+PT2
65496 PR2=P(N+3,5)**2+PT2
65497 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
65498 PREVCF=PARJ(42)
65499 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
65500 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
65501 ENDIF
65502 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
65503 PHI=PARU(2)*PYR(0)
65504 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
65505 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
65506 DO 870 J=1,3
65507 P(N+2,J)=PA*UE(J)
65508 P(N+3,J)=-PA*UE(J)
65509 870 CONTINUE
65510 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
65511 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
65512
65513C...Third step: move back to event frame and set production vertex.
65514 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
65515 &DPC(3)/DPC(4))
65516 DO 880 J=1,4
65517 V(N+1,J)=V(IC1,J)
65518 V(N+2,J)=V(IC1,J)
65519 V(N+3,J)=V(IC2,J)
65520 880 CONTINUE
65521 N=N+3
65522 GOTO 1120
65523
65524C...Else form one particle, if possible.
65525 890 NBODY=1
65526 K(N+1,5)=N+2
65527 DO 900 J=1,4
65528 V(N+1,J)=V(IC1,J)
65529 V(N+2,J)=V(IC1,J)
65530 900 CONTINUE
65531
65532C...Select hadron flavour from available quark flavours.
65533 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
65534 GOTO 1140
65535 ELSEIF(NQ.EQ.2) THEN
65536 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
65537 ELSE
65538 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
65539 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
65540 ENDIF
65541 IF(K(N+2,2).EQ.0) GOTO 910
65542 P(N+2,5)=PYMASS(K(N+2,2))
65543
65544C...Use old algorithm for E/p conservation? (EN)
65545 IF (MSTJ(16).LE.0) GOTO 1080
65546
65547C...Find the string piece closest to the cluster by a loop
65548C...over the undecayed partons not in present cluster. (EN)
65549 DGLOMI=1D30
65550 IBEG=0
65551 I0=0
65552 NJUNC=0
65553 DO 940 I1=MAX(1,IP),N-1
65554 IF(K(I1,1).EQ.1) NJUNC=0
65555 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
65556 IF(K(I1,1).EQ.41) GOTO 940
65557 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
65558 I0=0
65559 ELSEIF(K(I1,1).EQ.2) THEN
65560 IF(I0.EQ.0) I0=I1
65561 I2=I1
65562 920 I2=I2+1
65563 IF(K(I2,1).EQ.41) GOTO 940
65564 IF(K(I2,1).GT.10) GOTO 920
65565 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
65566 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
65567 & NJUNC.EQ.0) GOTO 940
65568 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
65569 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
65570 & K(I2,1).NE.1)) GOTO 940
65571
65572C...Define velocity vectors e1, e2, ecl and differences e3, e4.
65573 DO 930 J=1,3
65574 E1(J)=P(I1,J)/P(I1,4)
65575 E2(J)=P(I2,J)/P(I2,4)
65576 ECL(J)=P(N+1,J)/P(N+1,4)
65577 E3(J)=E2(J)-E1(J)
65578 E4(J)=ECL(J)-E1(J)
65579 930 CONTINUE
65580
65581C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
65582 E3S=E3(1)**2+E3(2)**2+E3(3)**2
65583 E4S=E4(1)**2+E4(2)**2+E4(3)**2
65584 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
65585 IF(E34.LE.0D0) THEN
65586 DDMIN=E4S
65587 ELSEIF(E34.LT.E3S) THEN
65588 DDMIN=E4S-E34**2/E3S
65589 ELSE
65590 DDMIN=E4S-2D0*E34+E3S
65591 ENDIF
65592
65593C...Is this the smallest so far?
65594 IF(DDMIN.LT.DGLOMI) THEN
65595 DGLOMI=DDMIN
65596 IBEG=I0
65597 IPCS=I1
65598 ENDIF
65599 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
65600 I0=0
65601 ENDIF
65602 940 CONTINUE
65603
65604C... Check if there are any strings to connect to the new gluon. (EN)
65605 IF (IBEG.EQ.0) GOTO 1080
65606
65607C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
65608 IF (P(N+1,5).GE.P(N+2,5)) THEN
65609
65610C...Construct 'gluon' that is needed to put hadron on the mass shell.
65611 FRAC=P(N+2,5)/P(N+1,5)
65612 DO 950 J=1,5
65613 P(N+2,J)=FRAC*P(N+1,J)
65614 PG(J)=(1D0-FRAC)*P(N+1,J)
65615 950 CONTINUE
65616
65617C... Copy string with new gluon put in.
65618 N=N+2
65619 I=IBEG-1
65620 960 I=I+1
65621 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
65622 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
65623 N=N+1
65624 DO 970 J=1,5
65625 K(N,J)=K(I,J)
65626 P(N,J)=P(I,J)
65627 V(N,J)=V(I,J)
65628 970 CONTINUE
65629 K(I,1)=K(I,1)+10
65630 K(I,4)=N
65631 K(I,5)=N
65632 K(N,3)=I
65633 IF(I.EQ.IPCS) THEN
65634 N=N+1
65635 DO 980 J=1,5
65636 K(N,J)=K(N-1,J)
65637 P(N,J)=PG(J)
65638 V(N,J)=V(N-1,J)
65639 980 CONTINUE
65640 K(N,2)=21
65641 K(N,3)=NSAV+1
65642 ENDIF
65643 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
65644 GOTO 1120
65645
65646C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
65647C...from string piece endpoints.
65648 ELSE
65649
65650C...Begin by copying string that should give energy to cluster.
65651 N=N+2
65652 I=IBEG-1
65653 990 I=I+1
65654 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
65655 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
65656 N=N+1
65657 DO 1000 J=1,5
65658 K(N,J)=K(I,J)
65659 P(N,J)=P(I,J)
65660 V(N,J)=V(I,J)
65661 1000 CONTINUE
65662 K(I,1)=K(I,1)+10
65663 K(I,4)=N
65664 K(I,5)=N
65665 K(N,3)=I
65666 IF(I.EQ.IPCS) I1=N
65667 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
65668 I2=I1+1
65669
65670C...Set initial Phad.
65671 DO 1010 J=1,4
65672 P(NSAV+2,J)=P(NSAV+1,J)
65673 1010 CONTINUE
65674
65675C...Calculate Pg, a part of which will be added to Phad later. (EN)
65676 1020 IF(MSTJ(16).EQ.1) THEN
65677 ALPHA=1D0
65678 BETA=1D0
65679 ELSE
8ff9ce7d 65680 IF (ABS(FOUR(I1,I2)).GT.0.D0) THEN
65681 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
65682 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
65683 ELSE
65684 ALPHA=1D0
65685 BETA=1D0
65686 ENDIF
92e27c01 65687 ENDIF
65688 DO 1030 J=1,4
65689 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
65690 1030 CONTINUE
65691 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
65692
65693C..Solve 2nd order equation, use the best (smallest) solution. (EN)
65694 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
65695 & P(NSAV+2,3)**2
65696 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
65697 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
65698 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
65699
65700C...If all gluon energy eaten, zero it and take a step back.
65701 ITER=0
65702 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
65703 ITER=1
65704 DO 1040 J=1,4
65705 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
65706 P(I1,J)=0D0
65707 1040 CONTINUE
65708 P(I1,5)=0D0
65709 K(I1,1)=K(I1,1)+10
65710 I1=I1-1
65711 IF(K(I1,1).EQ.41) ITER=-1
65712 ENDIF
65713 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
65714 ITER=1
65715 DO 1050 J=1,4
65716 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
65717 P(I2,J)=0D0
65718 1050 CONTINUE
65719 P(I2,5)=0D0
65720 K(I2,1)=K(I2,1)+10
65721 I2=I2+1
65722 IF(K(I2,1).EQ.41) ITER=-1
65723 ENDIF
65724 IF(ITER.EQ.1) GOTO 1020
65725
65726C...If also all endpoint energy eaten, revert to old procedure.
65727 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
65728 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
65729 DO 1060 I=NSAV+3,N
65730 IM=K(I,3)
65731 K(IM,1)=K(IM,1)-10
65732 K(IM,4)=0
65733 K(IM,5)=0
65734 1060 CONTINUE
65735 N=NSAV
65736 GOTO 1080
65737 ENDIF
65738
65739C... Construct the collapsed hadron and modified string partons.
65740 DO 1070 J=1,4
65741 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
65742 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
65743 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
65744 1070 CONTINUE
65745 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
65746 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
65747
65748C...Finished with string collapse in new scheme.
65749 GOTO 1120
65750 ENDIF
65751
65752C... Use old algorithm; by choice or when in trouble.
65753 1080 CONTINUE
65754C...Find parton/particle which combines to largest extra mass.
65755 IR=0
65756 HA=0D0
65757 HSM=0D0
65758 DO 1100 MCOMB=1,3
65759 IF(IR.NE.0) GOTO 1100
65760 DO 1090 I=MAX(1,IP),N
65761 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
65762 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
65763 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
65764 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
65765 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
65766 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
65767 & GOTO 1090
65768 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
65769 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
65770 IF(HSR.GT.HSM) THEN
65771 IR=I
65772 HA=HCR
65773 HSM=HSR
65774 ENDIF
65775 1090 CONTINUE
65776 1100 CONTINUE
65777
65778C...Shuffle energy and momentum to put new particle on mass shell.
65779 IF(IR.NE.0) THEN
65780 HB=PECM**2+HA
65781 HC=P(N+2,5)**2+HA
65782 HD=P(IR,5)**2+HA
65783 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
65784 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
65785 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
65786 DO 1110 J=1,4
65787 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
65788 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
65789 1110 CONTINUE
65790 N=N+2
65791 ELSE
65792 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
65793 RETURN
65794 ENDIF
65795
65796C...Mark collapsed system and store daughter pointers. Iterate.
65797 1120 DO 1130 I=IC1,IC2
65798 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
65799 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
65800 K(I,1)=K(I,1)+10
65801 IF(MSTU(16).NE.2) THEN
65802 K(I,4)=NSAV+1
65803 K(I,5)=NSAV+1
65804 ELSE
65805 K(I,4)=NSAV+2
65806 K(I,5)=NSAV+1+NBODY
65807 ENDIF
65808 ENDIF
65809 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
65810 1130 CONTINUE
65811 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
65812
65813C...Check flavours and invariant masses in parton systems.
65814 1140 NP=0
65815 KFN=0
65816 KQS=0
65817 NJU=0
65818 DO 1150 J=1,5
65819 DPS(J)=0D0
65820 1150 CONTINUE
65821 DO 1180 I=MAX(1,IP),N
65822 IF(K(I,1).EQ.41) NJU=NJU+1
65823 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
65824 KC=PYCOMP(K(I,2))
65825 IF(KC.EQ.0) GOTO 1180
65826 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
65827 IF(KQ.EQ.0) GOTO 1180
65828 NP=NP+1
65829 IF(KQ.NE.2) THEN
65830 KFN=KFN+1
65831 KQS=KQS+KQ
65832 MSTJ(93)=1
65833 DPS(5)=DPS(5)+PYMASS(K(I,2))
65834 ENDIF
65835 DO 1160 J=1,4
65836 DPS(J)=DPS(J)+P(I,J)
65837 1160 CONTINUE
65838 IF(K(I,1).EQ.1) THEN
65839 NFERR=0
65840 IF(NJU.EQ.0.AND.NP.NE.1) THEN
65841 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
65842 ELSEIF(NJU.EQ.1) THEN
65843 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
65844 ELSEIF(NJU.EQ.2) THEN
65845 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
65846 ELSEIF(NJU.GE.3) THEN
65847 NFERR=1
65848 ENDIF
65849 IF(NFERR.EQ.1) THEN
65850 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
65851 MINT(51)=1
65852 RETURN
65853 ENDIF
65854 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
65855 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
65856 & '(PYPREP:) too small mass in jet system')
65857 NP=0
65858 KFN=0
65859 KQS=0
65860 NJU=0
65861 DO 1170 J=1,5
65862 DPS(J)=0D0
65863 1170 CONTINUE
65864 ENDIF
65865 1180 CONTINUE
65866
65867 RETURN
65868 END
65869
65870C*********************************************************************
65871
65872C...PYSTRF
65873C...Handles the fragmentation of an arbitrary colour singlet
65874C...jet system according to the Lund string fragmentation model.
65875
65876 SUBROUTINE PYSTRF(IP)
65877
65878C...Double precision and integer declarations.
65879 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65880 IMPLICIT INTEGER(I-N)
65881 INTEGER PYK,PYCHGE,PYCOMP
65882C...Commonblocks.
65883 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65884 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65885 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65886 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
65887C...Local arrays. All MOPS variables ends with MO
65888 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
65889 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
65890 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
65891 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
65892 &PBST(3,5),TJUOLD(5)
65893
65894C...Function: four-product of two vectors.
65895 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)
65896 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
65897 &DP(I,3)*DP(J,3)
65898
65899C...Reset counters.
65900 MSTJ(91)=0
65901 NSAV=N
65902 MSTU90=MSTU(90)
65903 NP=0
65904 KQSUM=0
65905 DO 100 J=1,5
65906 DPS(J)=0D0
65907 100 CONTINUE
65908 MJU(1)=0
65909 MJU(2)=0
65910 NTRYFN=0
65911 IJUORI(1)=0
65912 IJUORI(2)=0
65913
65914C...Identify parton system.
65915 I=IP-1
65916 110 I=I+1
65917 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
65918 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
65919 IF(MSTU(21).GE.1) RETURN
65920 ENDIF
65921 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
65922 KC=PYCOMP(K(I,2))
65923 IF(KC.EQ.0) GOTO 110
65924 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
65925 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
65926 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
65927 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
65928 IF(MSTU(21).GE.1) RETURN
65929 ENDIF
65930
65931C...Take copy of partons to be considered. Check flavour sum.
65932 NP=NP+1
65933 DO 120 J=1,5
65934 K(N+NP,J)=K(I,J)
65935 P(N+NP,J)=P(I,J)
65936 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
65937 120 CONTINUE
65938 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
65939 K(N+NP,3)=I
65940 IF(KQ.NE.2) KQSUM=KQSUM+KQ
65941 IF(K(I,1).EQ.41) THEN
65942 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
65943 MJU(1)=N+NP
65944 IJUORI(1)=I
65945 ELSE
65946 MJU(2)=N+NP
65947 IJUORI(2)=I
65948 ENDIF
65949 ENDIF
65950 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
65951 IF(MOD(KQSUM,3).NE.0) THEN
65952 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
65953 IF(MSTU(21).GE.1) RETURN
65954 ENDIF
65955 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
65956
65957C...Boost copied system to CM frame (for better numerical precision).
65958 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
65959 MBST=0
65960 MSTU(33)=1
65961 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
65962 & -DPS(3)/DPS(4))
65963 ELSE
65964 MBST=1
65965 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
65966 DO 130 I=N+1,N+NP
65967 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
65968 IF(P(I,3).GT.0D0) THEN
65969 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
65970 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
65971 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65972 ELSE
65973 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
65974 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
65975 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65976 ENDIF
65977 130 CONTINUE
65978 ENDIF
65979
65980C...Search for very nearby partons that may be recombined.
65981 NTRYR=0
65982 NTRYWR=0
65983 PARU12=PARU(12)
65984 PARU13=PARU(13)
65985 MJU(3)=MJU(1)
65986 MJU(4)=MJU(2)
65987 NR=NP
65988 NRMIN=2
65989 IF(MJU(1).GT.0) NRMIN=NRMIN+2
65990 IF(MJU(2).GT.0) NRMIN=NRMIN+2
65991 140 IF(NR.GT.NRMIN) THEN
65992 PDRMIN=2D0*PARU12
65993 DO 150 I=N+1,N+NR
65994 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
65995 I1=I+1
65996 IF(I.EQ.N+NR) I1=N+1
65997 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
65998 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
65999 & GOTO 150
66000 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
66001 & GOTO 150
66002 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
66003 & P(I1,2)**2+P(I1,3)**2))
66004 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
66005 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
66006 IF(PDR.LT.PDRMIN) THEN
66007 IR=I
66008 PDRMIN=PDR
66009 ENDIF
66010 150 CONTINUE
66011
66012C...Recombine very nearby partons to avoid machine precision problems.
66013 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
66014 DO 160 J=1,4
66015 P(N+1,J)=P(N+1,J)+P(N+NR,J)
66016 160 CONTINUE
66017 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
66018 & P(N+1,3)**2))
66019 NR=NR-1
66020 GOTO 140
66021 ELSEIF(PDRMIN.LT.PARU12) THEN
66022 DO 170 J=1,4
66023 P(IR,J)=P(IR,J)+P(IR+1,J)
66024 170 CONTINUE
66025 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
66026 & P(IR,3)**2))
66027 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
66028 DO 190 I=IR+1,N+NR-1
66029 K(I,1)=K(I+1,1)
66030 K(I,2)=K(I+1,2)
66031 DO 180 J=1,5
66032 P(I,J)=P(I+1,J)
66033 180 CONTINUE
66034 190 CONTINUE
66035 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
66036 NR=NR-1
66037 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
66038 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
66039 GOTO 140
66040 ENDIF
66041 ENDIF
66042 NTRYR=NTRYR+1
66043
66044C...Reset particle counter. Skip ahead if no junctions are present;
66045C...this is usually the case!
66046 NRS=MAX(5*NR+11,NP)
66047 NTRY=0
66048 200 NTRY=NTRY+1
66049 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
66050 PARU12=4D0*PARU12
66051 PARU13=2D0*PARU13
66052 GOTO 140
66053 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
66054 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
66055 IF(MSTU(21).GE.1) RETURN
66056 ENDIF
66057 I=N+NRS
66058 MSTU(90)=MSTU90
66059 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
66060 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
66061 & ' junction strings not handled by MSTJ(12)>3 options')
66062 DO 640 JT=1,2
66063 NJS(JT)=0
66064 IF(MJU(JT).EQ.0) GOTO 640
66065 JS=3-2*JT
66066
66067C++SKANDS
66068C...Find and sum up momentum on three sides of junction.
66069C...Begin with previous boost = zero.
66070 IJRFIT=0
66071 DO 210 IX=1,3
66072 TJUOLD(IX)=0D0
66073 210 CONTINUE
66074C...Prevent IJU (specifically IJU(5)) from containing junk below
66075 DO 215 IU=1,6
66076 IJU(IU)=0
66077 215 CONTINUE
66078 TJUOLD(4)=1D0
66079 220 IU=0
66080C...Beginning and end of string system in event record.
66081 I1BEG=N+1+(JT-1)*(NR-1)
66082 I1END=N+NR+(JT-1)*(1-NR)
66083C...Look for junction string piece end points
66084 DO 230 I1=I1BEG,I1END,JS
66085 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
66086C...Store junction string piece end points.
66087C 1-junction systems 2-junction systems
66088C IU : 1 2 3 4 1 2 3 4 5 6
66089C 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
66090 IU=IU+1
66091 IJU(IU)=I1
66092 ENDIF
66093C...Sum over momenta, from junction outwards.
66094 230 CONTINUE
66095 DO 280 IU=1,3
66096 PWT=0D0
66097C...Initialize junction drag and string piece 4-vectors.
66098 DO 240 J=1,5
66099 PBST(IU,J)=0D0
66100 PJU(IU,J)=0D0
66101 240 CONTINUE
66102C...First two branches. Inwards out means opposite direction to JS.
66103C...(JS is 1 for JT=1, -1 for JT=2)
66104 IF (IU.LT.3) THEN
66105 I1A=IJU(IU+1)-JS
66106 I1B=IJU(IU)
66107 IDIR=-JS
66108C...Last branch (gq or gjgqgq). Direction now reversed.
66109 ELSE
66110 I1A=IJU(IU)+JS
66111 I1B=I1END
66112 IDIR=JS
66113 ENDIF
66114 DO 270 I1=I1A,I1B,IDIR
66115C...Sum up momentum directions with exponential suppression
66116C...for use in finding junction rest frame below.
66117 IF (K(I1,2).EQ.88) THEN
66118C...gjgqgq type system encountered. Use current PWT as start
66119C...for both strings.
66120 PWTOLD=PWT
66121 ELSE
66122 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
66123C...Sum up string piece (boosted) 4-momenta.
66124 DO 250 J=1,4
66125 PJU(IU,J)=PJU(IU,J)+P(I1,J)
66126 250 CONTINUE
66127C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
66128C...boost is zero, see above). Skip parton if suppression factor large.
66129 IF (PWT.GT.10D0) GOTO 270
66130C...Compute momentum in current frame:
66131 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
66132 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
66133 DO 260 J=1,3
66134 PTMP=P(I1,J)+TJUOLD(J)*BFC
66135 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
66136 260 CONTINUE
66137C...Boosted energy
66138 PTMP=TJUOLD(4)*P(I1,4)+TDP
66139 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
66140 PWT=PWT+PTMP/PARJ(48)
66141 ENDIF
66142 270 CONTINUE
66143C...Put |p| rather than m in 5th slot.
66144 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
66145 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
66146 280 CONTINUE
66147
66148C...Calculate boost from present frame to next JRF candidate.
66149 IJRFIT=IJRFIT+1
66150 CALL PYJURF(PBST,TJU)
66151
66152C...After some iterations do not take full step in new direction.
66153 IF(IJRFIT.GT.5) THEN
66154 REDUCE=0.8D0**(IJRFIT-5)
66155 TJU(1)=REDUCE*TJU(1)
66156 TJU(2)=REDUCE*TJU(2)
66157 TJU(3)=REDUCE*TJU(3)
66158 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
66159 ENDIF
66160
66161C...Combine new boost (TJU) with old boost (TJUOLD)
66162 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
66163 DO 290 IX=1,3
66164 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
66165 290 CONTINUE
66166 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
66167
66168C...If last boost small, accept JRF, else iterate.
66169C...Also prevent possibility of infinite loop.
66170 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
66171 & IJRFIT.LT.MSTJ(18)) THEN
66172 GOTO 220
66173 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
66174 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
66175 ENDIF
66176
66177C...Now store total boost in TJU and change perception.
66178C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
66179C...TJU = junction motion vector in string CM, so the sign changes.
66180 DO 300 J=1,3
66181 TJU(J)=-TJUOLD(J)
66182 300 CONTINUE
66183 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
66184
66185C--SKANDS
66186
66187C...Calculate string piece energies in junction rest frame.
66188 DO 310 IU=1,3
66189 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
66190 & TJU(3)*PJU(IU,3)
66191 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
66192 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
66193 310 CONTINUE
66194
66195C...Start preparing for fragmentation of two strings from junction.
66196 ISTA=I
66197 NTRYER=0
66198 320 NTRYER=NTRYER+1
66199 I=ISTA
66200 DO 620 IU=1,2
66201 NS=IABS(IJU(IU+1)-IJU(IU))
66202
66203C...Junction strings: find longitudinal string directions.
66204 DO 350 IS=1,NS
66205 IS1=IJU(IU)+JS*(IS-1)
66206 IS2=IJU(IU)+JS*IS
66207 DO 330 J=1,5
66208 DP(1,J)=0.5D0*P(IS1,J)
66209 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
66210 DP(2,J)=0.5D0*P(IS2,J)
66211 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
66212 & (PJU(IU,5)/PBST(IU,5))
66213 330 CONTINUE
66214 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
66215 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
66216 DP(3,5)=DFOUR(1,1)
66217 DP(4,5)=DFOUR(2,2)
66218 DHKC=DFOUR(1,2)
66219 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
66220 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66221 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66222 DP(3,5)=0D0
66223 DP(4,5)=0D0
66224 DHKC=DFOUR(1,2)
66225 ENDIF
66226 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
66227 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
66228 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
66229 IN1=N+NR+4*IS-3
66230 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
66231 DO 340 J=1,4
66232 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
66233 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
66234 340 CONTINUE
66235 350 CONTINUE
66236
66237C...Junction strings: initialize flavour, momentum and starting pos.
66238 ISAV=I
66239 MSTU91=MSTU(90)
66240 360 NTRY=NTRY+1
66241 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
66242 PARU12=4D0*PARU12
66243 PARU13=2D0*PARU13
66244 GOTO 140
66245 ELSEIF(NTRY.GT.100) THEN
66246 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
66247 IF(MSTU(21).GE.1) RETURN
66248 ENDIF
66249 I=ISAV
66250 MSTU(90)=MSTU91
66251 IRANKJ=0
66252 IE(1)=K(N+1+(JT/2)*(NP-1),3)
66253 IF (MOD(JT+IU,2).NE.0) THEN
66254 IE(1)=K(IJU(IU),3)
66255 IF (NP-NR.NE.0) THEN
66256C...If gluons have disappeared. Original IJU must be used.
66257 IT=IP
66258 NE=1
66259 370 IT=IT+1
66260 IF (K(IT,2).NE.21) THEN
66261 NE=NE+1
66262 ENDIF
66263 IF (NE.EQ.IU+4*(JT-1)) THEN
66264 IE(1)=IT
66265 ELSEIF (IT.LE.IP+NP) THEN
66266 GOTO 370
66267 ELSE
66268 CALL PYERRM(14,'(PYSTRF:) '//
66269 & 'Original IJU could not be reconstructed!')
66270 ENDIF
66271 ENDIF
66272 ENDIF
66273 IN(4)=N+NR+1
66274 IN(5)=IN(4)+1
66275 IN(6)=N+NR+4*NS+1
66276 DO 390 JQ=1,2
66277 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
66278 P(IN1,1)=2-JQ
66279 P(IN1,2)=JQ-1
66280 P(IN1,3)=1D0
66281 380 CONTINUE
66282 390 CONTINUE
66283 KFL(1)=K(IJU(IU),2)
66284 PX(1)=0D0
66285 PY(1)=0D0
66286 GAM(1)=0D0
66287 DO 400 J=1,5
66288 PJU(IU+3,J)=0D0
66289 400 CONTINUE
66290
66291C...Junction strings: find initial transverse directions.
66292 DO 410 J=1,4
66293 DP(1,J)=P(IN(4),J)
66294 DP(2,J)=P(IN(4)+1,J)
66295 DP(3,J)=0D0
66296 DP(4,J)=0D0
66297 410 CONTINUE
66298 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66299 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66300 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
66301 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
66302 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
66303 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
66304 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
66305 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
66306 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
66307 DHC12=DFOUR(1,2)
66308 DHCX1=DFOUR(3,1)/DHC12
66309 DHCX2=DFOUR(3,2)/DHC12
66310 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
66311 DHCY1=DFOUR(4,1)/DHC12
66312 DHCY2=DFOUR(4,2)/DHC12
66313 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
66314 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
66315 DO 420 J=1,4
66316 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
66317 P(IN(6),J)=DP(3,J)
66318 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
66319 & DHCYX*DP(3,J))
66320 420 CONTINUE
66321
66322C...Junction strings: produce new particle, origin.
66323 430 I=I+1
66324 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
66325 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
66326 IF(MSTU(21).GE.1) RETURN
66327 ENDIF
66328 IRANKJ=IRANKJ+1
66329 K(I,1)=1
66330 K(I,3)=IE(1)
66331 K(I,4)=0
66332 K(I,5)=0
66333
66334C...Junction strings: generate flavour, hadron, pT, z and Gamma.
66335 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
66336 IF(K(I,2).EQ.0) GOTO 360
66337 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
66338 & IABS(KFL(3)).GT.10) THEN
66339 IF(PYR(0).GT.PARJ(19)) GOTO 440
66340 ENDIF
66341 P(I,5)=PYMASS(K(I,2))
66342 CALL PYPTDI(KFL(1),PX(3),PY(3))
66343 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
66344 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
66345 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
66346 & MSTU(90).LT.8) THEN
66347 MSTU(90)=MSTU(90)+1
66348 MSTU(90+MSTU(90))=I
66349 PARU(90+MSTU(90))=Z
66350 ENDIF
66351 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
66352 DO 450 J=1,3
66353 IN(J)=IN(3+J)
66354 450 CONTINUE
66355
66356C...Junction strings: stepping within 'low' string region.
66357 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
66358 & P(IN(1),5)**2.GE.PR(1)) THEN
66359 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
66360 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
66361 DO 460 J=1,4
66362 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
66363 460 CONTINUE
66364 GOTO 560
66365C...Has used up energy of junction string, i.e. no more hadrons in it.
66366 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
66367 DO 470 J=1,5
66368 P(I,J)=0D0
66369 470 CONTINUE
66370 GOTO 600
66371C...Stepping from 'low' string region
66372 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
66373 P(IN(2)+2,4)=P(IN(2)+2,3)
66374 P(IN(2)+2,1)=1D0
66375 IN(2)=IN(2)+4
66376 IF(IN(2).GT.N+NR+4*NS) GOTO 360
66377 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
66378 P(IN(1)+2,4)=P(IN(1)+2,3)
66379 P(IN(1)+2,1)=0D0
66380 IN(1)=IN(1)+4
66381 ENDIF
66382 ENDIF
66383
66384C...Junction strings: find new transverse directions.
66385 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
66386 & IN(1).GT.IN(2)) GOTO 360
66387 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
66388 DO 490 J=1,4
66389 DP(1,J)=P(IN(1),J)
66390 DP(2,J)=P(IN(2),J)
66391 DP(3,J)=0D0
66392 DP(4,J)=0D0
66393 490 CONTINUE
66394 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66395 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66396 DHC12=DFOUR(1,2)
66397 IF(DHC12.LE.1D-2) THEN
66398 P(IN(1)+2,4)=P(IN(1)+2,3)
66399 P(IN(1)+2,1)=0D0
66400 IN(1)=IN(1)+4
66401 GOTO 480
66402 ENDIF
66403 IN(3)=N+NR+4*NS+5
66404 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
66405 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
66406 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
66407 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
66408 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
66409 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
66410 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
66411 DHCX1=DFOUR(3,1)/DHC12
66412 DHCX2=DFOUR(3,2)/DHC12
66413 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
66414 DHCY1=DFOUR(4,1)/DHC12
66415 DHCY2=DFOUR(4,2)/DHC12
66416 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
66417 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
66418 DO 500 J=1,4
66419 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
66420 P(IN(3),J)=DP(3,J)
66421 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
66422 & DHCYX*DP(3,J))
66423 500 CONTINUE
66424C...Express pT with respect to new axes, if sensible.
66425 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
66426 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
66427 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
66428 PX(3)=PXP
66429 PY(3)=PYP
66430 ENDIF
66431 ENDIF
66432
66433C...Junction strings: sum up known four-momentum, coefficients for m2.
66434 DO 530 J=1,4
66435 DHG(J)=0D0
66436 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
66437 & PY(3)*P(IN(3)+1,J)
66438 DO 510 IN1=IN(4),IN(1)-4,4
66439 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
66440 510 CONTINUE
66441 DO 520 IN2=IN(5),IN(2)-4,4
66442 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
66443 520 CONTINUE
66444 530 CONTINUE
66445 DHM(1)=FOUR(I,I)
66446 DHM(2)=2D0*FOUR(I,IN(1))
66447 DHM(3)=2D0*FOUR(I,IN(2))
66448 DHM(4)=2D0*FOUR(IN(1),IN(2))
66449
66450C...Junction strings: find coefficients for Gamma expression.
66451 DO 550 IN2=IN(1)+1,IN(2),4
66452 DO 540 IN1=IN(1),IN2-1,4
66453 DHC=2D0*FOUR(IN1,IN2)
66454 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
66455 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
66456 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
66457 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
66458 540 CONTINUE
66459 550 CONTINUE
66460
66461C...Junction strings: solve (m2, Gamma) equation system for energies.
66462 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
66463 IF(ABS(DHS1).LT.1D-4) GOTO 360
66464 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
66465 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
66466 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
66467 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
66468 & ABS(DHS1)-DHS2/DHS1)
66469 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
66470 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
66471 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
66472
66473C...Junction strings: step to new region if necessary.
66474 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
66475 P(IN(2)+2,4)=P(IN(2)+2,3)
66476 P(IN(2)+2,1)=1D0
66477 IN(2)=IN(2)+4
66478 IF(IN(2).GT.N+NR+4*NS) GOTO 360
66479 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
66480 P(IN(1)+2,4)=P(IN(1)+2,3)
66481 P(IN(1)+2,1)=0D0
66482 IN(1)=IN(1)+4
66483 ENDIF
66484 GOTO 480
66485 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
66486 P(IN(1)+2,4)=P(IN(1)+2,3)
66487 P(IN(1)+2,1)=0D0
66488 IN(1)=IN(1)+4
66489 GOTO 480
66490 ENDIF
66491
66492C...Junction strings: particle four-momentum, remainder, loop back.
66493 560 DO 570 J=1,4
66494 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
66495 & P(IN(2)+2,4)*P(IN(2),J)
66496 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
66497 570 CONTINUE
66498 IF(P(I,4).LT.P(I,5)) GOTO 360
66499 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
66500 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
66501 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
66502 KFL(1)=-KFL(3)
66503 PX(1)=-PX(3)
66504 PY(1)=-PY(3)
66505 GAM(1)=GAM(3)
66506 IF(IN(3).NE.IN(6)) THEN
66507 DO 580 J=1,4
66508 P(IN(6),J)=P(IN(3),J)
66509 P(IN(6)+1,J)=P(IN(3)+1,J)
66510 580 CONTINUE
66511 ENDIF
66512 DO 590 JQ=1,2
66513 IN(3+JQ)=IN(JQ)
66514 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
66515 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
66516 590 CONTINUE
66517 GOTO 430
66518 ENDIF
66519
66520C...Junction strings: save quantities left after each string.
66521 IF(IABS(KFL(1)).GT.10) GOTO 360
66522 600 I=I-1
66523 KFJH(IU)=KFL(1)
66524 DO 610 J=1,4
66525 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
66526 610 CONTINUE
66527
66528C...Junction strings: loopback if much unused energy in both strings.
66529 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
66530 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
66531 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
66532 620 CONTINUE
66533 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
66534 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
66535 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
66536 & .AND.NTRYER.LT.10) GOTO 320
66537
66538C...Junction strings: put together to new effective string endpoint.
66539 NJS(JT)=I-ISTA
66540 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
66541 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
66542 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
66543 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
66544 DO 630 J=1,4
66545 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
66546 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
66547 630 CONTINUE
66548 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
66549 & PJS(JT,3)**2))
66550 PJS(JT+2,5)=0D0
66551 640 CONTINUE
66552
66553C...Open versus closed strings. Choose breakup region for latter.
66554 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
66555 NS=MJU(2)-MJU(1)
66556 NB=MJU(1)-N
66557 ELSEIF(MJU(1).NE.0) THEN
66558 NS=N+NR-MJU(1)
66559 NB=MJU(1)-N
66560 ELSEIF(MJU(2).NE.0) THEN
66561 NS=MJU(2)-N
66562 NB=1
66563 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
66564 NS=NR-1
66565 NB=1
66566 ELSE
66567 NS=NR+1
66568 W2SUM=0D0
66569 DO 660 IS=1,NR
66570 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
66571 W2SUM=W2SUM+P(N+NR+IS,1)
66572 660 CONTINUE
66573 W2RAN=PYR(0)*W2SUM
66574 NB=0
66575 670 NB=NB+1
66576 W2SUM=W2SUM-P(N+NR+NB,1)
66577 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
66578 ENDIF
66579
66580C...Find longitudinal string directions (i.e. lightlike four-vectors).
66581 DO 700 IS=1,NS
66582 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
66583 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
66584 DO 680 J=1,5
66585 DP(1,J)=P(IS1,J)
66586 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
66587 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
66588 DP(2,J)=P(IS2,J)
66589 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
66590 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
66591 680 CONTINUE
66592 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
66593 & DP(1,2)**2-DP(1,3)**2))
66594 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
66595 & DP(2,2)**2-DP(2,3)**2))
66596 DP(3,5)=DFOUR(1,1)
66597 DP(4,5)=DFOUR(2,2)
66598 DHKC=DFOUR(1,2)
66599 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
66600 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
66601 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
66602 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
66603 IN1=N+NR+4*IS-3
66604 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
66605 DO 690 J=1,4
66606 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
66607 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
66608 690 CONTINUE
66609 700 CONTINUE
66610
66611C...Begin initialization: sum up energy, set starting position.
66612 ISAV=I
66613 MSTU91=MSTU(90)
66614 710 NTRY=NTRY+1
66615 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
66616 PARU12=4D0*PARU12
66617 PARU13=2D0*PARU13
66618 GOTO 140
66619 ELSEIF(NTRY.GT.100) THEN
66620 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
66621 IF(MSTU(21).GE.1) RETURN
66622 ENDIF
66623 I=ISAV
66624 MSTU(90)=MSTU91
66625 DO 730 J=1,4
66626 P(N+NRS,J)=0D0
66627 DO 720 IS=1,NR
66628 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
66629 720 CONTINUE
66630 730 CONTINUE
66631 DO 750 JT=1,2
66632 IRANK(JT)=0
66633 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
66634 IF(NS.GT.NR) IRANK(JT)=1
66635 IBARRK(JT)=0
66636 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
66637 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
66638 IN(3*JT+2)=IN(3*JT+1)+1
66639 IN(3*JT+3)=N+NR+4*NS+2*JT-1
66640 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
66641 P(IN1,1)=2-JT
66642 P(IN1,2)=JT-1
66643 P(IN1,3)=1D0
66644 740 CONTINUE
66645 750 CONTINUE
66646
66647C.. MOPS variables and switches
66648 NRVMO=0
66649 XBMO=1D0
66650 MSTU(121)=0
66651 MSTU(122)=0
66652
66653C...Initialize flavour and pT variables for open string.
66654 IF(NS.LT.NR) THEN
66655 PX(1)=0D0
66656 PY(1)=0D0
66657 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
66658 PX(2)=-PX(1)
66659 PY(2)=-PY(1)
66660 DO 760 JT=1,2
66661 KFL(JT)=K(IE(JT),2)
66662 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
66663 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
66664 MSTJ(93)=1
66665 PMQ(JT)=PYMASS(KFL(JT))
66666 GAM(JT)=0D0
66667 760 CONTINUE
66668
66669C...Closed string: random initial breakup flavour, pT and vertex.
66670 ELSE
66671 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
66672 IBMO=0
66673 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
66674C.. Closed string: first vertex diq attempt => enforced second
66675C.. vertex diq
66676 IF(IABS(KFL(1)).GT.10)THEN
66677 IBMO=1
66678 MSTU(121)=0
66679 GOTO 770
66680 ENDIF
66681 IF(IBMO.EQ.1) MSTU(121)=-1
66682 KFL(2)=-KFL(1)
66683 CALL PYPTDI(KFL(1),PX(1),PY(1))
66684 PX(2)=-PX(1)
66685 PY(2)=-PY(1)
66686 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
66687 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
66688 ZR=PR3/(Z*P(N+NR+1,5)**2)
66689 IF(ZR.GE.1D0) GOTO 780
66690 DO 790 JT=1,2
66691 MSTJ(93)=1
66692 PMQ(JT)=PYMASS(KFL(JT))
66693 GAM(JT)=PR3*(1D0-Z)/Z
66694 IN1=N+NR+3+4*(JT/2)*(NS-1)
66695 P(IN1,JT)=1D0-Z
66696 P(IN1,3-JT)=JT-1
66697 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
66698 P(IN1+1,JT)=ZR
66699 P(IN1+1,3-JT)=2-JT
66700 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
66701 790 CONTINUE
66702 ENDIF
66703C.. MOPS variables
66704 DO 800 JT=1,2
66705 XTMO(JT)=1D0
66706 PM2QMO(JT)=PMQ(JT)**2
66707 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
66708 800 CONTINUE
66709
66710C...Find initial transverse directions (i.e. spacelike four-vectors).
66711 DO 840 JT=1,2
66712 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
66713 IN1=IN(3*JT+1)
66714 IN3=IN(3*JT+3)
66715 DO 810 J=1,4
66716 DP(1,J)=P(IN1,J)
66717 DP(2,J)=P(IN1+1,J)
66718 DP(3,J)=0D0
66719 DP(4,J)=0D0
66720 810 CONTINUE
66721 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66722 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66723 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
66724 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
66725 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
66726 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
66727 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
66728 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
66729 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
66730 DHC12=DFOUR(1,2)
66731 DHCX1=DFOUR(3,1)/DHC12
66732 DHCX2=DFOUR(3,2)/DHC12
66733 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
66734 DHCY1=DFOUR(4,1)/DHC12
66735 DHCY2=DFOUR(4,2)/DHC12
66736 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
66737 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
66738 DO 820 J=1,4
66739 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
66740 P(IN3,J)=DP(3,J)
66741 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
66742 & DHCYX*DP(3,J))
66743 820 CONTINUE
66744 ELSE
66745 DO 830 J=1,4
66746 P(IN3+2,J)=P(IN3,J)
66747 P(IN3+3,J)=P(IN3+1,J)
66748 830 CONTINUE
66749 ENDIF
66750 840 CONTINUE
66751
66752C...Remove energy used up in junction string fragmentation.
66753 IF(MJU(1)+MJU(2).GT.0) THEN
66754 DO 860 JT=1,2
66755 IF(NJS(JT).EQ.0) GOTO 860
66756 DO 850 J=1,4
66757 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
66758 850 CONTINUE
66759 860 CONTINUE
66760 PARJST=PARJ(33)
66761 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
66762 WMIN=PARJST+PMQ(1)+PMQ(2)
66763 WREM2=FOUR(N+NRS,N+NRS)
66764 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
66765 NTRYWR=NTRYWR+1
66766 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
66767 GOTO 140
66768 ENDIF
66769 ENDIF
66770
66771C...Produce new particle: side, origin.
66772 870 I=I+1
66773 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
66774 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
66775 IF(MSTU(21).GE.1) RETURN
66776 ENDIF
66777C.. New side priority for popcorn systems
66778 IF(MSTU(121).LE.0)THEN
66779 JT=1.5D0+PYR(0)
66780 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
66781 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
66782 ENDIF
66783 JR=3-JT
66784 JS=3-2*JT
66785 IRANK(JT)=IRANK(JT)+1
66786 K(I,1)=1
66787 K(I,4)=0
66788 K(I,5)=0
66789
66790C...Generate flavour, hadron and pT.
66791 880 K(I,3)=IE(JT)
66792 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
66793 IF(K(I,2).EQ.0) GOTO 710
66794 MU90MO=MSTU(90)
66795 IF(MSTU(121).EQ.-1) GOTO 910
66796 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
66797 &IABS(KFL(3)).GT.10) THEN
66798 IF(PYR(0).GT.PARJ(19)) GOTO 880
66799 ENDIF
66800 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
66801 &K(I,3)=IJUORI(JT)
66802 P(I,5)=PYMASS(K(I,2))
66803 CALL PYPTDI(KFL(JT),PX(3),PY(3))
66804 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
66805
66806C...Final hadrons for small invariant mass.
66807 MSTJ(93)=1
66808 PMQ(3)=PYMASS(KFL(3))
66809 PARJST=PARJ(33)
66810 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
66811 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
66812 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
66813 &WMIN-0.5D0*PARJ(36)*PMQ(3)
66814 WREM2=FOUR(N+NRS,N+NRS)
66815 IF(WREM2.LT.0.10D0) GOTO 710
66816 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
66817 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
66818
66819C...Choose z, which gives Gamma. Shift z for heavy flavours.
66820 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
66821 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
66822 &MSTU(90).LT.8) THEN
66823 MSTU(90)=MSTU(90)+1
66824 MSTU(90+MSTU(90))=I
66825 PARU(90+MSTU(90))=Z
66826 ENDIF
66827 KFL1A=IABS(KFL(1))
66828 KFL2A=IABS(KFL(2))
66829 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
66830 &MOD(KFL2A/1000,10)).GE.4) THEN
66831 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
66832 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
66833 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
66834 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
66835 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
66836 ENDIF
66837 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
66838
66839C.. MOPS baryon model modification
66840 XTMO3=(1D0-Z)*XTMO(JT)
66841 IF(IABS(KFL(3)).LE.10) NRVMO=0
66842 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
66843 GTSTMO=1D0
66844 PTSTMO=1D0
66845 RTSTMO=PYR(0)
66846 IF(IABS(KFL(JT)).LE.10)THEN
66847 XBMO=MIN(XTMO3,1D0-(2D-10))
66848 GBMO=GAM(3)
66849 PMMO=0D0
66850 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
66851 GTSTMO=1D0-PARF(192)**PGMO
66852 ELSE
66853 IF(IRANK(JT).EQ.1) THEN
66854 GBMO=GAM(JT)
66855 PMMO=0D0
66856 XBMO=1D0
66857 ENDIF
66858 IF(XBMO.LT.1D0-(1D-10))THEN
66859 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
66860 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
66861 PGMO=PGNMO
66862 ENDIF
66863 IF(MSTJ(12).GE.5)THEN
66864 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
66865 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
66866 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
66867 PMMO=PMNMO
66868 ENDIF
66869 ENDIF
66870
66871C.. MOPS Accepting popcorn system hadron.
66872 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
66873 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
66874 NRVMO=I-N-NR
66875 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
66876 CALL PYERRM(11,
66877 & '(PYSTRF:) no more memory left in PYJETS')
66878 IF(MSTU(21).GE.1) RETURN
66879 ENDIF
66880 IMO=I
66881 KFLMO=KFL(JT)
66882 PMQMO=PMQ(JT)
66883 PXMO=PX(JT)
66884 PYMO=PY(JT)
66885 GAMMO=GAM(JT)
66886 IRMO=IRANK(JT)
66887 XMO=XTMO(JT)
66888 DO 900 J=1,9
66889 IF(J.LE.5) THEN
66890 DO 890 LINE=1,I-N-NR
66891 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
66892 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
66893 890 CONTINUE
66894 ENDIF
66895 INMO(J)=IN(J)
66896 900 CONTINUE
66897 ENDIF
66898 ELSE
66899C..Reject popcorn system, flag=-1 if enforcing new one
66900 MSTU(121)=-1
66901 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
66902 ENDIF
66903 ENDIF
66904
66905
66906C..Lift restoring string outside MOPS block
66907 910 IF(MSTU(121).LT.0) THEN
66908 IF(MSTU(121).EQ.-2) MSTU(121)=0
66909 MSTU(90)=MU90MO
66910 NRVMO=0
66911 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
66912 I=IMO
66913 KFL(JT)=KFLMO
66914 PMQ(JT)=PMQMO
66915 PX(JT)=PXMO
66916 PY(JT)=PYMO
66917 GAM(JT)=GAMMO
66918 IRANK(JT)=IRMO
66919 XTMO(JT)=XMO
66920 DO 930 J=1,9
66921 IF(J.LE.5) THEN
66922 DO 920 LINE=1,I-N-NR
66923 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
66924 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
66925 920 CONTINUE
66926 ENDIF
66927 IN(J)=INMO(J)
66928 930 CONTINUE
66929 GOTO 880
66930 ENDIF
66931 XTMO(JT)=XTMO3
66932C.. MOPS end of modification
66933
66934 DO 940 J=1,3
66935 IN(J)=IN(3*JT+J)
66936 940 CONTINUE
66937
66938C...Stepping within or from 'low' string region easy.
66939 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
66940 &P(IN(1),5)**2.GE.PR(JT)) THEN
66941 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
66942 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
66943 DO 950 J=1,4
66944 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
66945 950 CONTINUE
66946 GOTO 1040
66947 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
66948 P(IN(JR)+2,4)=P(IN(JR)+2,3)
66949 P(IN(JR)+2,JT)=1D0
66950 IN(JR)=IN(JR)+4*JS
66951 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
66952 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
66953 P(IN(JT)+2,4)=P(IN(JT)+2,3)
66954 P(IN(JT)+2,JT)=0D0
66955 IN(JT)=IN(JT)+4*JS
66956 ENDIF
66957 ENDIF
66958
66959C...Find new transverse directions (i.e. spacelike string vectors).
66960 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
66961 &IN(1).GT.IN(2)) GOTO 710
66962 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
66963 DO 970 J=1,4
66964 DP(1,J)=P(IN(1),J)
66965 DP(2,J)=P(IN(2),J)
66966 DP(3,J)=0D0
66967 DP(4,J)=0D0
66968 970 CONTINUE
66969 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66970 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66971 DHC12=DFOUR(1,2)
66972 IF(DHC12.LE.1D-2) THEN
66973 P(IN(JT)+2,4)=P(IN(JT)+2,3)
66974 P(IN(JT)+2,JT)=0D0
66975 IN(JT)=IN(JT)+4*JS
66976 GOTO 960
66977 ENDIF
66978 IN(3)=N+NR+4*NS+5
66979 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
66980 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
66981 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
66982 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
66983 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
66984 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
66985 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
66986 DHCX1=DFOUR(3,1)/DHC12
66987 DHCX2=DFOUR(3,2)/DHC12
66988 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
66989 DHCY1=DFOUR(4,1)/DHC12
66990 DHCY2=DFOUR(4,2)/DHC12
66991 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
66992 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
66993 DO 980 J=1,4
66994 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
66995 P(IN(3),J)=DP(3,J)
66996 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
66997 & DHCYX*DP(3,J))
66998 980 CONTINUE
66999C...Express pT with respect to new axes, if sensible.
67000 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
67001 & FOUR(IN(3*JT+3)+1,IN(3)))
67002 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
67003 & FOUR(IN(3*JT+3)+1,IN(3)+1))
67004 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
67005 PX(3)=PXP
67006 PY(3)=PYP
67007 ENDIF
67008 ENDIF
67009
67010C...Sum up known four-momentum. Gives coefficients for m2 expression.
67011 DO 1010 J=1,4
67012 DHG(J)=0D0
67013 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
67014 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
67015 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
67016 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
67017 990 CONTINUE
67018 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
67019 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
67020 1000 CONTINUE
67021 1010 CONTINUE
67022 DHM(1)=FOUR(I,I)
67023 DHM(2)=2D0*FOUR(I,IN(1))
67024 DHM(3)=2D0*FOUR(I,IN(2))
67025 DHM(4)=2D0*FOUR(IN(1),IN(2))
67026
67027C...Find coefficients for Gamma expression.
67028 DO 1030 IN2=IN(1)+1,IN(2),4
67029 DO 1020 IN1=IN(1),IN2-1,4
67030 DHC=2D0*FOUR(IN1,IN2)
67031 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
67032 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
67033 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
67034 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
67035 1020 CONTINUE
67036 1030 CONTINUE
67037
67038C...Solve (m2, Gamma) equation system for energies taken.
67039 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
67040 IF(ABS(DHS1).LT.1D-4) GOTO 710
67041 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
67042 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
67043 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
67044 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
67045 &ABS(DHS1)-DHS2/DHS1)
67046 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
67047 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
67048 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
67049
67050C...Step to new region if necessary.
67051 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
67052 P(IN(JR)+2,4)=P(IN(JR)+2,3)
67053 P(IN(JR)+2,JT)=1D0
67054 IN(JR)=IN(JR)+4*JS
67055 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
67056 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
67057 P(IN(JT)+2,4)=P(IN(JT)+2,3)
67058 P(IN(JT)+2,JT)=0D0
67059 IN(JT)=IN(JT)+4*JS
67060 ENDIF
67061 GOTO 960
67062 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
67063 P(IN(JT)+2,4)=P(IN(JT)+2,3)
67064 P(IN(JT)+2,JT)=0D0
67065 IN(JT)=IN(JT)+4*JS
67066 GOTO 960
67067 ENDIF
67068
67069C...Four-momentum of particle. Remaining quantities. Loop back.
67070 1040 DO 1050 J=1,4
67071 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
67072 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
67073 1050 CONTINUE
67074 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
67075 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
67076 &GOTO 200
67077 IF(P(I,4).LT.P(I,5)) GOTO 710
67078 KFL(JT)=-KFL(3)
67079 PMQ(JT)=PMQ(3)
67080 PX(JT)=-PX(3)
67081 PY(JT)=-PY(3)
67082 GAM(JT)=GAM(3)
67083 IF(IN(3).NE.IN(3*JT+3)) THEN
67084 DO 1060 J=1,4
67085 P(IN(3*JT+3),J)=P(IN(3),J)
67086 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
67087 1060 CONTINUE
67088 ENDIF
67089 DO 1070 JQ=1,2
67090 IN(3*JT+JQ)=IN(JQ)
67091 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
67092 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
67093 1070 CONTINUE
67094 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
67095 &IBARRK(JT)=0
67096 GOTO 870
67097
67098C...Final hadron: side, flavour, hadron, mass.
67099 1080 I=I+1
67100 K(I,1)=1
67101 K(I,3)=IE(JR)
67102 K(I,4)=0
67103 K(I,5)=0
67104 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
67105 IF(K(I,2).EQ.0) GOTO 710
67106 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
67107 &IBARRK(JT)=0
67108 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
67109 &K(I,3)=IJUORI(JT)
67110 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
67111 &K(I,3)=IJUORI(JR)
67112 P(I,5)=PYMASS(K(I,2))
67113 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
67114
67115C...Final two hadrons: find common setup of four-vectors.
67116 JQ=1
67117 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
67118 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
67119 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
67120 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
67121 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
67122 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
67123 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
67124 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
67125 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
67126 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
67127 ENDIF
67128
67129C...Solve kinematics for final two hadrons, if possible.
67130 WREM2=2D0*DHR1*DHR2*DHC12
67131 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
67132 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
67133 IF(FD.GE.1D0) GOTO 710
67134 FA=WREM2+PR(JT)-PR(JR)
67135 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
67136 PREVCF=PARJ(42)
67137 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
67138 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
67139 FB=SIGN(FB,JS*(PYR(0)-PREV))
67140 KFL1A=IABS(KFL(1))
67141 KFL2A=IABS(KFL(2))
67142 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
67143 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
67144 &4D0*WREM2*PR(JT))),DBLE(JS))
67145 DO 1090 J=1,4
67146 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
67147 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
67148 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
67149 P(I,J)=P(N+NRS,J)-P(I-1,J)
67150 1090 CONTINUE
67151 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
67152 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
67153 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
67154 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
67155 NTRYFN=NTRYFN+1
67156 IF(NTRYFN.LT.100) GOTO 140
67157 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
67158 ENDIF
67159
67160C...Mark jets as fragmented and give daughter pointers.
67161 N=I-NRS+1
67162 DO 1100 I=NSAV+1,NSAV+NP
67163 IM=K(I,3)
67164 K(IM,1)=K(IM,1)+10
67165 IF(MSTU(16).NE.2) THEN
67166 K(IM,4)=NSAV+1
67167 K(IM,5)=NSAV+1
67168 ELSE
67169 K(IM,4)=NSAV+2
67170 K(IM,5)=N
67171 ENDIF
67172 1100 CONTINUE
67173
67174C...Document string system. Move up particles.
67175 NSAV=NSAV+1
67176 K(NSAV,1)=11
67177 K(NSAV,2)=92
67178 K(NSAV,3)=IP
67179 K(NSAV,4)=NSAV+1
67180 K(NSAV,5)=N
67181 DO 1110 J=1,4
67182 P(NSAV,J)=DPS(J)
67183 V(NSAV,J)=V(IP,J)
67184 1110 CONTINUE
67185 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
67186 V(NSAV,5)=0D0
67187 DO 1130 I=NSAV+1,N
67188 DO 1120 J=1,5
67189 K(I,J)=K(I+NRS-1,J)
67190 P(I,J)=P(I+NRS-1,J)
67191 V(I,J)=0D0
67192 1120 CONTINUE
67193 1130 CONTINUE
67194 MSTU91=MSTU(90)
67195 DO 1140 IZ=MSTU90+1,MSTU91
67196 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
67197 PARU9T(IZ)=PARU(90+IZ)
67198 1140 CONTINUE
67199 MSTU(90)=MSTU90
67200
67201C...Order particles in rank along the chain. Update mother pointer.
67202 DO 1160 I=NSAV+1,N
67203 DO 1150 J=1,5
67204 K(I-NSAV+N,J)=K(I,J)
67205 P(I-NSAV+N,J)=P(I,J)
67206 1150 CONTINUE
67207 1160 CONTINUE
67208 I1=NSAV
67209 DO 1190 I=N+1,2*N-NSAV
67210 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
67211 I1=I1+1
67212 DO 1170 J=1,5
67213 K(I1,J)=K(I,J)
67214 P(I1,J)=P(I,J)
67215 1170 CONTINUE
67216 IF(MSTU(16).NE.2) K(I1,3)=NSAV
67217 DO 1180 IZ=MSTU90+1,MSTU91
67218 IF(MSTU9T(IZ).EQ.I) THEN
67219 MSTU(90)=MSTU(90)+1
67220 MSTU(90+MSTU(90))=I1
67221 PARU(90+MSTU(90))=PARU9T(IZ)
67222 ENDIF
67223 1180 CONTINUE
67224 1190 CONTINUE
67225 DO 1220 I=2*N-NSAV,N+1,-1
67226 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
67227 I1=I1+1
67228 DO 1200 J=1,5
67229 K(I1,J)=K(I,J)
67230 P(I1,J)=P(I,J)
67231 1200 CONTINUE
67232 IF(MSTU(16).NE.2) K(I1,3)=NSAV
67233 DO 1210 IZ=MSTU90+1,MSTU91
67234 IF(MSTU9T(IZ).EQ.I) THEN
67235 MSTU(90)=MSTU(90)+1
67236 MSTU(90+MSTU(90))=I1
67237 PARU(90+MSTU(90))=PARU9T(IZ)
67238 ENDIF
67239 1210 CONTINUE
67240 1220 CONTINUE
67241
67242C...Boost back particle system. Set production vertices.
67243 IF(MBST.EQ.0) THEN
67244 MSTU(33)=1
67245 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
67246 & DPS(3)/DPS(4))
67247 ELSE
67248 DO 1230 I=NSAV+1,N
67249 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
67250 IF(P(I,3).GT.0D0) THEN
67251 HHPEZ=(P(I,4)+P(I,3))*HHBZ
67252 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
67253 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
67254 ELSE
67255 HHPEZ=(P(I,4)-P(I,3))/HHBZ
67256 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
67257 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
67258 ENDIF
67259 1230 CONTINUE
67260 ENDIF
67261 DO 1250 I=NSAV+1,N
67262 DO 1240 J=1,4
67263 V(I,J)=V(IP,J)
67264 1240 CONTINUE
67265 1250 CONTINUE
67266
67267 RETURN
67268 END
67269
67270C*********************************************************************
67271
67272C...PYJURF
67273C...From three given input vectors in PJU the boost VJU from
67274C...the "lab frame" to the junction rest frame is constructed.
67275
67276 SUBROUTINE PYJURF(PJU,VJU)
67277
67278C...Double precision and integer declarations.
67279 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67280 IMPLICIT INTEGER(I-N)
67281
67282C...Input, output and local arrays.
67283 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
67284 DATA TWOPI/6.283186D0/
67285
67286C...Calculate masses and other invariants.
67287 DO 100 J=1,4
67288 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
67289 100 CONTINUE
67290 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
67291 PSUM(5)=SQRT(PSUM2)
67292 DO 120 I=1,3
67293 DO 110 J=1,3
67294 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
67295 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
67296 110 CONTINUE
67297 120 CONTINUE
67298
67299C...Pick I to be most massive parton and J to be the one closest to I.
67300 ITRY=0
67301 I=1
67302 IF(A(2,2).GT.A(1,1)) I=2
67303 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
67304 130 ITRY=ITRY+1
67305 J=1+MOD(I,3)
67306 K=1+MOD(J,3)
67307 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
67308 K=1+MOD(I,3)
67309 J=1+MOD(K,3)
67310 ENDIF
67311 PMI2=A(I,I)
67312 PMJ2=A(J,J)
67313 PMK2=A(K,K)
67314 AIJ=A(I,J)
67315 AIK=A(I,K)
67316 AJK=A(J,K)
67317
67318C...Trivial find new parton energies if all three partons are massless.
67319 IF(PMI2.LT.1D-4) THEN
67320 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
67321 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
67322 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
67323
67324C...Else find momentum range for parton I and values at extremes.
67325 ELSE
67326 PAIMIN=0D0
67327 PEIMIN=SQRT(PMI2)
67328 PEJMIN=AIJ/PEIMIN
67329 PEKMIN=AIK/PEIMIN
67330 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
67331 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
67332 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
67333 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
67334 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
67335 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
67336 HI=PEIMAX**2-0.25D0*PAIMAX**2
67337 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
67338 & 0.5D0*PAIMAX*AIJ)/HI
67339 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
67340 & 0.5D0*PAIMAX*AIK)/HI
67341 PEJMAX=SQRT(PAJMAX**2+PMJ2)
67342 PEKMAX=SQRT(PAKMAX**2+PMK2)
67343 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
67344
67345C...If unexpected values at upper endpoint then pick another parton.
67346 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
67347 I1=1+MOD(I,3)
67348 IF(A(I1,I1).GE.1D-4) THEN
67349 I=I1
67350 GOTO 130
67351 ENDIF
67352 ITRY=ITRY+1
67353 I1=1+MOD(I,3)
67354 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
67355 I=I1
67356 GOTO 130
67357 ENDIF
67358 ENDIF
67359
67360C..Start binary + linear search to find solution inside range.
67361 ITER=0
67362 ITMIN=0
67363 ITMAX=0
67364 PAI=0.5D0*(PAIMIN+PAIMAX)
67365 140 ITER=ITER+1
67366
67367C...Derive momentum of other two partons and distance to root.
67368 PEI=SQRT(PAI**2+PMI2)
67369 HI=PEI**2-0.25D0*PAI**2
67370 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
67371 PEJ=SQRT(PAJ**2+PMJ2)
67372 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
67373 PEK=SQRT(PAK**2+PMK2)
67374 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
67375
67376C...Pick next I momentum to explore, hopefully closer to root.
67377 IF(FNOW.GT.0D0) THEN
67378 PAIMIN=PAI
67379 FMIN=FNOW
67380 ITMIN=ITMIN+1
67381 ELSE
67382 PAIMAX=PAI
67383 FMAX=FNOW
67384 ITMAX=ITMAX+1
67385 ENDIF
67386 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
67387 & THEN
67388 PAI=0.5D0*(PAIMIN+PAIMAX)
67389 GOTO 140
67390 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
67391 & ABS(FNOW).GT.1D-12*PSUM2) THEN
67392 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
67393 GOTO 140
67394 ENDIF
67395 ENDIF
67396
67397C...Now know energies in junction rest frame.
67398 PENEW(I)=PEI
67399 PENEW(J)=PEJ
67400 PENEW(K)=PEK
67401
67402C...Boost (copy of) partons to their rest frame.
67403 VXCM=-PSUM(1)/PSUM(5)
67404 VYCM=-PSUM(2)/PSUM(5)
67405 VZCM=-PSUM(3)/PSUM(5)
67406 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
67407 DO 150 I=1,3
67408 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
67409 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
67410 PCM(I,1)=PJU(I,1)+FAC2*VXCM
67411 PCM(I,2)=PJU(I,2)+FAC2*VYCM
67412 PCM(I,3)=PJU(I,3)+FAC2*VZCM
67413 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
67414 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
67415 150 CONTINUE
67416
67417C...Construct difference vectors and boost to junction rest frame.
67418 DO 160 J=1,3
67419 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
67420 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
67421 160 CONTINUE
67422 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
67423 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
67424 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
67425 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
67426 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
67427 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
67428 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
67429 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
67430 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
67431 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
67432 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
67433
67434C...Add two boosts, giving final result.
67435 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
67436 VJU(1)=VXJU+FCM*VXCM
67437 VJU(2)=VYJU+FCM*VYCM
67438 VJU(3)=VZJU+FCM*VZCM
67439 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
67440 VJU(5)=1D0
67441
67442C...In case of error in reconstruction: revert to CM frame of system.
67443 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
67444 &(PCM(1,5)*PCM(2,5))
67445 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
67446 &(PCM(1,5)*PCM(3,5))
67447 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
67448 &(PCM(2,5)*PCM(3,5))
67449 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
67450 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
67451 DO 170 I=1,3
67452 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
67453 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
67454 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
67455 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
67456 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
67457 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
67458 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
67459 170 CONTINUE
67460 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
67461 &(PCM(1,5)*PCM(2,5))
67462 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
67463 &(PCM(1,5)*PCM(3,5))
67464 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
67465 &(PCM(2,5)*PCM(3,5))
67466 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
67467 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
67468 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
67469 VJU(1)=VXCM
67470 VJU(2)=VYCM
67471 VJU(3)=VZCM
67472 VJU(4)=GAMCM
67473 ENDIF
67474
67475 RETURN
67476 END
67477
67478C*********************************************************************
67479
67480C...PYINDF
67481C...Handles the fragmentation of a jet system (or a single
67482C...jet) according to independent fragmentation models.
67483
67484 SUBROUTINE PYINDF(IP)
67485
67486C...Double precision and integer declarations.
67487 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67488 IMPLICIT INTEGER(I-N)
67489 INTEGER PYK,PYCHGE,PYCOMP
67490C...Commonblocks.
67491 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
67492 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67493 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67494 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
67495C...Local arrays.
67496 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
67497 &KFLO(2),PXO(2),PYO(2),WO(2)
67498
67499C.. MOPS error message
67500 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
67501 &' are not treated as expected in independent fragmentation')
67502
67503C...Reset counters. Identify parton system and take copy. Check flavour.
67504 NSAV=N
67505 MSTU90=MSTU(90)
67506 NJET=0
67507 KQSUM=0
67508 DO 100 J=1,5
67509 DPS(J)=0D0
67510 100 CONTINUE
67511 I=IP-1
67512 110 I=I+1
67513 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
67514 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
67515 IF(MSTU(21).GE.1) RETURN
67516 ENDIF
67517 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
67518 KC=PYCOMP(K(I,2))
67519 IF(KC.EQ.0) GOTO 110
67520 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
67521 IF(KQ.EQ.0) GOTO 110
67522 NJET=NJET+1
67523 IF(KQ.NE.2) KQSUM=KQSUM+KQ
67524 DO 120 J=1,5
67525 K(NSAV+NJET,J)=K(I,J)
67526 P(NSAV+NJET,J)=P(I,J)
67527 DPS(J)=DPS(J)+P(I,J)
67528 120 CONTINUE
67529 K(NSAV+NJET,3)=I
67530 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
67531 &K(I+1,1).EQ.2)) GOTO 110
67532 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
67533 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
67534 IF(MSTU(21).GE.1) RETURN
67535 ENDIF
67536
67537C...Boost copied system to CM frame. Find CM energy and sum flavours.
67538 IF(NJET.NE.1) THEN
67539 MSTU(33)=1
67540 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
67541 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
67542 ENDIF
67543 PECM=0D0
67544 DO 130 J=1,3
67545 NFI(J)=0
67546 130 CONTINUE
67547 DO 140 I=NSAV+1,NSAV+NJET
67548 PECM=PECM+P(I,4)
67549 KFA=IABS(K(I,2))
67550 IF(KFA.LE.3) THEN
67551 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
67552 ELSEIF(KFA.GT.1000) THEN
67553 KFLA=MOD(KFA/1000,10)
67554 KFLB=MOD(KFA/100,10)
67555 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
67556 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
67557 ENDIF
67558 140 CONTINUE
67559
67560C...Loop over attempts made. Reset counters.
67561 NTRY=0
67562 150 NTRY=NTRY+1
67563 IF(NTRY.GT.200) THEN
67564 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
67565 IF(MSTU(21).GE.1) RETURN
67566 ENDIF
67567 N=NSAV+NJET
67568 MSTU(90)=MSTU90
67569 DO 160 J=1,3
67570 NFL(J)=NFI(J)
67571 IFET(J)=0
67572 KFLF(J)=0
67573 160 CONTINUE
67574
67575C...Loop over jets to be fragmented.
67576 DO 230 IP1=NSAV+1,NSAV+NJET
67577 MSTJ(91)=0
67578 NSAV1=N
67579 MSTU91=MSTU(90)
67580
67581C...Initial flavour and momentum values. Jet along +z axis.
67582 KFLH=IABS(K(IP1,2))
67583 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
67584 KFLO(2)=0
67585 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
67586
67587C...Initial values for quark or diquark jet.
67588 170 IF(IABS(K(IP1,2)).NE.21) THEN
67589 NSTR=1
67590 KFLO(1)=K(IP1,2)
67591 CALL PYPTDI(0,PXO(1),PYO(1))
67592 WO(1)=WF
67593
67594C...Initial values for gluon treated like random quark jet.
67595 ELSEIF(MSTJ(2).LE.2) THEN
67596 NSTR=1
67597 IF(MSTJ(2).EQ.2) MSTJ(91)=1
67598 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
67599 CALL PYPTDI(0,PXO(1),PYO(1))
67600 WO(1)=WF
67601
67602C...Initial values for gluon treated like quark-antiquark jet pair,
67603C...sharing energy according to Altarelli-Parisi splitting function.
67604 ELSE
67605 NSTR=2
67606 IF(MSTJ(2).EQ.4) MSTJ(91)=1
67607 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
67608 KFLO(2)=-KFLO(1)
67609 CALL PYPTDI(0,PXO(1),PYO(1))
67610 PXO(2)=-PXO(1)
67611 PYO(2)=-PYO(1)
67612 WO(1)=WF*PYR(0)**(1D0/3D0)
67613 WO(2)=WF-WO(1)
67614 ENDIF
67615
67616C...Initial values for rank, flavour, pT and W+.
67617 DO 220 ISTR=1,NSTR
67618 180 I=N
67619 MSTU(90)=MSTU91
67620 IRANK=0
67621 KFL1=KFLO(ISTR)
67622 PX1=PXO(ISTR)
67623 PY1=PYO(ISTR)
67624 W=WO(ISTR)
67625
67626C...New hadron. Generate flavour and hadron species.
67627 190 I=I+1
67628 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
67629 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
67630 IF(MSTU(21).GE.1) RETURN
67631 ENDIF
67632 IRANK=IRANK+1
67633 K(I,1)=1
67634 K(I,3)=IP1
67635 K(I,4)=0
67636 K(I,5)=0
67637 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
67638 IF(K(I,2).EQ.0) GOTO 180
67639 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
67640 IF(PYR(0).GT.PARJ(19)) GOTO 200
67641 ENDIF
67642
67643C...Find hadron mass. Generate four-momentum.
67644 P(I,5)=PYMASS(K(I,2))
67645 CALL PYPTDI(KFL1,PX2,PY2)
67646 P(I,1)=PX1+PX2
67647 P(I,2)=PY1+PY2
67648 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
67649 CALL PYZDIS(KFL1,KFL2,PR,Z)
67650 MZSAV=0
67651 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
67652 MZSAV=1
67653 MSTU(90)=MSTU(90)+1
67654 MSTU(90+MSTU(90))=I
67655 PARU(90+MSTU(90))=Z
67656 ENDIF
67657 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
67658 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
67659 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
67660 & P(I,3).LE.0.001D0) THEN
67661 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
67662 P(I,3)=0.0001D0
67663 P(I,4)=SQRT(PR)
67664 Z=P(I,4)/W
67665 ENDIF
67666
67667C...Remaining flavour and momentum.
67668 KFL1=-KFL2
67669 PX1=-PX2
67670 PY1=-PY2
67671 W=(1D0-Z)*W
67672 DO 210 J=1,5
67673 V(I,J)=0D0
67674 210 CONTINUE
67675
67676C...Check if pL acceptable. Go back for new hadron if enough energy.
67677 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
67678 I=I-1
67679 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
67680 ENDIF
67681 IF(W.GT.PARJ(31)) GOTO 190
67682 N=I
67683 220 CONTINUE
67684 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
67685 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
67686
67687C...Rotate jet to new direction.
67688 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
67689 PHI=PYANGL(P(IP1,1),P(IP1,2))
67690 MSTU(33)=1
67691 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
67692 K(K(IP1,3),4)=NSAV1+1
67693 K(K(IP1,3),5)=N
67694
67695C...End of jet generation loop. Skip conservation in some cases.
67696 230 CONTINUE
67697 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
67698 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
67699
67700C...Subtract off produced hadron flavours, finished if zero.
67701 DO 240 I=NSAV+NJET+1,N
67702 KFA=IABS(K(I,2))
67703 KFLA=MOD(KFA/1000,10)
67704 KFLB=MOD(KFA/100,10)
67705 KFLC=MOD(KFA/10,10)
67706 IF(KFLA.EQ.0) THEN
67707 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
67708 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
67709 ELSE
67710 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
67711 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
67712 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
67713 ENDIF
67714 240 CONTINUE
67715 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
67716 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
67717 IF(NREQ.EQ.0) GOTO 320
67718
67719C...Take away flavour of low-momentum particles until enough freedom.
67720 NREM=0
67721 250 IREM=0
67722 P2MIN=PECM**2
67723 DO 260 I=NSAV+NJET+1,N
67724 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
67725 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
67726 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
67727 260 CONTINUE
67728 IF(IREM.EQ.0) GOTO 150
67729 K(IREM,1)=7
67730 KFA=IABS(K(IREM,2))
67731 KFLA=MOD(KFA/1000,10)
67732 KFLB=MOD(KFA/100,10)
67733 KFLC=MOD(KFA/10,10)
67734 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
67735 IF(K(IREM,1).EQ.8) GOTO 250
67736 IF(KFLA.EQ.0) THEN
67737 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
67738 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
67739 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
67740 ELSE
67741 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
67742 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
67743 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
67744 ENDIF
67745 NREM=NREM+1
67746 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
67747 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
67748 IF(NREQ.GT.NREM) GOTO 250
67749 DO 270 I=NSAV+NJET+1,N
67750 IF(K(I,1).EQ.8) K(I,1)=1
67751 270 CONTINUE
67752
67753C...Find combination of existing and new flavours for hadron.
67754 280 NFET=2
67755 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
67756 IF(NREQ.LT.NREM) NFET=1
67757 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
67758 DO 290 J=1,NFET
67759 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
67760 KFLF(J)=ISIGN(1,NFL(1))
67761 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
67762 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
67763 290 CONTINUE
67764 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
67765 &GOTO 280
67766 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
67767 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
67768 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
67769 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
67770 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
67771 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
67772 IF(NFET.LE.2) KFLF(3)=0
67773 IF(KFLF(3).NE.0) THEN
67774 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
67775 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
67776 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
67777 & KFLFC=KFLFC+ISIGN(2,KFLFC)
67778 ELSE
67779 KFLFC=KFLF(1)
67780 ENDIF
67781 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
67782 IF(KF.EQ.0) GOTO 280
67783 DO 300 J=1,MAX(2,NFET)
67784 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
67785 300 CONTINUE
67786
67787C...Store hadron at random among free positions.
67788 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
67789 DO 310 I=NSAV+NJET+1,N
67790 IF(K(I,1).EQ.7) NPOS=NPOS-1
67791 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
67792 K(I,1)=1
67793 K(I,2)=KF
67794 P(I,5)=PYMASS(K(I,2))
67795 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
67796 310 CONTINUE
67797 NREM=NREM-1
67798 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
67799 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
67800 IF(NREM.GT.0) GOTO 280
67801
67802C...Compensate for missing momentum in global scheme (3 options).
67803 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
67804 DO 340 J=1,3
67805 PSI(J)=0D0
67806 DO 330 I=NSAV+NJET+1,N
67807 PSI(J)=PSI(J)+P(I,J)
67808 330 CONTINUE
67809 340 CONTINUE
67810 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
67811 PWS=0D0
67812 DO 350 I=NSAV+NJET+1,N
67813 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
67814 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
67815 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
67816 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
67817 350 CONTINUE
67818 DO 370 I=NSAV+NJET+1,N
67819 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
67820 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
67821 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
67822 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
67823 DO 360 J=1,3
67824 P(I,J)=P(I,J)-PSI(J)*PW/PWS
67825 360 CONTINUE
67826 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
67827 370 CONTINUE
67828
67829C...Compensate for missing momentum withing each jet separately.
67830 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
67831 DO 390 I=N+1,N+NJET
67832 K(I,1)=0
67833 DO 380 J=1,5
67834 P(I,J)=0D0
67835 380 CONTINUE
67836 390 CONTINUE
67837 DO 410 I=NSAV+NJET+1,N
67838 IR1=K(I,3)
67839 IR2=N+IR1-NSAV
67840 K(IR2,1)=K(IR2,1)+1
67841 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
67842 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
67843 DO 400 J=1,3
67844 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
67845 400 CONTINUE
67846 P(IR2,4)=P(IR2,4)+P(I,4)
67847 P(IR2,5)=P(IR2,5)+PLS
67848 410 CONTINUE
67849 PSS=0D0
67850 DO 420 I=N+1,N+NJET
67851 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
67852 420 CONTINUE
67853 DO 440 I=NSAV+NJET+1,N
67854 IR1=K(I,3)
67855 IR2=N+IR1-NSAV
67856 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
67857 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
67858 DO 430 J=1,3
67859 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
67860 & PLS*P(IR1,J)
67861 430 CONTINUE
67862 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
67863 440 CONTINUE
67864 ENDIF
67865
67866C...Scale momenta for energy conservation.
67867 IF(MOD(MSTJ(3),5).NE.0) THEN
67868 PMS=0D0
67869 PES=0D0
67870 PQS=0D0
67871 DO 450 I=NSAV+NJET+1,N
67872 PMS=PMS+P(I,5)
67873 PES=PES+P(I,4)
67874 PQS=PQS+P(I,5)**2/P(I,4)
67875 450 CONTINUE
67876 IF(PMS.GE.PECM) GOTO 150
67877 NECO=0
67878 460 NECO=NECO+1
67879 PFAC=(PECM-PQS)/(PES-PQS)
67880 PES=0D0
67881 PQS=0D0
67882 DO 480 I=NSAV+NJET+1,N
67883 DO 470 J=1,3
67884 P(I,J)=PFAC*P(I,J)
67885 470 CONTINUE
67886 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
67887 PES=PES+P(I,4)
67888 PQS=PQS+P(I,5)**2/P(I,4)
67889 480 CONTINUE
67890 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
67891 ENDIF
67892
67893C...Origin of produced particles and parton daughter pointers.
67894 490 DO 500 I=NSAV+NJET+1,N
67895 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
67896 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
67897 500 CONTINUE
67898 DO 510 I=NSAV+1,NSAV+NJET
67899 I1=K(I,3)
67900 K(I1,1)=K(I1,1)+10
67901 IF(MSTU(16).NE.2) THEN
67902 K(I1,4)=NSAV+1
67903 K(I1,5)=NSAV+1
67904 ELSE
67905 K(I1,4)=K(I1,4)-NJET+1
67906 K(I1,5)=K(I1,5)-NJET+1
67907 IF(K(I1,5).LT.K(I1,4)) THEN
67908 K(I1,4)=0
67909 K(I1,5)=0
67910 ENDIF
67911 ENDIF
67912 510 CONTINUE
67913
67914C...Document independent fragmentation system. Remove copy of jets.
67915 NSAV=NSAV+1
67916 K(NSAV,1)=11
67917 K(NSAV,2)=93
67918 K(NSAV,3)=IP
67919 K(NSAV,4)=NSAV+1
67920 K(NSAV,5)=N-NJET+1
67921 DO 520 J=1,4
67922 P(NSAV,J)=DPS(J)
67923 V(NSAV,J)=V(IP,J)
67924 520 CONTINUE
67925 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
67926 V(NSAV,5)=0D0
67927 DO 540 I=NSAV+NJET,N
67928 DO 530 J=1,5
67929 K(I-NJET+1,J)=K(I,J)
67930 P(I-NJET+1,J)=P(I,J)
67931 V(I-NJET+1,J)=V(I,J)
67932 530 CONTINUE
67933 540 CONTINUE
67934 N=N-NJET+1
67935 DO 550 IZ=MSTU90+1,MSTU(90)
67936 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
67937 550 CONTINUE
67938
67939C...Boost back particle system. Set production vertices.
67940 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
67941 &DPS(2)/DPS(4),DPS(3)/DPS(4))
67942 DO 570 I=NSAV+1,N
67943 DO 560 J=1,4
67944 V(I,J)=V(IP,J)
67945 560 CONTINUE
67946 570 CONTINUE
67947
67948 RETURN
67949 END
67950
67951C*********************************************************************
67952
67953C...PYDECY
67954C...Handles the decay of unstable particles.
67955
67956 SUBROUTINE PYDECY(IP)
67957
67958C...Double precision and integer declarations.
67959 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67960 IMPLICIT INTEGER(I-N)
67961 INTEGER PYK,PYCHGE,PYCOMP
67962C...Commonblocks.
67963 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
67964 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67965 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67966 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
67967 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
67968C...Local arrays.
67969 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
67970 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
67971 CHARACTER CIDC*4
67972 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
67973
67974C...Functions: momentum in two-particle decays and four-product.
67975 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
67976 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)
67977
67978C...Initial values.
67979 NTRY=0
67980 NSAV=N
67981 KFA=IABS(K(IP,2))
67982 KFS=ISIGN(1,K(IP,2))
67983 KC=PYCOMP(KFA)
67984 MSTJ(92)=0
67985
67986C...Choose lifetime and determine decay vertex.
67987 IF(K(IP,1).EQ.5) THEN
67988 V(IP,5)=0D0
67989 ELSEIF(K(IP,1).NE.4) THEN
67990 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
67991 ENDIF
67992 DO 100 J=1,4
67993 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
67994 100 CONTINUE
67995
67996C...Determine whether decay allowed or not.
67997 MOUT=0
67998 IF(MSTJ(22).EQ.2) THEN
67999 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
68000 ELSEIF(MSTJ(22).EQ.3) THEN
68001 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
68002 ELSEIF(MSTJ(22).EQ.4) THEN
68003 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
68004 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
68005 ENDIF
68006 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
68007 K(IP,1)=4
68008 RETURN
68009 ENDIF
68010
68011C...Interface to external tau decay library (for tau polarization).
68012 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
68013
68014C...Starting values for pointers and momenta.
68015 ITAU=IP
68016 DO 110 J=1,4
68017 PTAU(J)=P(ITAU,J)
68018 PCMTAU(J)=P(ITAU,J)
68019 110 CONTINUE
68020
68021C...Iterate to find position and code of mother of tau.
68022 IMTAU=ITAU
68023 120 IMTAU=K(IMTAU,3)
68024
68025 IF(IMTAU.EQ.0) THEN
68026C...If no known origin then impossible to do anything further.
68027 KFORIG=0
68028 IORIG=0
68029
68030 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
68031C...If tau -> tau + gamma then add gamma energy and loop.
68032 IF(K(K(IMTAU,4),2).EQ.22) THEN
68033 DO 130 J=1,4
68034 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
68035 130 CONTINUE
68036 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
68037 DO 140 J=1,4
68038 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
68039 140 CONTINUE
68040 ENDIF
68041 GOTO 120
68042
68043 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
68044C...If coming from weak decay of hadron then W is not stored in record,
68045C...but can be reconstructed by adding neutrino momentum.
68046 KFORIG=-ISIGN(24,K(ITAU,2))
68047 IORIG=0
68048 DO 160 II=K(IMTAU,4),K(IMTAU,5)
68049 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
68050 DO 150 J=1,4
68051 PCMTAU(J)=PCMTAU(J)+P(II,J)
68052 150 CONTINUE
68053 ENDIF
68054 160 CONTINUE
68055
68056 ELSE
68057C...If coming from resonance decay then find latest copy of this
68058C...resonance (may not completely agree).
68059 KFORIG=K(IMTAU,2)
68060 IORIG=IMTAU
68061 DO 170 II=IMTAU+1,IP-1
68062 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
68063 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
68064 170 CONTINUE
68065 DO 180 J=1,4
68066 PCMTAU(J)=P(IORIG,J)
68067 180 CONTINUE
68068 ENDIF
68069
68070C...Boost tau to rest frame of production process (where known)
68071C...and rotate it to sit along +z axis.
68072 DO 190 J=1,3
68073 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
68074 190 CONTINUE
68075 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
68076 & -DBETAU(2),-DBETAU(3))
68077 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
68078 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
68079 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
68080 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
68081
68082C...Call tau decay routine (if meaningful) and fill extra info.
68083 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
68084 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
68085 DO 200 II=NSAV+1,NSAV+NDECAY
68086 K(II,1)=1
68087 K(II,3)=IP
68088 K(II,4)=0
68089 K(II,5)=0
68090 200 CONTINUE
68091 N=NSAV+NDECAY
68092 ENDIF
68093
68094C...Boost back decay tau and decay products.
68095 DO 210 J=1,4
68096 P(ITAU,J)=PTAU(J)
68097 210 CONTINUE
68098 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
68099 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
68100 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
68101 & DBETAU(2),DBETAU(3))
68102
68103C...Skip past ordinary tau decay treatment.
68104 MMAT=0
68105 MBST=0
68106 ND=0
68107 GOTO 630
68108 ENDIF
68109 ENDIF
68110
68111C...B-Bbar mixing: flip sign of meson appropriately.
68112 MMIX=0
68113 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
68114 XBBMIX=PARJ(76)
68115 IF(KFA.EQ.531) XBBMIX=PARJ(77)
68116 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
68117 IF(MMIX.EQ.1) KFS=-KFS
68118 ENDIF
68119
68120C...Check existence of decay channels. Particle/antiparticle rules.
68121 KCA=KC
68122 IF(MDCY(KC,2).GT.0) THEN
68123 MDMDCY=MDME(MDCY(KC,2),2)
68124 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
68125 ENDIF
68126 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
68127 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
68128 RETURN
68129 ENDIF
68130 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
68131 IF(KCHG(KC,3).EQ.0) THEN
68132 KFSP=1
68133 KFSN=0
68134 IF(PYR(0).GT.0.5D0) KFS=-KFS
68135 ELSEIF(KFS.GT.0) THEN
68136 KFSP=1
68137 KFSN=0
68138 ELSE
68139 KFSP=0
68140 KFSN=1
68141 ENDIF
68142
68143C...Sum branching ratios of allowed decay channels.
68144 220 NOPE=0
68145 BRSU=0D0
68146 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
68147 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
68148 & KFSN*MDME(IDL,1).NE.3) GOTO 230
68149 IF(MDME(IDL,2).GT.100) GOTO 230
68150 NOPE=NOPE+1
68151 BRSU=BRSU+BRAT(IDL)
68152 230 CONTINUE
68153 IF(NOPE.EQ.0) THEN
68154 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
68155 RETURN
68156 ENDIF
68157
68158C...Select decay channel among allowed ones.
68159 240 RBR=BRSU*PYR(0)
68160 IDL=MDCY(KCA,2)-1
68161 250 IDL=IDL+1
68162 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
68163 &KFSN*MDME(IDL,1).NE.3) THEN
68164 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
68165 ELSEIF(MDME(IDL,2).GT.100) THEN
68166 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
68167 ELSE
68168 IDC=IDL
68169 RBR=RBR-BRAT(IDL)
68170 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
68171 ENDIF
68172
68173C...Start readout of decay channel: matrix element, reset counters.
68174 MMAT=MDME(IDC,2)
68175 260 NTRY=NTRY+1
68176 IF(MOD(NTRY,200).EQ.0) THEN
68177 WRITE(CIDC,'(I4)') IDC
68178C...Do not print warning for some well-known special cases.
68179 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
68180 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
68181 & CIDC)
68182 GOTO 240
68183 ENDIF
68184 IF(NTRY.GT.1000) THEN
68185 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
68186 IF(MSTU(21).GE.1) RETURN
68187 ENDIF
68188 I=N
68189 NP=0
68190 NQ=0
68191 MBST=0
68192 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
68193 DO 270 J=1,4
68194 PV(1,J)=0D0
68195 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
68196 270 CONTINUE
68197 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
68198 PV(1,5)=P(IP,5)
68199 PS=0D0
68200 PSQ=0D0
68201 MREM=0
68202 MHADDY=0
68203 IF(KFA.GT.80) MHADDY=1
68204C.. Random flavour and popcorn system memory.
68205 IRNDMO=0
68206 JTMO=0
68207 MSTU(121)=0
68208 MSTU(125)=10
68209
68210C...Read out decay products. Convert to standard flavour code.
68211 JTMAX=5
68212 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
68213 DO 280 JT=1,JTMAX
68214 IF(JT.LE.5) KP=KFDP(IDC,JT)
68215 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
68216 IF(KP.EQ.0) GOTO 280
68217 KPA=IABS(KP)
68218 KCP=PYCOMP(KPA)
68219 IF(KPA.GT.80) MHADDY=1
68220 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
68221 KFP=KP
68222 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
68223 KFP=KFS*KP
68224 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
68225 KFP=-KFS*MOD(KFA/10,10)
68226 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
68227 KFP=KFS*(100*MOD(KFA/10,100)+3)
68228 ELSEIF(KPA.EQ.81) THEN
68229 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
68230 ELSEIF(KP.EQ.82) THEN
68231 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
68232 IF(KFP.EQ.0) GOTO 260
68233 KFP=-KFP
68234 IRNDMO=1
68235 MSTJ(93)=1
68236 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
68237 ELSEIF(KP.EQ.-82) THEN
68238 KFP=MSTU(124)
68239 ENDIF
68240 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
68241
68242C...Add decay product to event record or to quark flavour list.
68243 KFPA=IABS(KFP)
68244 KQP=KCHG(KCP,2)
68245 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
68246 NQ=NQ+1
68247 KFLO(NQ)=KFP
68248C...set rndmflav popcorn system pointer
68249 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
68250 MSTJ(93)=2
68251 PSQ=PSQ+PYMASS(KFLO(NQ))
68252 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
68253 & MOD(NQ,2).EQ.1) THEN
68254 NQ=NQ-1
68255 PS=PS-P(I,5)
68256 K(I,1)=1
68257 KFI=K(I,2)
68258 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
68259 IF(K(I,2).EQ.0) GOTO 260
68260 MSTJ(93)=1
68261 P(I,5)=PYMASS(K(I,2))
68262 PS=PS+P(I,5)
68263 ELSE
68264 I=I+1
68265 NP=NP+1
68266 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
68267 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
68268 K(I,1)=1+MOD(NQ,2)
68269 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
68270 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
68271 K(I,2)=KFP
68272 K(I,3)=IP
68273 K(I,4)=0
68274 K(I,5)=0
68275 P(I,5)=PYMASS(KFP)
68276 PS=PS+P(I,5)
68277 ENDIF
68278 280 CONTINUE
68279
68280C...Check masses for resonance decays.
68281 IF(MHADDY.EQ.0) THEN
68282 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
68283 ENDIF
68284
68285C...Choose decay multiplicity in phase space model.
68286 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
68287 PSP=PS
68288 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
68289 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
68290 300 NTRY=NTRY+1
68291C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
68292 IF(IRNDMO.EQ.0) THEN
68293 MSTU(121)=0
68294 JTMO=0
68295 ELSEIF(IRNDMO.EQ.1) THEN
68296 IRNDMO=2
68297 ELSE
68298 GOTO 260
68299 ENDIF
68300 IF(NTRY.GT.1000) THEN
68301 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
68302 IF(MSTU(21).GE.1) RETURN
68303 ENDIF
68304 IF(MMAT.LE.20) THEN
68305 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
68306 & SIN(PARU(2)*PYR(0))
68307 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
68308 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
68309 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
68310 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
68311 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
68312 ELSE
68313 ND=MMAT-20
68314 ENDIF
68315C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
68316 MSTU(125)=ND-NQ/2
68317 IF(MSTU(121).GT.MSTU(125)) GOTO 300
68318
68319C...Form hadrons from flavour content.
68320 DO 310 JT=1,NQ
68321 KFL1(JT)=KFLO(JT)
68322 310 CONTINUE
68323 IF(ND.EQ.NP+NQ/2) GOTO 330
68324 DO 320 I=N+NP+1,N+ND-NQ/2
68325C.. Stick to started popcorn system, else pick side at random
68326 JT=JTMO
68327 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
68328 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
68329 IF(K(I,2).EQ.0) GOTO 300
68330 MSTU(125)=MSTU(125)-1
68331 JTMO=0
68332 IF(MSTU(121).GT.0) JTMO=JT
68333 KFL1(JT)=-KFL2
68334 320 CONTINUE
68335 330 JT=2
68336 JT2=3
68337 JT3=4
68338 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
68339 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
68340 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
68341 IF(JT.EQ.3) JT2=2
68342 IF(JT.EQ.4) JT3=2
68343 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
68344 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
68345 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
68346 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
68347
68348C...Check that sum of decay product masses not too large.
68349 PS=PSP
68350 DO 340 I=N+NP+1,N+ND
68351 K(I,1)=1
68352 K(I,3)=IP
68353 K(I,4)=0
68354 K(I,5)=0
68355 P(I,5)=PYMASS(K(I,2))
68356 PS=PS+P(I,5)
68357 340 CONTINUE
68358 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
68359
68360C...Rescale energy to subtract off spectator quark mass.
68361 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
68362 & .AND.NP.GE.3) THEN
68363 PS=PS-P(N+NP,5)
68364 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
68365 DO 350 J=1,5
68366 P(N+NP,J)=PQT*PV(1,J)
68367 PV(1,J)=(1D0-PQT)*PV(1,J)
68368 350 CONTINUE
68369 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
68370 ND=NP-1
68371 MREM=1
68372
68373C...Fully specified final state: check mass broadening effects.
68374 ELSE
68375 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
68376 ND=NP
68377 ENDIF
68378
68379C...Determine position of grandmother, number of sisters.
68380 NM=0
68381 KFAS=0
68382 MSGN=0
68383 IF(MMAT.EQ.3) THEN
68384 IM=K(IP,3)
68385 IF(IM.LT.0.OR.IM.GE.IP) IM=0
68386 IF(IM.NE.0) KFAM=IABS(K(IM,2))
68387 IF(IM.NE.0) THEN
68388 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
68389 IF(K(IL,3).EQ.IM) NM=NM+1
68390 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
68391 360 CONTINUE
68392 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
68393 & MOD(KFAM/1000,10).NE.0) NM=0
68394 IF(NM.EQ.2) THEN
68395 KFAS=IABS(K(ISIS,2))
68396 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
68397 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
68398 ENDIF
68399 ENDIF
68400 ENDIF
68401
68402C...Kinematics of one-particle decays.
68403 IF(ND.EQ.1) THEN
68404 DO 370 J=1,4
68405 P(N+1,J)=P(IP,J)
68406 370 CONTINUE
68407 GOTO 630
68408 ENDIF
68409
68410C...Calculate maximum weight ND-particle decay.
68411 PV(ND,5)=P(N+ND,5)
68412 IF(ND.GE.3) THEN
68413 WTMAX=1D0/WTCOR(ND-2)
68414 PMAX=PV(1,5)-PS+P(N+ND,5)
68415 PMIN=0D0
68416 DO 380 IL=ND-1,1,-1
68417 PMAX=PMAX+P(N+IL,5)
68418 PMIN=PMIN+P(N+IL+1,5)
68419 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
68420 380 CONTINUE
68421 ENDIF
68422
68423C...Find virtual gamma mass in Dalitz decay.
68424 390 IF(ND.EQ.2) THEN
68425 ELSEIF(MMAT.EQ.2) THEN
68426 PMES=4D0*PMAS(11,1)**2
68427 PMRHO2=PMAS(131,1)**2
68428 PGRHO2=PMAS(131,2)**2
68429 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
68430 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
68431 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
68432 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
68433 IF(WT.LT.PYR(0)) GOTO 400
68434 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
68435
68436C...M-generator gives weight. If rejected, try again.
68437 ELSE
68438 410 RORD(1)=1D0
68439 DO 440 IL1=2,ND-1
68440 RSAV=PYR(0)
68441 DO 420 IL2=IL1-1,1,-1
68442 IF(RSAV.LE.RORD(IL2)) GOTO 430
68443 RORD(IL2+1)=RORD(IL2)
68444 420 CONTINUE
68445 430 RORD(IL2+1)=RSAV
68446 440 CONTINUE
68447 RORD(ND)=0D0
68448 WT=1D0
68449 DO 450 IL=ND-1,1,-1
68450 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
68451 & (PV(1,5)-PS)
68452 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
68453 450 CONTINUE
68454 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
68455 ENDIF
68456
68457C...Perform two-particle decays in respective CM frame.
68458 460 DO 480 IL=1,ND-1
68459 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
68460 UE(3)=2D0*PYR(0)-1D0
68461 PHI=PARU(2)*PYR(0)
68462 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
68463 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
68464 DO 470 J=1,3
68465 P(N+IL,J)=PA*UE(J)
68466 PV(IL+1,J)=-PA*UE(J)
68467 470 CONTINUE
68468 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
68469 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
68470 480 CONTINUE
68471
68472C...Lorentz transform decay products to lab frame.
68473 DO 490 J=1,4
68474 P(N+ND,J)=PV(ND,J)
68475 490 CONTINUE
68476 DO 530 IL=ND-1,1,-1
68477 DO 500 J=1,3
68478 BE(J)=PV(IL,J)/PV(IL,4)
68479 500 CONTINUE
68480 GA=PV(IL,4)/PV(IL,5)
68481 DO 520 I=N+IL,N+ND
68482 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
68483 DO 510 J=1,3
68484 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
68485 510 CONTINUE
68486 P(I,4)=GA*(P(I,4)+BEP)
68487 520 CONTINUE
68488 530 CONTINUE
68489
68490C...Check that no infinite loop in matrix element weight.
68491 NTRY=NTRY+1
68492 IF(NTRY.GT.800) GOTO 560
68493
68494C...Matrix elements for omega and phi decays.
68495 IF(MMAT.EQ.1) THEN
68496 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
68497 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
68498 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
68499 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
68500
68501C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
68502 ELSEIF(MMAT.EQ.2) THEN
68503 FOUR12=FOUR(N+1,N+2)
68504 FOUR13=FOUR(N+1,N+3)
68505 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
68506 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
68507 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
68508
68509C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
68510C...V vector), of form cos**2(theta02) in V1 rest frame, and for
68511C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
68512 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
68513 FOUR10=FOUR(IP,IM)
68514 FOUR12=FOUR(IP,N+1)
68515 FOUR02=FOUR(IM,N+1)
68516 PMS1=P(IP,5)**2
68517 PMS0=P(IM,5)**2
68518 PMS2=P(N+1,5)**2
68519 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
68520 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
68521 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
68522 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
68523 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
68524 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
68525
68526C...Matrix element for "onium" -> g + g + g or gamma + g + g.
68527 ELSEIF(MMAT.EQ.4) THEN
68528 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
68529 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
68530 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
68531 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
68532 & ((1D0-HX3)/(HX1*HX2))**2
68533 IF(WT.LT.2D0*PYR(0)) GOTO 390
68534 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
68535 & GOTO 390
68536
68537C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
68538 ELSEIF(MMAT.EQ.41) THEN
68539 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
68540 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
68541 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
68542 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
68543
68544C...Matrix elements for weak decays (only semileptonic for c and b)
68545 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
68546 & .AND.ND.EQ.3) THEN
68547 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
68548 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
68549 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
68550 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
68551 DO 550 J=1,4
68552 P(N+NP+1,J)=0D0
68553 DO 540 IS=N+3,N+NP
68554 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
68555 540 CONTINUE
68556 550 CONTINUE
68557 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
68558 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
68559 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
68560 ENDIF
68561
68562C...Scale back energy and reattach spectator.
68563 560 IF(MREM.EQ.1) THEN
68564 DO 570 J=1,5
68565 PV(1,J)=PV(1,J)/(1D0-PQT)
68566 570 CONTINUE
68567 ND=ND+1
68568 MREM=0
68569 ENDIF
68570
68571C...Low invariant mass for system with spectator quark gives particle,
68572C...not two jets. Readjust momenta accordingly.
68573 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
68574 MSTJ(93)=1
68575 PM2=PYMASS(K(N+2,2))
68576 MSTJ(93)=1
68577 PM3=PYMASS(K(N+3,2))
68578 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
68579 & (PARJ(32)+PM2+PM3)**2) GOTO 630
68580 K(N+2,1)=1
68581 KFTEMP=K(N+2,2)
68582 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
68583 IF(K(N+2,2).EQ.0) GOTO 260
68584 P(N+2,5)=PYMASS(K(N+2,2))
68585 PS=P(N+1,5)+P(N+2,5)
68586 PV(2,5)=P(N+2,5)
68587 MMAT=0
68588 ND=2
68589 GOTO 460
68590 ELSEIF(MMAT.EQ.44) THEN
68591 MSTJ(93)=1
68592 PM3=PYMASS(K(N+3,2))
68593 MSTJ(93)=1
68594 PM4=PYMASS(K(N+4,2))
68595 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
68596 & (PARJ(32)+PM3+PM4)**2) GOTO 600
68597 K(N+3,1)=1
68598 KFTEMP=K(N+3,2)
68599 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
68600 IF(K(N+3,2).EQ.0) GOTO 260
68601 P(N+3,5)=PYMASS(K(N+3,2))
68602 DO 580 J=1,3
68603 P(N+3,J)=P(N+3,J)+P(N+4,J)
68604 580 CONTINUE
68605 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)
68606 HA=P(N+1,4)**2-P(N+2,4)**2
68607 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
68608 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
68609 & (P(N+1,3)-P(N+2,3))**2
68610 HD=(PV(1,4)-P(N+3,4))**2
68611 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
68612 HF=HD*HC-HB**2
68613 HG=HD*HC-HA*HB
68614 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
68615 DO 590 J=1,3
68616 PCOR=HH*(P(N+1,J)-P(N+2,J))
68617 P(N+1,J)=P(N+1,J)+PCOR
68618 P(N+2,J)=P(N+2,J)-PCOR
68619 590 CONTINUE
68620 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)
68621 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)
68622 ND=ND-1
68623 ENDIF
68624
68625C...Check invariant mass of W jets. May give one particle or start over.
68626 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
68627 &.AND.IABS(K(N+1,2)).LT.10) THEN
68628 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
68629 MSTJ(93)=1
68630 PM1=PYMASS(K(N+1,2))
68631 MSTJ(93)=1
68632 PM2=PYMASS(K(N+2,2))
68633 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
68634 KFLDUM=INT(1.5D0+PYR(0))
68635 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
68636 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
68637 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
68638 PSM=PYMASS(KF1)+PYMASS(KF2)
68639 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
68640 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
68641 IF(MMAT.EQ.48) GOTO 390
68642 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
68643 K(N+1,1)=1
68644 KFTEMP=K(N+1,2)
68645 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
68646 IF(K(N+1,2).EQ.0) GOTO 260
68647 P(N+1,5)=PYMASS(K(N+1,2))
68648 K(N+2,2)=K(N+3,2)
68649 P(N+2,5)=P(N+3,5)
68650 PS=P(N+1,5)+P(N+2,5)
68651 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
68652 PV(2,5)=P(N+3,5)
68653 MMAT=0
68654 ND=2
68655 GOTO 460
68656 ENDIF
68657
68658C...Phase space decay of partons from W decay.
68659 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
68660 KFLO(1)=K(N+1,2)
68661 KFLO(2)=K(N+2,2)
68662 K(N+1,1)=K(N+3,1)
68663 K(N+1,2)=K(N+3,2)
68664 DO 620 J=1,5
68665 PV(1,J)=P(N+1,J)+P(N+2,J)
68666 P(N+1,J)=P(N+3,J)
68667 620 CONTINUE
68668 PV(1,5)=PMR
68669 N=N+1
68670 NP=0
68671 NQ=2
68672 PS=0D0
68673 MSTJ(93)=2
68674 PSQ=PYMASS(KFLO(1))
68675 MSTJ(93)=2
68676 PSQ=PSQ+PYMASS(KFLO(2))
68677 MMAT=11
68678 GOTO 290
68679 ENDIF
68680
68681C...Boost back for rapidly moving particle.
68682 630 N=N+ND
68683 IF(MBST.EQ.1) THEN
68684 DO 640 J=1,3
68685 BE(J)=P(IP,J)/P(IP,4)
68686 640 CONTINUE
68687 GA=P(IP,4)/P(IP,5)
68688 DO 660 I=NSAV+1,N
68689 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
68690 DO 650 J=1,3
68691 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
68692 650 CONTINUE
68693 P(I,4)=GA*(P(I,4)+BEP)
68694 660 CONTINUE
68695 ENDIF
68696
68697C...Fill in position of decay vertex.
68698 DO 680 I=NSAV+1,N
68699 DO 670 J=1,4
68700 V(I,J)=VDCY(J)
68701 670 CONTINUE
68702 V(I,5)=0D0
68703 680 CONTINUE
68704
68705C...Set up for parton shower evolution from jets.
68706 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
68707 K(NSAV+1,1)=3
68708 K(NSAV+2,1)=3
68709 K(NSAV+3,1)=3
68710 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
68711 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
68712 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
68713 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
68714 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
68715 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
68716 MSTJ(92)=-(NSAV+1)
68717 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
68718 K(NSAV+2,1)=3
68719 K(NSAV+3,1)=3
68720 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
68721 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
68722 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
68723 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
68724 MSTJ(92)=NSAV+2
68725 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
68726 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
68727 K(NSAV+1,1)=3
68728 K(NSAV+2,1)=3
68729 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
68730 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
68731 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
68732 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
68733 MSTJ(92)=NSAV+1
68734 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
68735 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
68736 MSTJ(92)=NSAV+1
68737 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
68738 & THEN
68739 K(NSAV+1,1)=3
68740 K(NSAV+2,1)=3
68741 K(NSAV+3,1)=3
68742 KCP=PYCOMP(K(NSAV+1,2))
68743 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
68744 JCON=4
68745 IF(KQP.LT.0) JCON=5
68746 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
68747 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
68748 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
68749 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
68750 MSTJ(92)=NSAV+1
68751 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
68752 K(NSAV+1,1)=3
68753 K(NSAV+3,1)=3
68754 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
68755 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
68756 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
68757 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
68758 MSTJ(92)=NSAV+1
68759 ENDIF
68760
68761C...Mark decayed particle; special option for B-Bbar mixing.
68762 IF(K(IP,1).EQ.5) K(IP,1)=15
68763 IF(K(IP,1).LE.10) K(IP,1)=11
68764 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
68765 K(IP,4)=NSAV+1
68766 K(IP,5)=N
68767
68768 RETURN
68769 END
68770
68771
68772C*********************************************************************
68773
68774C...PYDCYK
68775C...Handles flavour production in the decay of unstable particles
68776C...and small string clusters.
68777
68778 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
68779
68780C...Double precision and integer declarations.
68781 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68782 IMPLICIT INTEGER(I-N)
68783 INTEGER PYK,PYCHGE,PYCOMP
68784C...Commonblocks.
68785 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68786 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68787 SAVE /PYDAT1/,/PYDAT2/
68788
68789
68790C.. Call PYKFDI directly if no popcorn option is on
68791 IF(MSTJ(12).LT.2) THEN
68792 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
68793 MSTU(124)=KFL3
68794 RETURN
68795 ENDIF
68796
68797 KFL3=0
68798 KF=0
68799 IF(KFL1.EQ.0) RETURN
68800 KF1A=IABS(KFL1)
68801 KF2A=IABS(KFL2)
68802
68803 NSTO=130
68804 NMAX=MIN(MSTU(125),10)
68805
68806C.. Identify rank 0 cluster qq
68807 IRANK=1
68808 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
68809
68810 IF(KF2A.GT.0)THEN
68811C.. Join jets: Fails if store not empty
68812 IF(MSTU(121).GT.0) THEN
68813 MSTU(121)=0
68814 RETURN
68815 ENDIF
68816 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
68817 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
68818C.. Pick popcorn meson from store, return same qq, decrease store
68819 KF=MSTU(NSTO+MSTU(121))
68820 KFL3=-KFL1
68821 MSTU(121)=MSTU(121)-1
68822 ELSE
68823C.. Generate new flavour. Then done if no diquark is generated
68824 100 CALL PYKFDI(KFL1,0,KFL3,KF)
68825 IF(MSTU(121).EQ.-1) GOTO 100
68826 MSTU(124)=KFL3
68827 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
68828
68829C.. Simple case if no dynamical popcorn suppressions are considered
68830 IF(MSTJ(12).LT.4) THEN
68831 IF(MSTU(121).EQ.0) RETURN
68832 NMES=1
68833 KFPREV=-KFL3
68834 CALL PYKFDI(KFPREV,0,KFL3,KFM)
68835C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
68836 IF(IABS(KFL3).LE.10)THEN
68837 KFL3=-KFPREV
68838 RETURN
68839 ENDIF
68840 GOTO 120
68841 ENDIF
68842
68843C test output qq against fake Gamma, then return if no popcorn.
68844 GB=2D0
68845 IF(IRANK.NE.0)THEN
68846 CALL PYZDIS(1,2103,5D0,Z)
68847 GB=5D0*(1D0-Z)/Z
68848 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
68849 MSTU(121)=0
68850 GOTO 100
68851 ENDIF
68852 ENDIF
68853 IF(MSTU(121).EQ.0) RETURN
68854
68855C..Set store size memory. Pick fake dynamical variables of qq.
68856 NMES=MSTU(121)
68857 CALL PYPTDI(1,PX3,PY3)
68858 X=1D0
68859 POPM=0D0
68860 G=GB
68861 POPG=GB
68862
68863C.. Pick next popcorn meson, test with fake dynamical variables
68864 110 KFPREV=-KFL3
68865 PX1=-PX3
68866 PY1=-PY3
68867 CALL PYKFDI(KFPREV,0,KFL3,KFM)
68868 IF(MSTU(121).EQ.-1) GOTO 100
68869 CALL PYPTDI(KFL3,PX3,PY3)
68870 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
68871 CALL PYZDIS(KFPREV,KFL3,PM,Z)
68872 G=(1D0-Z)*(G+PM/Z)
68873 X=(1D0-Z)*X
68874
68875 PTST=1D0
68876 GTST=1D0
68877 RTST=PYR(0)
68878 IF(MSTJ(12).GT.4)THEN
68879 POPMN=SQRT((1D0-X)*(G/X-GB))
68880 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68881 PTST=EXP((POPM-POPMN)*PARF(193))
68882 POPM=POPMN
68883 ENDIF
68884 IF(IRANK.NE.0)THEN
68885 POPGN=X*GB
68886 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
68887 POPG=POPGN
68888 ENDIF
68889 IF(RTST.GT.PTST*GTST)THEN
68890 MSTU(121)=0
68891 IF(RTST.GT.PTST) MSTU(121)=-1
68892 GOTO 100
68893 ENDIF
68894
68895C.. Store meson
68896 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
68897 IF(MSTU(121).GT.0) GOTO 110
68898
68899C.. Test accepted system size. If OK set global popcorn size variable.
68900 IF(NMES.GT.NMAX)THEN
68901 KF=0
68902 KFL3=0
68903 RETURN
68904 ENDIF
68905 MSTU(121)=NMES
68906 ENDIF
68907
68908 RETURN
68909 END
68910
68911C********************************************************************
68912
68913C...PYKFDI
68914C...Generates a new flavour pair and combines off a hadron
68915
68916 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
68917
68918C...Double precision and integer declarations.
68919 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68920 IMPLICIT INTEGER(I-N)
68921 INTEGER PYK,PYCHGE,PYCOMP
68922C...Commonblocks.
68923 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68924 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68925 SAVE /PYDAT1/,/PYDAT2/
68926C...Local arrays.
68927 DIMENSION PD(7)
68928
68929 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
68930
68931C...Default flavour values. Input consistency checks.
68932 KF1A=IABS(KFL1)
68933 KF2A=IABS(KFL2)
68934 KFL3=0
68935 KF=0
68936 IF(KF1A.EQ.0) RETURN
68937 IF(KF2A.NE.0)THEN
68938 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
68939 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
68940 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
68941 ENDIF
68942
68943C...Check if tabulated flavour probabilities are to be used.
68944 IF(MSTJ(15).EQ.1) THEN
68945 IF(MSTJ(12).GE.5) CALL PYERRM(29,
68946 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
68947 & ' together with MSTJ(12)>=5 modification')
68948 KTAB1=-1
68949 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
68950 KFL1A=MOD(KF1A/1000,10)
68951 KFL1B=MOD(KF1A/100,10)
68952 KFL1S=MOD(KF1A,10)
68953 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
68954 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
68955 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
68956 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
68957 KTAB2=0
68958 IF(KF2A.NE.0) THEN
68959 KTAB2=-1
68960 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
68961 KFL2A=MOD(KF2A/1000,10)
68962 KFL2B=MOD(KF2A/100,10)
68963 KFL2S=MOD(KF2A,10)
68964 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
68965 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
68966 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
68967 ENDIF
68968 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
68969 ENDIF
68970
68971C.. Recognize rank 0 diquark case
68972 100 IRANK=1
68973 KFDIQ=MAX(KF1A,KF2A)
68974 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
68975
68976C.. Join two flavours to meson or baryon. Test for popcorn.
68977 IF(KF2A.GT.0)THEN
68978 MBARY=0
68979 IF(KFDIQ.GT.10) THEN
68980 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
68981 & CALL PYNMES(KFDIQ)
68982 IF(MSTU(121).NE.0) THEN
68983 MSTU(121)=0
68984 RETURN
68985 ENDIF
68986 MBARY=2
68987 ENDIF
68988 KFQOLD=KF1A
68989 KFQVER=KF2A
68990 GOTO 130
68991 ENDIF
68992
68993C.. Separate incoming flavours, curtain flavour consistency check
68994 KFIN=KFL1
68995 KFQOLD=KF1A
68996 KFQPOP=KF1A/10000
68997 IF(KF1A.GT.10)THEN
68998 KFIN=-KFL1
68999 KFL1A=MOD(KF1A/1000,10)
69000 KFL1B=MOD(KF1A/100,10)
69001 IF(IRANK.EQ.0)THEN
69002 QAWT=1D0
69003 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
69004 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
69005 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
69006 ENDIF
69007 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
69008 MSTU(121)=0
69009 RETURN
69010 ENDIF
69011 KFQOLD=KFL1A+KFL1B-KFQPOP
69012 ENDIF
69013
69014C...Meson/baryon choice. Set number of mesons if starting a popcorn
69015C...system.
69016 110 MBARY=0
69017 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
69018 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
69019 MBARY=1
69020 CALL PYNMES(0)
69021 ENDIF
69022 ELSEIF(KF1A.GT.10)THEN
69023 MBARY=2
69024 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
69025 IF(MSTU(121).GT.0) MBARY=-1
69026 ENDIF
69027
69028C..x->H+q: Choose single vertex quark. Jump to form hadron.
69029 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
69030 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
69031 KFL3=ISIGN(KFQVER,-KFIN)
69032 GOTO 130
69033 ENDIF
69034
69035C..x->H+qq: (IDW=proper PARF position for diquark weights)
69036 IDW=160
69037 IF(MBARY.EQ.1)THEN
69038 IF(MSTU(121).EQ.0) IDW=150
69039 SQWT=PARF(IDW+1)
69040 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
69041 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
69042C.. Shift to s-curtain parameters if needed
69043 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
69044 PARF(194)=PARF(138)*PARF(139)
69045 PARF(193)=PARJ(8)+PARJ(9)
69046 ENDIF
69047 ENDIF
69048
69049C.. x->H+qq: Get vertex quark
69050 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
69051 IDW=MSTU(122)
69052 MSTU(121)=MSTU(121)-1
69053 IF(IDW.EQ.170) THEN
69054 IF(MSTU(121).EQ.0)THEN
69055 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
69056 ELSE
69057 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
69058 ENDIF
69059 ELSE
69060 IF(MSTU(121).EQ.0)THEN
69061 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
69062 ELSE
69063 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
69064 ENDIF
69065 ENDIF
69066 IPOS=200+30*IPOS+1
69067
69068 IMES=-1
69069 RMES=PYR(0)*PARF(194)
69070 120 IMES=IMES+1
69071 RMES=RMES-PARF(IPOS+IMES)
69072 IF(IMES.EQ.30) THEN
69073 MSTU(121)=-1
69074 KF=-111
69075 RETURN
69076 ENDIF
69077 IF(RMES.GT.0D0) GOTO 120
69078 KMUL=IMES/5
69079 KFJ=2*KMUL+1
69080 IF(KMUL.EQ.2) KFJ=10003
69081 IF(KMUL.EQ.3) KFJ=10001
69082 IF(KMUL.EQ.4) KFJ=20003
69083 IF(KMUL.EQ.5) KFJ=5
69084 IDIAG=0
69085 KFQVER=MOD(IMES,5)+1
69086 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
69087 IF(KFQVER.GT.3)THEN
69088 IDIAG=KFQVER-3
69089 KFQVER=KFQOLD
69090 ENDIF
69091 ELSE
69092 IF(MBARY.EQ.-1) IDW=170
69093 SQWT=PARF(IDW+2)
69094 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
69095 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
69096 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
69097 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
69098 KFQVER=KFQPOP
69099 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
69100 ENDIF
69101 ENDIF
69102
69103C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
69104 KFLDS=3
69105 IF(KFQPOP.NE.KFQVER)THEN
69106 SWT=PARF(IDW+7)
69107 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
69108 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
69109 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
69110 ENDIF
69111 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
69112 & +10000*KFQPOP
69113 KFL3=ISIGN(KFDIQ,KFIN)
69114
69115C..x->M+y: flavour for meson.
69116 130 IF(MBARY.LE.0)THEN
69117 KFLA=MAX(KFQOLD,KFQVER)
69118 KFLB=MIN(KFQOLD,KFQVER)
69119 KFS=ISIGN(1,KFL1)
69120 IF(KFLA.NE.KFQOLD) KFS=-KFS
69121C... Form meson, with spin and flavour mixing for diagonal states.
69122 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
69123 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
69124 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
69125 RETURN
69126 ENDIF
69127 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
69128 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
69129 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
69130 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
69131 IF(PYR(0).LT.PARJ(14)) KMUL=2
69132 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
69133 RMUL=PYR(0)
69134 IF(RMUL.LT.PARJ(15)) KMUL=3
69135 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
69136 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
69137 ENDIF
69138 KFLS=3
69139 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
69140 IF(KMUL.EQ.5) KFLS=5
69141 IF(KFLA.NE.KFLB)THEN
69142 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
69143 ELSE
69144 RMIX=PYR(0)
69145 IMIX=2*KFLA+10*KMUL
69146 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
69147 & INT(RMIX+PARF(IMIX)))+KFLS
69148 IF(KFLA.GE.4) KF=110*KFLA+KFLS
69149 ENDIF
69150 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
69151 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
69152
69153C..Optional extra suppression of eta and eta'.
69154C..Allow shift to qq->B+q in old version (set IRANK to 0)
69155 IF(KF.EQ.221.OR.KF.EQ.331)THEN
69156 IF(PYR(0).GT.PARJ(25+KF/300))THEN
69157 IF(KF2A.GT.0) GOTO 130
69158 IF(MSTJ(12).LT.4) IRANK=0
69159 GOTO 110
69160 ENDIF
69161 ENDIF
69162 MSTU(121)=0
69163
69164C.. x->B+y: Flavour for baryon
69165 ELSE
69166 KFLA=KFQVER
69167 IF(KF1A.LE.10) KFLA=KFQOLD
69168 KFLB=MOD(KFDIQ/1000,10)
69169 KFLC=MOD(KFDIQ/100,10)
69170 KFLDS=MOD(KFDIQ,10)
69171 KFLD=MAX(KFLA,KFLB,KFLC)
69172 KFLF=MIN(KFLA,KFLB,KFLC)
69173 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
69174
69175C... SU(6) factors for formation of baryon.
69176 KBARY=3
69177 KDMAX=5
69178 KFLG=KFLB
69179 IF(KFLB.NE.KFLC)THEN
69180 KBARY=2*KFLDS-1
69181 KDMAX=1+KFLDS/2
69182 IF(KFLB.GT.2) KDMAX=KDMAX+2
69183 ENDIF
69184 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
69185 KBARY=KBARY+1
69186 KFLG=KFLA
69187 ENDIF
69188
69189 SU6MAX=PARF(140+KDMAX)
69190 SU6DEC=PARJ(18)
69191 SU6S =PARF(146)
69192 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
69193 SU6MAX=1D0
69194 SU6DEC=1D0
69195 SU6S =1D0
69196 ENDIF
69197 SU6OCT=PARF(60+KBARY)
69198 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
69199 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
69200 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
69201 ELSE
69202 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
69203 ENDIF
69204 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
69205
69206C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
69207 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
69208 MSTU(121)=0
69209 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
69210 GOTO 110
69211 ENDIF
69212
69213C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
69214 KSIG=1
69215 KFLS=2
69216 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
69217 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
69218 KSIG=KFLDS/3
69219 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
69220 ENDIF
69221 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
69222 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
69223 ENDIF
69224 RETURN
69225
b73cda88 69226C -------------------------------------------------------------------------
69227C Extracted from a private e-mail exchange with Torbjorn Sjostrand
69228C
69229C No, Lambda(1520) is not included and not foreseen.
69230C So if you want it in Pythia, it would have to be a hack.
69231C What you could do is:
69232C 1) In PYKFDI, just before the RETURN above label 140, you could check if
69233C a Lambda, Sigma0 or Sigma*0 has been produced, and with some small
69234C probability switch such a particle to the Lambda(1520) code. That is,
69235C if KF = 3122, 3212, or 3214 and a random number below some number, switch
69236C to KF = 3124. (And correspondingly for anticparticles.)
69237C 2) Use the PYUPDA routine (see manual) to include particle and decay data
69238C for the Lambda(1520).
69239C -------------------------------------------------------------------------
69240
69241 IF (IABS(KF).EQ.3122) THEN
69242C Converting a fraction (0.20) of Lambda0 to Lambda(1520) + c.c.
69243C This fraction is based on the experimental measurement at ISR
69244C Bobbink 83, NP B217,11 (1983)
69245C The region 0.5 < XF < 1.0 has been extrapolated to XF=0
69246 IF(PYR(0).LE.0.20) KF=ISIGN(3124,KF)
69247 ENDIF
69248
69249 IF(IABS(KF).EQ.3212) THEN
69250C Converting a fraction (0.20) of Sigma0 to Lambda(1520) + c.c.
69251C We suppose the same fraction as for Lambda0
69252 IF(PYR(0).LE.0.20) KF=ISIGN(3124,KF)
69253 ENDIF
69254
69255 IF (IABS(KF).EQ.3214) THEN
69256C Converting a fraction (0.30) of Sigma0(1385) to Lambda(1520) + c.c.
69257C This is conservative extimate supposing that the ratio
69258C scales as (M_Sigma1385/M_Lambda0)^2 ~ 1.5
69259 IF(PYR(0).LE.0.30) KF=ISIGN(3124,KF)
69260 ENDIF
69261 RETURN
69262
92e27c01 69263C...Use tabulated probabilities to select new flavour and hadron.
69264 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
69265 KT3L=1
69266 KT3U=6
69267 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
69268 KT3L=1
69269 KT3U=6
69270 ELSEIF(KTAB2.EQ.0) THEN
69271 KT3L=1
69272 KT3U=22
69273 ELSE
69274 KT3L=KTAB2
69275 KT3U=KTAB2
69276 ENDIF
69277 RFL=0D0
69278 DO 160 KTS=0,2
69279 DO 150 KT3=KT3L,KT3U
69280 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
69281 150 CONTINUE
69282 160 CONTINUE
69283 RFL=PYR(0)*RFL
69284 DO 180 KTS=0,2
69285 KTABS=KTS
69286 DO 170 KT3=KT3L,KT3U
69287 KTAB3=KT3
69288 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
69289 IF(RFL.LE.0D0) GOTO 190
69290 170 CONTINUE
69291 180 CONTINUE
69292 190 CONTINUE
69293
69294C...Reconstruct flavour of produced quark/diquark.
69295 IF(KTAB3.LE.6) THEN
69296 KFL3A=KTAB3
69297 KFL3B=0
69298 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
69299 ELSE
69300 KFL3A=1
69301 IF(KTAB3.GE.8) KFL3A=2
69302 IF(KTAB3.GE.11) KFL3A=3
69303 IF(KTAB3.GE.16) KFL3A=4
69304 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
69305 KFL3=1000*KFL3A+100*KFL3B+1
69306 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
69307 & KFL3+2
69308 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
69309 ENDIF
69310
69311C...Reconstruct meson code.
69312 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
69313 &KFL3B.NE.0)) THEN
69314 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
69315 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
69316 KF=110+2*KTABS+1
69317 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
69318 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
69319 & 25*KTABS)) KF=330+2*KTABS+1
69320 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
69321 KFLA=MAX(KTAB1,KTAB3)
69322 KFLB=MIN(KTAB1,KTAB3)
69323 KFS=ISIGN(1,KFL1)
69324 IF(KFLA.NE.KF1A) KFS=-KFS
69325 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
69326 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
69327 KFS=ISIGN(1,KFL1)
69328 IF(KFL1A.EQ.KFL3A) THEN
69329 KFLA=MAX(KFL1B,KFL3B)
69330 KFLB=MIN(KFL1B,KFL3B)
69331 IF(KFLA.NE.KFL1B) KFS=-KFS
69332 ELSEIF(KFL1A.EQ.KFL3B) THEN
69333 KFLA=KFL3A
69334 KFLB=KFL1B
69335 KFS=-KFS
69336 ELSEIF(KFL1B.EQ.KFL3A) THEN
69337 KFLA=KFL1A
69338 KFLB=KFL3B
69339 ELSEIF(KFL1B.EQ.KFL3B) THEN
69340 KFLA=MAX(KFL1A,KFL3A)
69341 KFLB=MIN(KFL1A,KFL3A)
69342 IF(KFLA.NE.KFL1A) KFS=-KFS
69343 ELSE
69344 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
69345 GOTO 100
69346 ENDIF
69347 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
69348
69349C...Reconstruct baryon code.
69350 ELSE
69351 IF(KTAB1.GE.7) THEN
69352 KFLA=KFL3A
69353 KFLB=KFL1A
69354 KFLC=KFL1B
69355 ELSE
69356 KFLA=KFL1A
69357 KFLB=KFL3A
69358 KFLC=KFL3B
69359 ENDIF
69360 KFLD=MAX(KFLA,KFLB,KFLC)
69361 KFLF=MIN(KFLA,KFLB,KFLC)
69362 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
69363 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
69364 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
69365 ENDIF
69366
69367C...Check that constructed flavour code is an allowed one.
69368 IF(KFL2.NE.0) KFL3=0
69369 KC=PYCOMP(KF)
69370 IF(KC.EQ.0) THEN
69371 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
69372 & 'failed')
69373 GOTO 100
69374 ENDIF
69375
69376 RETURN
69377 END
69378
69379C*********************************************************************
69380
69381C...PYNMES
69382C...Generates number of popcorn mesons and stores some relevant
69383C...parameters.
69384
69385 SUBROUTINE PYNMES(KFDIQ)
69386
69387C...Double precision and integer declarations.
69388 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69389 IMPLICIT INTEGER(I-N)
69390 INTEGER PYK,PYCHGE,PYCOMP
69391C...Commonblocks.
69392 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69393 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69394 SAVE /PYDAT1/,/PYDAT2/
69395
69396 MSTU(121)=0
69397 IF(MSTJ(12).LT.2) RETURN
69398
69399C..Old version: Get 1 or 0 popcorn mesons
69400 IF(MSTJ(12).LT.5)THEN
69401 POPWT=PARF(131)
69402 IF(KFDIQ.NE.0) THEN
69403 KFDIQA=IABS(KFDIQ)
69404 KFA=MOD(KFDIQA/1000,10)
69405 KFB=MOD(KFDIQA/100,10)
69406 KFS=MOD(KFDIQA,10)
69407 POPWT=PARF(132)
69408 IF(KFA.EQ.3) POPWT=PARF(133)
69409 IF(KFB.EQ.3) POPWT=PARF(134)
69410 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
69411 ENDIF
69412 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
69413 RETURN
69414 ENDIF
69415
69416C..New version: Store popcorn- or rank 0 diquark parameters
69417 MSTU(122)=170
69418 PARF(193)=PARJ(8)
69419 PARF(194)=PARF(139)
69420 IF(KFDIQ.NE.0) THEN
69421 MSTU(122)=180
69422 PARF(193)=PARJ(10)
69423 PARF(194)=PARF(140)
69424 ENDIF
69425 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
69426 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
69427 & '(PYNMES:) Neglecting too large popcorn possibility')
69428 RETURN
69429 ENDIF
69430
69431C..New version: Get number of popcorn mesons
69432 100 RTST=PYR(0)
69433 MSTU(121)=-1
69434 110 MSTU(121)=MSTU(121)+1
69435 RTST=RTST/PARF(194)
69436 IF(RTST.LT.1D0) GOTO 110
69437 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
69438 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
69439 RETURN
69440 END
69441
69442C***************************************************************
69443
69444C...PYKFIN
69445C...Precalculates a set of diquark and popcorn weights.
69446
69447 SUBROUTINE PYKFIN
69448
69449C...Double precision and integer declarations.
69450 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69451 IMPLICIT INTEGER(I-N)
69452 INTEGER PYK,PYCHGE,PYCOMP
69453C...Commonblocks.
69454 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69455 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69456 SAVE /PYDAT1/,/PYDAT2/
69457
69458 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
69459
69460
69461 MSTU(123)=1
69462C..Diquark indices for dimensional variables
69463 IUD1=1
69464 IUU1=2
69465 IUS0=3
69466 ISU0=4
69467 IUS1=5
69468 ISU1=6
69469 ISS1=7
69470
69471C.. *** SU(6) factors **
69472C..Modify with decuplet- (and Sigma/Lambda-) suppression.
69473 PARF(146)=1D0
69474 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
69475 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
69476 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
69477 DO 100 I=1,6
69478 SU6(I)=PARF(60+I)
69479 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
69480 100 CONTINUE
69481 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
69482 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
69483 DO 110 I=1,6
69484 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
69485 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
69486 110 CONTINUE
69487
69488C..SU(6)max q q' s,c,b
69489 SU6MUD =MAX(SU6(1) , SU6(8) )
69490 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
69491 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
69492 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
69493 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
69494 SU6M(IUS0)=SU6M(ISU0)
69495 SU6M(ISS1)=SU6M(IUU1)
69496 SU6M(IUS1)=SU6M(ISU1)
69497
69498C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
69499 PARF(141)=SU6MUD
69500 PARF(142)=SU6M(IUD1)
69501 PARF(143)=SU6M(ISU0)
69502 PARF(144)=SU6M(ISU1)
69503 PARF(145)=SU6M(ISS1)
69504
69505C..diquark SU(6) survival =
69506C..sum over quark (quark tunnel weight)*(SU(6)).
69507 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
69508 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
69509 DMB(IUS0)=DMB(ISU0)
69510 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
69511 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
69512 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
69513 DMB(IUS1)=DMB(ISU1)
69514 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
69515
69516C.. *** Tunneling factors for Diquark production***
69517C.. T: half a curtain pair = sqrt(curtain pair factor)
69518 IF(MSTJ(12).GE.5) THEN
69519 PMUD0=PYMASS(2101)
69520 PMUD1=PYMASS(2103)-PMUD0
69521 PMUS0=PYMASS(3201)-PMUD0
69522 PMUS1=PYMASS(3203)-PMUS0-PMUD0
69523 PMSS1=PYMASS(3303)-PMUS0-PMUD0
69524 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
69525 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
69526 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
69527 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
69528 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
69529 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
69530 QBB(IUD1)=QBB(IUU1)
69531 ELSE
69532 PAR2M=SQRT(PARJ(2))
69533 PAR3M=SQRT(PARJ(3))
69534 PAR4M=SQRT(PARJ(4))
69535 QBB(ISU0)=PAR2M*PAR3M
69536 QBB(IUS0)=PAR3M
69537 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
69538 QBB(IUU1)=PAR4M
69539 QBB(ISU1)=PAR4M*QBB(ISU0)
69540 QBB(IUS1)=PAR4M*QBB(IUS0)
69541 QBB(IUD1)=PAR4M
69542 ENDIF
69543
69544C.. tau: spin*(vertex factor)*(T = half-curtain factor)
69545 QBM(ISU0)=QBB(ISU0)
69546 QBM(IUS0)=PARJ(2)*QBB(IUS0)
69547 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
69548 QBM(IUU1)=6D0*QBB(IUU1)
69549 QBM(ISU1)=3D0*QBB(ISU1)
69550 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
69551 QBM(IUD1)=3D0*QBB(IUD1)
69552
69553C.. Combine T and tau to diquark weight for q-> B+B+..
69554 DO 120 I=1,7
69555 QBB(I)=QBB(I)*QBM(I)
69556 120 CONTINUE
69557
69558 IF(MSTJ(12).GE.5)THEN
69559C..New version: tau for rank 0 diquark.
69560 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
69561 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
69562 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
69563 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
69564 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
69565 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
69566 DMB(7+IUD1)=DMB(7+IUU1)/2D0
69567
69568C..New version: curtain flavour ratios.
69569C.. s/u for q->B+M+...
69570C.. s/u for rank 0 diquark: su -> ...M+B+...
69571C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
69572 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
69573 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
69574 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
69575 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
69576 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
69577 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
69578 ELSE
69579C..Old version: reset unused rank 0 diquark weights and
69580C.. unused diquark SU(6) survival weights
69581 DO 130 I=1,7
69582 IF(MSTJ(12).LT.3) DMB(I)=1D0
69583 DMB(7+I)=1D0
69584 130 CONTINUE
69585
69586C..Old version: Shuffle PARJ(7) into tau
69587 QBM(IUS0)=QBM(IUS0)*PARJ(7)
69588 QBM(ISS1)=QBM(ISS1)*PARJ(7)
69589 QBM(IUS1)=QBM(IUS1)*PARJ(7)
69590
69591C..Old version: curtain flavour ratios.
69592C.. s/u for q->B+M+...
69593C.. s/u for rank 0 diquark: su -> ...M+B+...
69594C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
69595 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
69596 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
69597 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
69598 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
69599 ENDIF
69600
69601C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
69602C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
69603 DO 140 I=1,7
69604 DMB(7+I)=DMB(7+I)*DMB(I)
69605 DMB(I)=DMB(I)*QBM(I)
69606 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
69607 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
69608 140 CONTINUE
69609
69610C.. *** Popcorn factors ***
69611
69612 IF(MSTJ(12).LT.5)THEN
69613C.. Old version: Resulting popcorn weights.
69614 PARF(138)=PARJ(6)
69615 WS=PARF(135)*PARF(138)
69616 WQ=WU*PARJ(5)/3D0
69617 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
69618 PARF(133)=WQ*
69619 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
69620 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
69621 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
69622 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
69623 & (1D0+QBB(IUD1)+QBB(IUU1)+
69624 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
69625 ELSE
69626C..New version: Store weights for popcorn mesons,
69627C..get prel. popcorn weights.
69628 DO 150 IPOS=201,1400
69629 PARF(IPOS)=0D0
69630 150 CONTINUE
69631 DO 160 I=138,140
69632 PARF(I)=0D0
69633 160 CONTINUE
69634 IPOS=200
69635 PARF(193)=PARJ(8)
69636 DO 240 MR=0,7,7
69637 IF(MR.EQ.7) PARF(193)=PARJ(10)
69638 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
69639 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
69640 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
69641 DO 230 NMES=0,1
69642 IF(NMES.EQ.1) SQWT=PARJ(2)
69643 DO 220 KFQPOP=1,4
69644 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
69645 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
69646 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
69647 QQWT=0.5D0
69648 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
69649 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
69650 ENDIF
69651 DO 210 KFQOLD =1,5
69652 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
69653 IF(NMES.EQ.1) THEN
69654 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
69655 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
69656 ENDIF
69657 WTTOT=0D0
69658 WTFAIL=0D0
69659 DO 190 KMUL=0,5
69660 PJWT=PARJ(12+KMUL)
69661 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
69662 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
69663 IF(PJWT.LE.0D0) GOTO 190
69664 IF(PJWT.GT.1D0) PJWT=1D0
69665 IMES=5*KMUL
69666 IMIX=2*KFQOLD+10*KMUL
69667 KFJ=2*KMUL+1
69668 IF(KMUL.EQ.2) KFJ=10003
69669 IF(KMUL.EQ.3) KFJ=10001
69670 IF(KMUL.EQ.4) KFJ=20003
69671 IF(KMUL.EQ.5) KFJ=5
69672 DO 180 KFQVER =1,3
69673 KFLA=MAX(KFQOLD,KFQVER)
69674 KFLB=MIN(KFQOLD,KFQVER)
69675 SWT=PARJ(11+KFLA/3+KFLA/4)
69676 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
69677 SWT=SWT*PJWT
69678 QWT=SQWT/(2D0+SQWT)
69679 IF(KFQVER.LT.3)THEN
69680 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
69681 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
69682 ENDIF
69683 IF(KFQVER.NE.KFQOLD)THEN
69684 IMES=IMES+1
69685 KFM=100*KFLA+10*KFLB+KFJ
69686 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
69687 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
69688 WTTOT=WTTOT+PARF(IPOS+IMES)
69689 ELSE
69690 DO 170 ID=3,5
69691 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
69692 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
69693 IF(ID.EQ.5) DWT=PARF(IMIX)
69694 KFM=110*(ID-2)+KFJ
69695 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
69696 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
69697 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
69698 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
69699 PARF(IPOS+5*KMUL+ID)=
69700 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
69701 ENDIF
69702 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
69703 170 CONTINUE
69704 ENDIF
69705 180 CONTINUE
69706 190 CONTINUE
69707 DO 200 IMES=1,30
69708 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
69709 200 CONTINUE
69710 IF(MR.EQ.7) PARF(140)=
69711 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
69712 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
69713 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
69714 IPOS=IPOS+30
69715 210 CONTINUE
69716 220 CONTINUE
69717 230 CONTINUE
69718 240 CONTINUE
69719 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
69720 MSTU(121)=0
69721
69722 ENDIF
69723
69724C..Recombine diquark weights to flavour and spin ratios
69725 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
69726 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
69727 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
69728 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
69729 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
69730 PARF(155)=QBB(ISU1)/QBB(ISU0)
69731 PARF(156)=QBB(IUS1)/QBB(IUS0)
69732 PARF(157)=QBB(IUD1)
69733
69734 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
69735 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
69736 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
69737 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
69738 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
69739 PARF(165)=QBM(ISU1)/QBM(ISU0)
69740 PARF(166)=QBM(IUS1)/QBM(IUS0)
69741 PARF(167)=QBM(IUD1)
69742
69743 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
69744 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
69745 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
69746 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
69747 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
69748 PARF(175)=DMB(ISU1)/DMB(ISU0)
69749 PARF(176)=DMB(IUS1)/DMB(IUS0)
69750 PARF(177)=DMB(IUD1)
69751
69752 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
69753 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
69754 PARF(187)=DMB(7+IUD1)
69755
69756 RETURN
69757 END
69758
69759
69760C*********************************************************************
69761
69762C...PYPTDI
69763C...Generates transverse momentum according to a Gaussian.
69764
69765 SUBROUTINE PYPTDI(KFL,PX,PY)
69766
69767C...Double precision and integer declarations.
69768 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69769 IMPLICIT INTEGER(I-N)
69770 INTEGER PYK,PYCHGE,PYCOMP
69771C...Commonblocks.
69772 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69773 SAVE /PYDAT1/
69774
69775C...Generate p_T and azimuthal angle, gives p_x and p_y.
69776 KFLA=IABS(KFL)
69777 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
69778 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
69779 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
69780 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
69781 PHI=PARU(2)*PYR(0)
69782 PX=PT*COS(PHI)
69783 PY=PT*SIN(PHI)
69784
69785 RETURN
69786 END
69787
69788C*********************************************************************
69789
69790C...PYZDIS
69791C...Generates the longitudinal splitting variable z.
69792
69793 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
69794
69795C...Double precision and integer declarations.
69796 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69797 IMPLICIT INTEGER(I-N)
69798 INTEGER PYK,PYCHGE,PYCOMP
69799C...Commonblocks.
69800 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69801 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69802 SAVE /PYDAT1/,/PYDAT2/
69803
69804C...Check if heavy flavour fragmentation.
69805 KFLA=IABS(KFL1)
69806 KFLB=IABS(KFL2)
69807 KFLH=KFLA
69808 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
69809
69810C...Lund symmetric scaling function: determine parameters of shape.
69811 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
69812 &MSTJ(11).GE.4) THEN
69813 FA=PARJ(41)
69814 IF(MSTJ(91).EQ.1) FA=PARJ(43)
69815 IF(KFLB.GE.10) FA=FA+PARJ(45)
69816 FBB=PARJ(42)
69817 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
69818 FB=FBB*PR
69819 FC=1D0
69820 IF(KFLA.GE.10) FC=FC-PARJ(45)
69821 IF(KFLB.GE.10) FC=FC+PARJ(45)
69822 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
69823 FRED=PARJ(46)
69824 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
69825 FC=FC+FRED*FBB*PARF(100+KFLH)**2
69826 ENDIF
69827 MC=1
69828 IF(ABS(FC-1D0).GT.0.01D0) MC=2
69829
69830C...Determine position of maximum. Special cases for a = 0 or a = c.
69831 IF(FA.LT.0.02D0) THEN
69832 MA=1
69833 ZMAX=1D0
69834 IF(FC.GT.FB) ZMAX=FB/FC
69835 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
69836 MA=2
69837 ZMAX=FB/(FB+FC)
69838 ELSE
69839 MA=3
69840 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
69841 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
69842 ENDIF
69843
69844C...Subdivide z range if distribution very peaked near endpoint.
69845 MMAX=2
69846 IF(ZMAX.LT.0.1D0) THEN
69847 MMAX=1
69848 ZDIV=2.75D0*ZMAX
69849 IF(MC.EQ.1) THEN
69850 FINT=1D0-LOG(ZDIV)
69851 ELSE
69852 ZDIVC=ZDIV**(1D0-FC)
69853 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
69854 ENDIF
69855 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
69856 MMAX=3
69857 FSCB=SQRT(4D0+(FC/FB)**2)
69858 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
69859 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
69860 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
69861 FINT=1D0+FB*(1D0-ZDIV)
69862 ENDIF
69863
69864C...Choice of z, preweighted for peaks at low or high z.
69865 100 Z=PYR(0)
69866 FPRE=1D0
69867 IF(MMAX.EQ.1) THEN
69868 IF(FINT*PYR(0).LE.1D0) THEN
69869 Z=ZDIV*Z
69870 ELSEIF(MC.EQ.1) THEN
69871 Z=ZDIV**Z
69872 FPRE=ZDIV/Z
69873 ELSE
69874 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
69875 FPRE=(ZDIV/Z)**FC
69876 ENDIF
69877 ELSEIF(MMAX.EQ.3) THEN
69878 IF(FINT*PYR(0).LE.1D0) THEN
69879 Z=ZDIV+LOG(Z)/FB
69880 FPRE=EXP(FB*(Z-ZDIV))
69881 ELSE
69882 Z=ZDIV+Z*(1D0-ZDIV)
69883 ENDIF
69884 ENDIF
69885
69886C...Weighting according to correct formula.
69887 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
69888 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
69889 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
69890 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
69891 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
69892
69893C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
69894 ELSE
69895 FC=PARJ(50+MAX(1,KFLH))
69896 IF(MSTJ(91).EQ.1) FC=PARJ(59)
69897 110 Z=PYR(0)
69898 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
69899 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
69900 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
69901 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
69902 & GOTO 110
69903 ELSE
69904 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
69905 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
69906 ENDIF
69907 ENDIF
69908
69909 RETURN
69910 END
69911
69912C*********************************************************************
69913
69914C...PYSHOW
69915C...Generates timelike parton showers from given partons.
69916
69917 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
69918
69919C...Double precision and integer declarations.
69920 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69921 IMPLICIT INTEGER(I-N)
69922 INTEGER PYK,PYCHGE,PYCOMP
69923C...Parameter statement to help give large particle numbers.
69924 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69925 &KEXCIT=4000000,KDIMEN=5000000)
69926 PARAMETER (MAXNUR=1000)
69927C...Commonblocks.
69928 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
69929 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69930 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69931 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69932 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69933 COMMON/PYINT1/MINT(400),VINT(400)
69934 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
69935C...Local arrays.
69936 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
69937 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
69938 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
69939 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
69940 &IREF(1000)
69941
69942C...Check that QMAX not too low.
69943 IF(MSTJ(41).LE.0) THEN
69944 RETURN
69945 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
69946 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
69947 ELSE
69948 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
69949 & RETURN
69950 ENDIF
69951
69952C...Store positions of shower initiating partons.
69953 MPSPD=0
69954 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
69955 NPA=1
69956 IPA(1)=IP1
69957 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
69958 & MSTU(32))) THEN
69959 NPA=2
69960 IPA(1)=IP1
69961 IPA(2)=IP2
69962 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
69963 & .AND.IP2.GE.-80) THEN
69964 NPA=IABS(IP2)
69965 DO 100 I=1,NPA
69966 IPA(I)=IP1+I-1
69967 100 CONTINUE
69968 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
69969 &IP2.EQ.-100) THEN
69970 MPSPD=1
69971 NPA=2
69972 IPA(1)=IP1+6
69973 IPA(2)=IP1+7
69974 ELSE
69975 CALL PYERRM(12,
69976 & '(PYSHOW:) failed to reconstruct showering system')
69977 IF(MSTU(21).GE.1) RETURN
69978 ENDIF
69979
69980C...Send off to PYPTFS for pT-ordered evolution if requested,
69981C...if at least 2 partons, and without predefined shower branchings.
69982 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
69983 &MPSPD.EQ.0) THEN
69984 NPART=NPA
69985 DO 110 II=1,NPART
69986 IPART(II)=IPA(II)
69987 PTPART(II)=0.5D0*QMAX
69988 110 CONTINUE
69989 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
69990 RETURN
69991 ENDIF
69992
69993C...Initialization of cutoff masses etc.
69994 DO 120 IFL=0,40
69995 ISCOL(IFL)=0
69996 ISCHG(IFL)=0
69997 KSH(IFL)=0
69998 120 CONTINUE
69999 ISCOL(21)=1
70000 KSH(21)=1
70001 PMTH(1,21)=PYMASS(21)
70002 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
70003 PMTH(3,21)=2D0*PMTH(2,21)
70004 PMTH(4,21)=PMTH(3,21)
70005 PMTH(5,21)=PMTH(3,21)
70006 PMTH(1,22)=PYMASS(22)
70007 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
70008 PMTH(3,22)=2D0*PMTH(2,22)
70009 PMTH(4,22)=PMTH(3,22)
70010 PMTH(5,22)=PMTH(3,22)
70011 PMQTH1=PARJ(82)
70012 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
70013 PMQT1E=MIN(PMQTH1,PARJ(90))
70014 PMQTH2=PMTH(2,21)
70015 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
70016 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
70017 DO 130 IFL=1,5
70018 ISCOL(IFL)=1
70019 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
70020 KSH(IFL)=1
70021 PMTH(1,IFL)=PYMASS(IFL)
70022 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
70023 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
70024 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
70025 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
70026 130 CONTINUE
70027 DO 140 IFL=11,15,2
70028 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
70029 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
70030 PMTH(1,IFL)=PYMASS(IFL)
70031 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
70032 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
70033 PMTH(4,IFL)=PMTH(3,IFL)
70034 PMTH(5,IFL)=PMTH(3,IFL)
70035 140 CONTINUE
70036 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
70037 ALAMS=PARJ(81)**2
70038 ALFM=LOG(PT2MIN/ALAMS)
70039
70040C...Check on phase space available for emission.
70041 IREJ=0
70042 DO 150 J=1,5
70043 PS(J)=0D0
70044 150 CONTINUE
70045 PM=0D0
70046 KFLA(2)=0
70047 DO 170 I=1,NPA
70048 KFLA(I)=IABS(K(IPA(I),2))
70049 PMA(I)=P(IPA(I),5)
70050C...Special cutoff masses for initial partons (may be a heavy quark,
70051C...squark, ..., and need not be on the mass shell).
70052 IR=30+I
70053 IF(NPA.LE.1) IREF(I)=IR
70054 IF(NPA.GE.2) IREF(I+1)=IR
70055 ISCOL(IR)=0
70056 ISCHG(IR)=0
70057 KSH(IR)=0
70058 IF(KFLA(I).LE.8) THEN
70059 ISCOL(IR)=1
70060 IF(MSTJ(41).GE.2) ISCHG(IR)=1
70061 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
70062 & KFLA(I).EQ.17) THEN
70063 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
70064 ELSEIF(KFLA(I).EQ.21) THEN
70065 ISCOL(IR)=1
70066 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
70067 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
70068 ISCOL(IR)=1
70069 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
70070 ISCOL(IR)=1
70071C...QUARKONIA+++
70072C...same for QQ~[3S18]
70073 ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
70074 & KFLA(I).EQ.9900553)) THEN
70075 ISCOL(IR)=1
70076C...QUARKONIA---
70077 ENDIF
70078
70079C...Option to switch off radiation from particle KF = MSTJ(39) entirely
70080C...(only intended for studying the effects of switching such rad on/off)
70081 IF (MSTJ(39).GT.0.AND.KFLA(I).EQ.MSTJ(39)) THEN
70082 ISCOL(IR)=0
70083 ISCHG(IR)=0
70084 ENDIF
70085
70086 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
70087 PMTH(1,IR)=PMA(I)
70088 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
70089 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
70090 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
70091 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
70092 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
70093 ELSEIF(ISCOL(IR).EQ.1) THEN
70094 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
70095 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
70096 PMTH(4,IR)=PMTH(3,IR)
70097 PMTH(5,IR)=PMTH(3,IR)
70098 ELSEIF(ISCHG(IR).EQ.1) THEN
70099 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
70100 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
70101 PMTH(4,IR)=PMTH(3,IR)
70102 PMTH(5,IR)=PMTH(3,IR)
70103 ENDIF
70104 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
70105 PM=PM+PMA(I)
70106 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
70107 DO 160 J=1,4
70108 PS(J)=PS(J)+P(IPA(I),J)
70109 160 CONTINUE
70110 170 CONTINUE
70111 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
70112 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
70113 IF(NPA.EQ.1) PS(5)=PS(4)
70114 IF(PS(5).LE.PM+PMQT1E) RETURN
70115
70116C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
70117 KFSRCE=0
70118 IF(IP2.LE.0) THEN
70119 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
70120 KFSRCE=IABS(K(K(IP1,3),2))
70121 ELSE
70122 IPAR1=MAX(1,K(IP1,3))
70123 IPAR2=MAX(1,K(IP2,3))
70124 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
70125 & KFSRCE=IABS(K(K(IPAR1,3),2))
70126 ENDIF
70127 ITYPES=0
70128 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
70129 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
70130 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
70131 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
70132 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
70133 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
70134 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
70135 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
70136
70137C...Identify two primary showerers.
70138 ITYPE1=0
70139 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
70140 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
70141 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
70142 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
70143 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
70144 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
70145 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
70146 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
70147 ITYPE2=0
70148 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
70149 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
70150 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
70151 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
70152 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
70153 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
70154 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
70155 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
70156
70157C...Order of showerers. Presence of gluino.
70158 ITYPMN=MIN(ITYPE1,ITYPE2)
70159 ITYPMX=MAX(ITYPE1,ITYPE2)
70160 IORD=1
70161 IF(ITYPE1.GT.ITYPE2) IORD=2
70162 IGLUI=0
70163 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
70164
70165C...Check if 3-jet matrix elements to be used.
70166 M3JC=0
70167 ALPHA=0.5D0
70168 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
70169 IF(MSTJ(38).NE.0) THEN
70170 M3JC=MSTJ(38)
70171 ALPHA=PARJ(80)
70172 MSTJ(38)=0
70173 ELSEIF(MSTJ(47).GE.6) THEN
70174 M3JC=MSTJ(47)
70175 ELSE
70176 ICLASS=1
70177 ICOMBI=4
70178
70179C...Vector/axial vector -> q + qbar; q -> q + V.
70180 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
70181 & ITYPES.EQ.3)) THEN
70182 ICLASS=2
70183 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
70184 ICOMBI=1
70185 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
70186 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
70187C...gamma*/Z0: assume e+e- initial state if unknown.
70188 EI=-1D0
70189 IF(KFSRCE.EQ.23) THEN
70190 IANNFL=K(K(IP1,3),3)
70191 IF(IANNFL.NE.0) THEN
70192 KANNFL=IABS(K(IANNFL,2))
70193 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
70194 ENDIF
70195 ENDIF
70196 AI=SIGN(1D0,EI+0.1D0)
70197 VI=AI-4D0*EI*PARU(102)
70198 EF=KCHG(KFLA(1),1)/3D0
70199 AF=SIGN(1D0,EF+0.1D0)
70200 VF=AF-4D0*EF*PARU(102)
70201 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
70202 SH=PS(5)**2
70203 SQMZ=PMAS(23,1)**2
70204 SQWZ=PS(5)*PMAS(23,2)
70205 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
70206 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
70207 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
70208 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
70209 ICOMBI=3
70210 ALPHA=VECT/(VECT+AXIV)
70211 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
70212 ICOMBI=4
70213 ENDIF
70214C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
70215 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
70216 ICLASS=2
70217 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70218 & ITYPES.EQ.1)) THEN
70219 ICLASS=3
70220
70221C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
70222 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
70223 ICLASS=4
70224 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
70225 ICOMBI=1
70226 ELSEIF(KFSRCE.EQ.36) THEN
70227 ICOMBI=2
70228 ENDIF
70229 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70230 & ITYPES.EQ.1)) THEN
70231 ICLASS=5
70232
70233C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
70234 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70235 & ITYPES.EQ.3)) THEN
70236 ICLASS=6
70237 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70238 & ITYPES.EQ.2)) THEN
70239 ICLASS=7
70240 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
70241 ICLASS=8
70242 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70243 & ITYPES.EQ.2)) THEN
70244 ICLASS=9
70245
70246C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
70247 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70248 & ITYPES.EQ.5)) THEN
70249 ICLASS=10
70250 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70251 & ITYPES.EQ.2)) THEN
70252 ICLASS=11
70253 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70254 & ITYPES.EQ.1)) THEN
70255 ICLASS=12
70256
70257C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
70258 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
70259 ICLASS=13
70260 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70261 & ITYPES.EQ.2)) THEN
70262 ICLASS=14
70263 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70264 & ITYPES.EQ.1)) THEN
70265 ICLASS=15
70266
70267C...g -> ~g + ~g (eikonal approximation).
70268 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
70269 ICLASS=16
70270 ENDIF
70271 M3JC=5*ICLASS+ICOMBI
70272 ENDIF
70273 ENDIF
70274
70275C...Find if interference with initial state partons.
70276 MIIS=0
70277 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
70278 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
70279 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
70280 &MIIS=MSTJ(50)-3
70281 IF(MIIS.NE.0) THEN
70282 DO 190 I=1,2
70283 KCII(I)=0
70284 KCA=PYCOMP(KFLA(I))
70285 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
70286 NIIS(I)=0
70287 IF(KCII(I).NE.0) THEN
70288 DO 180 J=1,2
70289 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
70290 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
70291 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
70292 NIIS(I)=NIIS(I)+1
70293 IIIS(I,NIIS(I))=ICSI
70294 ENDIF
70295 180 CONTINUE
70296 ENDIF
70297 190 CONTINUE
70298 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
70299 ENDIF
70300
70301C...Boost interfering initial partons to rest frame
70302C...and reconstruct their polar and azimuthal angles.
70303 IF(MIIS.NE.0) THEN
70304 DO 210 I=1,2
70305 DO 200 J=1,5
70306 K(N+I,J)=K(IPA(I),J)
70307 P(N+I,J)=P(IPA(I),J)
70308 V(N+I,J)=0D0
70309 200 CONTINUE
70310 210 CONTINUE
70311 DO 230 I=3,2+NIIS(1)
70312 DO 220 J=1,5
70313 K(N+I,J)=K(IIIS(1,I-2),J)
70314 P(N+I,J)=P(IIIS(1,I-2),J)
70315 V(N+I,J)=0D0
70316 220 CONTINUE
70317 230 CONTINUE
70318 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
70319 DO 240 J=1,5
70320 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
70321 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
70322 V(N+I,J)=0D0
70323 240 CONTINUE
70324 250 CONTINUE
70325 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
70326 & -PS(2)/PS(4),-PS(3)/PS(4))
70327 PHI=PYANGL(P(N+1,1),P(N+1,2))
70328 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
70329 THE=PYANGL(P(N+1,3),P(N+1,1))
70330 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
70331 DO 260 I=3,2+NIIS(1)
70332 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
70333 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
70334 260 CONTINUE
70335 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
70336 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
70337 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
70338 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
70339 270 CONTINUE
70340 ENDIF
70341
70342C...Boost 3 or more partons to their rest frame.
70343 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
70344 &-PS(2)/PS(4),-PS(3)/PS(4))
70345
70346C...Define imagined single initiator of shower for parton system.
70347 NS=N
70348 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
70349 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
70350 IF(MSTU(21).GE.1) RETURN
70351 ENDIF
70352 280 N=NS
70353 IF(NPA.GE.2) THEN
70354 K(N+1,1)=11
70355 K(N+1,2)=21
70356 K(N+1,3)=0
70357 K(N+1,4)=0
70358 K(N+1,5)=0
70359 P(N+1,1)=0D0
70360 P(N+1,2)=0D0
70361 P(N+1,3)=0D0
70362 P(N+1,4)=PS(5)
70363 P(N+1,5)=PS(5)
70364 V(N+1,5)=PS(5)**2
70365 N=N+1
70366 IREF(1)=21
70367 ENDIF
70368
70369C...Loop over partons that may branch.
70370 NEP=NPA
70371 IM=NS
70372 IF(NPA.EQ.1) IM=NS-1
70373 290 IM=IM+1
70374 IF(N.GT.NS) THEN
70375 IF(IM.GT.N) GOTO 600
70376 KFLM=IABS(K(IM,2))
70377 IR=IREF(IM-NS)
70378 IF(KSH(IR).EQ.0) GOTO 290
70379 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
70380 IGM=K(IM,3)
70381 ELSE
70382 IGM=-1
70383 ENDIF
70384 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
70385 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
70386 IF(MSTU(21).GE.1) RETURN
70387 ENDIF
70388
70389C...Position of aunt (sister to branching parton).
70390C...Origin and flavour of daughters.
70391 IAU=0
70392 IF(IGM.GT.0) THEN
70393 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
70394 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
70395 ENDIF
70396 IF(IGM.GE.0) THEN
70397 K(IM,4)=N+1
70398 DO 300 I=1,NEP
70399 K(N+I,3)=IM
70400 300 CONTINUE
70401 ELSE
70402 K(N+1,3)=IPA(1)
70403 ENDIF
70404 IF(IGM.LE.0) THEN
70405 DO 310 I=1,NEP
70406 K(N+I,2)=K(IPA(I),2)
70407 310 CONTINUE
70408 ELSEIF(KFLM.NE.21) THEN
70409 K(N+1,2)=K(IM,2)
70410 K(N+2,2)=K(IM,5)
70411 IREF(N+1-NS)=IREF(IM-NS)
70412 IREF(N+2-NS)=IABS(K(N+2,2))
70413 ELSEIF(K(IM,5).EQ.21) THEN
70414 K(N+1,2)=21
70415 K(N+2,2)=21
70416 IREF(N+1-NS)=21
70417 IREF(N+2-NS)=21
70418 ELSE
70419 K(N+1,2)=K(IM,5)
70420 K(N+2,2)=-K(IM,5)
70421 IREF(N+1-NS)=IABS(K(N+1,2))
70422 IREF(N+2-NS)=IABS(K(N+2,2))
70423 ENDIF
70424
70425C...Reset flags on daughters and tries made.
70426 DO 320 IP=1,NEP
70427 K(N+IP,1)=3
70428 K(N+IP,4)=0
70429 K(N+IP,5)=0
70430 KFLD(IP)=IABS(K(N+IP,2))
70431 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
70432 ITRY(IP)=0
70433 ISL(IP)=0
70434 ISI(IP)=0
70435 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
70436 320 CONTINUE
70437 ISLM=0
70438
70439C...Maximum virtuality of daughters.
70440 IF(IGM.LE.0) THEN
70441 DO 330 I=1,NPA
70442 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
70443 P(N+I,5)=MIN(QMAX,PS(5))
70444 IR=IREF(N+I-NS)
70445 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
70446 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
70447 330 CONTINUE
70448 ELSE
70449 IF(MSTJ(43).LE.2) PEM=V(IM,2)
70450 IF(MSTJ(43).GE.3) PEM=P(IM,4)
70451 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
70452 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
70453 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
70454 ENDIF
70455 DO 340 I=1,NEP
70456 PMSD(I)=P(N+I,5)
70457 IF(ISI(I).EQ.1) THEN
70458 IR=IREF(N+I-NS)
70459 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
70460 ENDIF
70461 V(N+I,5)=P(N+I,5)**2
70462 340 CONTINUE
70463
70464C...Choose one of the daughters for evolution.
70465 350 INUM=0
70466 IF(NEP.EQ.1) INUM=1
70467 DO 360 I=1,NEP
70468 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
70469 360 CONTINUE
70470 DO 370 I=1,NEP
70471 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
70472 IR=IREF(N+I-NS)
70473 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
70474 ENDIF
70475 370 CONTINUE
70476 IF(INUM.EQ.0) THEN
70477 RMAX=0D0
70478 DO 380 I=1,NEP
70479 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
70480 RPM=P(N+I,5)/PMSD(I)
70481 IR=IREF(N+I-NS)
70482 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
70483 RMAX=RPM
70484 INUM=I
70485 ENDIF
70486 ENDIF
70487 380 CONTINUE
70488 ENDIF
70489
70490C...Cancel choice of predetermined daughter already treated.
70491 INUM=MAX(1,INUM)
70492 INUMT=INUM
70493 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
70494 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
70495 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
70496 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
70497 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
70498 ENDIF
70499
70500C...Store information on choice of evolving daughter.
70501 IEP(1)=N+INUM
70502 DO 390 I=2,NEP
70503 IEP(I)=IEP(I-1)+1
70504 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
70505 390 CONTINUE
70506 DO 400 I=1,NEP
70507 KFL(I)=IABS(K(IEP(I),2))
70508 400 CONTINUE
70509 ITRY(INUM)=ITRY(INUM)+1
70510 IF(ITRY(INUM).GT.200) THEN
70511 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
70512 IF(MSTU(21).GE.1) RETURN
70513 ENDIF
70514 Z=0.5D0
70515 IR=IREF(IEP(1)-NS)
70516 IF(KSH(IR).EQ.0) GOTO 450
70517 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
70518
70519C...Check if evolution already predetermined for daughter.
70520 IPSPD=0
70521 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
70522 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
70523 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
70524 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
70525 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
70526 ENDIF
70527 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
70528 ISSET(INUM)=0
70529 IF(IPSPD.NE.0) ISSET(INUM)=1
70530 ENDIF
70531
70532C...Select side for interference with initial state partons.
70533 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
70534 III=IEP(1)-NS-1
70535 ISII(III)=0
70536 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
70537 ISII(III)=1
70538 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
70539 IF(PYR(0).GT.0.5D0) ISII(III)=1
70540 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
70541 ISII(III)=1
70542 IF(PYR(0).GT.0.5D0) ISII(III)=2
70543 ENDIF
70544 ENDIF
70545
70546C...Calculate allowed z range.
70547 IF(NEP.EQ.1) THEN
70548 PMED=PS(4)
70549 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
70550 PMED=P(IM,5)
70551 ELSE
70552 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
70553 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
70554 ENDIF
70555 IF(MOD(MSTJ(43),2).EQ.1) THEN
70556 ZC=PMTH(2,21)/PMED
70557 ZCE=PMTH(2,22)/PMED
70558 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
70559 ELSE
70560 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
70561 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
70562 PMTMPE=PMTH(2,22)
70563 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
70564 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
70565 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
70566 ENDIF
70567 ZC=MIN(ZC,0.491D0)
70568 ZCE=MIN(ZCE,0.49991D0)
70569 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
70570 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
70571 P(IEP(1),5)=PMTH(1,IR)
70572 V(IEP(1),5)=P(IEP(1),5)**2
70573 GOTO 450
70574 ENDIF
70575
70576C...Integral of Altarelli-Parisi z kernel for QCD.
70577C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
70578 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
70579 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
70580C...QUARKONIA+++
70581C...Evolution of QQ~[3S18] state if MSTP(148)=1.
70582 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
70583 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
70584 FBR=6D0*LOG((1D0-ZC)/ZC)
70585C...QUARKONIA---
70586 ELSEIF(MSTJ(49).EQ.0) THEN
70587 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
70588 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
70589
70590C...Integral of Altarelli-Parisi z kernel for scalar gluon.
70591 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
70592 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
70593 ELSEIF(MSTJ(49).EQ.1) THEN
70594 FBR=(1D0-2D0*ZC)/3D0
70595 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
70596
70597C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
70598 ELSEIF(KFL(1).EQ.21) THEN
70599 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
70600 ELSE
70601 FBR=2D0*LOG((1D0-ZC)/ZC)
70602 ENDIF
70603
70604C...Reset QCD probability for colourless.
70605 IF(ISCOL(IR).EQ.0) FBR=0D0
70606
70607C...Integral of Altarelli-Parisi kernel for photon emission.
70608 FBRE=0D0
70609 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
70610 IF(KFL(1).LE.18) THEN
70611 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
70612 ENDIF
70613 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
70614 ENDIF
70615
70616C...Inner veto algorithm starts. Find maximum mass for evolution.
70617 410 PMS=V(IEP(1),5)
70618 IF(IGM.GE.0) THEN
70619 PM2=0D0
70620 DO 420 I=2,NEP
70621 PM=P(IEP(I),5)
70622 IRI=IREF(IEP(I)-NS)
70623 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
70624 PM2=PM2+PM
70625 420 CONTINUE
70626 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
70627 ENDIF
70628
70629C...Select mass for daughter in QCD evolution.
70630 B0=27D0/6D0
70631 DO 430 IFF=4,MSTJ(45)
70632 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
70633 430 CONTINUE
70634C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
70635 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
70636C...Already predetermined choice.
70637 IF(IPSPD.NE.0) THEN
70638 PMSQCD=P(IPSPD,5)**2
70639 ELSEIF(FBR.LT.1D-3) THEN
70640 PMSQCD=0D0
70641 ELSEIF(MSTJ(44).LE.0) THEN
70642 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
70643 ELSEIF(MSTJ(44).EQ.1) THEN
70644 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
70645 ELSE
70646 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
70647 ENDIF
70648C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
70649 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
70650 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
70651 V(IEP(1),5)=PMSQCD
70652 MCE=1
70653
70654C...Select mass for daughter in QED evolution.
70655 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
70656C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
70657 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
70658 IF(FBRE.LT.1D-3) THEN
70659 PMSQED=0D0
70660 ELSE
70661 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
70662 & (PARU(101)*FBRE)))
70663 ENDIF
70664C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
70665 PMSQED=PMSQED+PMTH(1,IR)**2
70666 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
70667 & PMTH(2,IR)**2
70668 IF(PMSQED.GT.PMSQCD) THEN
70669 V(IEP(1),5)=PMSQED
70670 MCE=2
70671 ENDIF
70672 ENDIF
70673
70674C...Check whether daughter mass below cutoff.
70675 P(IEP(1),5)=SQRT(V(IEP(1),5))
70676 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
70677 P(IEP(1),5)=PMTH(1,IR)
70678 V(IEP(1),5)=P(IEP(1),5)**2
70679 GOTO 450
70680 ENDIF
70681
70682C...Already predetermined choice of z, and flavour in g -> qqbar.
70683 IF(IPSPD.NE.0) THEN
70684 IPSGD1=K(IPSPD,4)
70685 IPSGD2=K(IPSPD,5)
70686 PMSGD1=P(IPSGD1,5)**2
70687 PMSGD2=P(IPSGD2,5)**2
70688 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
70689 & 4D0*PMSGD1*PMSGD2))
70690 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
70691 & PMSGD1+PMSGD2)/ALAMPS
70692 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
70693 IF(KFL(1).NE.21) THEN
70694 K(IEP(1),5)=21
70695 ELSE
70696 K(IEP(1),5)=IABS(K(IPSGD1,2))
70697 ENDIF
70698
70699C...Select z value of branching: q -> qgamma.
70700 ELSEIF(MCE.EQ.2) THEN
70701 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
70702 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
70703 K(IEP(1),5)=22
70704
70705C...QUARKONIA+++
70706C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
70707 ELSEIF(MSTJ(49).EQ.0.AND.
70708 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
70709 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
70710C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
70711 IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
70712 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
70713 K(IEP(1),5)=21
70714C...QUARKONIA---
70715
70716C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
70717 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
70718 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
70719C...Only do z weighting when no ME correction afterwards.
70720 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
70721 K(IEP(1),5)=21
70722 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
70723 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
70724 IF(PYR(0).GT.0.5D0) Z=1D0-Z
70725 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
70726 K(IEP(1),5)=21
70727 ELSEIF(MSTJ(49).NE.1) THEN
70728 Z=PYR(0)
70729 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
70730 KFLB=1+INT(MSTJ(45)*PYR(0))
70731 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
70732 IF(PMQ.GE.1D0) GOTO 410
70733 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
70734 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
70735 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
70736 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
70737 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
70738 ELSE
70739 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
70740 ENDIF
70741 K(IEP(1),5)=KFLB
70742
70743C...Ditto for scalar gluon model.
70744 ELSEIF(KFL(1).NE.21) THEN
70745 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
70746 K(IEP(1),5)=21
70747 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
70748 Z=ZC+(1D0-2D0*ZC)*PYR(0)
70749 K(IEP(1),5)=21
70750 ELSE
70751 Z=ZC+(1D0-2D0*ZC)*PYR(0)
70752 KFLB=1+INT(MSTJ(45)*PYR(0))
70753 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
70754 IF(PMQ.GE.1D0) GOTO 410
70755 K(IEP(1),5)=KFLB
70756 ENDIF
70757
70758C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
70759 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
70760 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
70761 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
70762 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
70763 ELSE
70764 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
70765 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
70766 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
70767 IF(PT2APP.LT.PT2MIN) GOTO 410
70768 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
70769 ENDIF
70770 ENDIF
70771
70772C...Check if z consistent with chosen m.
70773 IF(KFL(1).EQ.21) THEN
70774 IRGD1=IABS(K(IEP(1),5))
70775 IRGD2=IRGD1
70776 ELSE
70777 IRGD1=IR
70778 IRGD2=IABS(K(IEP(1),5))
70779 ENDIF
70780 IF(NEP.EQ.1) THEN
70781 PED=PS(4)
70782 ELSEIF(NEP.GE.3) THEN
70783 PED=P(IEP(1),4)
70784 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
70785 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
70786 ELSE
70787 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
70788 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
70789 ENDIF
70790 IF(MOD(MSTJ(43),2).EQ.1) THEN
70791 PMQTH3=0.5D0*PARJ(82)
70792 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
70793 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
70794 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
70795 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
70796 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
70797 & 4D0*PMQ1*PMQ2)))
70798 ZH=1D0+PMQ1-PMQ2
70799 ELSE
70800 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
70801 ZH=1D0
70802 ENDIF
70803 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
70804 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
70805 ELSEIF(IPSPD.NE.0) THEN
70806 ELSE
70807 ZL=0.5D0*(ZH-ZD)
70808 ZU=0.5D0*(ZH+ZD)
70809 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
70810 ENDIF
70811 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
70812 &(1D0-ZU)))
70813 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
70814
70815C...Width suppression for q -> q + g.
70816 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
70817 IF(IGM.EQ.0) THEN
70818 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
70819 ELSE
70820 EGLU=PMED*(1D0-Z)
70821 ENDIF
70822 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
70823 IF(MSTJ(40).EQ.1) THEN
70824 IF(CHI.LT.PYR(0)) GOTO 410
70825 ELSEIF(MSTJ(40).EQ.2) THEN
70826 IF(1D0-CHI.LT.PYR(0)) GOTO 410
70827 ENDIF
70828 ENDIF
70829
70830C...Three-jet matrix element correction.
70831 IF(M3JC.GE.1) THEN
70832 WME=1D0
70833 WSHOW=1D0
70834
70835C...QED matrix elements: only for massless case so far.
70836 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
70837 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
70838 X2=1D0-V(IEP(1),5)/V(NS+1,5)
70839 X3=(1D0-X1)+(1D0-X2)
70840 KI1=K(IPA(INUM),2)
70841 KI2=K(IPA(3-INUM),2)
70842 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
70843 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
70844 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
70845 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
70846 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
70847 ELSEIF(MCE.EQ.2) THEN
70848
70849C...QCD matrix elements, including mass effects.
70850 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
70851 PS1ME=V(IEP(1),5)
70852 PM1ME=PMTH(1,IR)
70853 M3JCC=M3JC
70854 IF(IR.GE.31.AND.IGM.EQ.0) THEN
70855C...QCD ME: original parton, first branching.
70856 PM2ME=PMTH(1,63-IR)
70857 ECMME=PS(5)
70858 ELSEIF(IR.GE.31) THEN
70859C...QCD ME: original parton, subsequent branchings.
70860 PM2ME=PMTH(1,63-IR)
70861 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
70862 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
70863 ELSEIF(K(IM,2).EQ.21) THEN
70864C...QCD ME: secondary partons, first branching.
70865 PM2ME=PM1ME
70866 ZMME=V(IM,1)
70867 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
70868 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
70869 & 4D0*PS1ME*PM2ME**2))
70870 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
70871 & V(IM,5)
70872 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
70873 M3JCC=66
70874 ELSE
70875C...QCD ME: secondary partons, subsequent branchings.
70876 PM2ME=PM1ME
70877 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
70878 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
70879 M3JCC=66
70880 ENDIF
70881C...Construct ME variables.
70882 R1ME=PM1ME/ECMME
70883 R2ME=PM2ME/ECMME
70884 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
70885 X2=1D0+R2ME**2-PS1ME/ECMME**2
70886C...Call ME, with right order important for two inequivalent showerers.
70887 IF(IR.EQ.IORD+30) THEN
70888 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
70889 ELSE
70890 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
70891 ENDIF
70892C...Split up total ME when two radiating partons.
70893 ISPRAD=1
70894 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
70895 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
70896 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
70897 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
70898 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
70899 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
70900 & MAX(1D-10,2D0-X1-X2)
70901C...Evaluate shower rate to be compared with.
70902 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
70903 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70904 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
70905 ELSEIF(MSTJ(49).NE.1) THEN
70906
70907C...Toy model scalar theory matrix elements; no mass effects.
70908 ELSE
70909 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
70910 X2=1D0-V(IEP(1),5)/V(NS+1,5)
70911 X3=(1D0-X1)+(1D0-X2)
70912 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
70913 WME=X3**2
70914 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
70915 & PARJ(171)
70916 ENDIF
70917
70918 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
70919 ENDIF
70920
70921C...Impose angular ordering by rejection of nonordered emission.
70922 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
70923 PEMAO=V(IM,1)*P(IM,4)
70924 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
70925 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
70926 MAOD=0
70927 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
70928 & .OR.MSTJ(42).EQ.7)) THEN
70929 MAOD=0
70930 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
70931 & .OR.MSTJ(42).EQ.6)) THEN
70932 MAOD=1
70933 PMDAO=PMTH(2,K(IEP(1),5))
70934 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
70935 ELSE
70936 MAOD=1
70937 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
70938 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
70939 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
70940 ENDIF
70941 MAOM=1
70942 IAOM=IM
70943 440 IF(K(IAOM,5).EQ.22) THEN
70944 IAOM=K(IAOM,3)
70945 IF(K(IAOM,3).LE.NS) MAOM=0
70946 IF(MAOM.EQ.1) GOTO 440
70947 ENDIF
70948 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
70949 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
70950 IF(THE2ID.LT.THE2IM) GOTO 410
70951 ENDIF
70952 ENDIF
70953
70954C...Impose user-defined maximum angle at first branching.
70955 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
70956 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
70957 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
70958 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
70959 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
70960 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
70961 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
70962 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
70963 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
70964 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
70965 ENDIF
70966 ENDIF
70967
70968C...Impose angular constraint in first branching from interference
70969C...with initial state partons.
70970 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
70971 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
70972 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
70973 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
70974 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
70975 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
70976 ENDIF
70977 ENDIF
70978
70979C...End of inner veto algorithm. Check if only one leg evolved so far.
70980 450 V(IEP(1),1)=Z
70981 ISL(1)=0
70982 ISL(2)=0
70983 IF(NEP.EQ.1) GOTO 490
70984 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
70985 DO 460 I=1,NEP
70986 IR=IREF(N+I-NS)
70987 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
70988 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
70989 ENDIF
70990 460 CONTINUE
70991
70992C...Check if chosen multiplet m1,m2,z1,z2 is physical.
70993 IF(NEP.GE.3) THEN
70994 PMSUM=0D0
70995 DO 470 I=1,NEP
70996 PMSUM=PMSUM+P(N+I,5)
70997 470 CONTINUE
70998 IF(PMSUM.GE.PS(5)) GOTO 350
70999 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
71000 DO 480 I1=N+1,N+2
71001 IRDA=IREF(I1-NS)
71002 IF(KSH(IRDA).EQ.0) GOTO 480
71003 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
71004 IF(IRDA.EQ.21) THEN
71005 IRGD1=IABS(K(I1,5))
71006 IRGD2=IRGD1
71007 ELSE
71008 IRGD1=IRDA
71009 IRGD2=IABS(K(I1,5))
71010 ENDIF
71011 I2=2*N+3-I1
71012 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
71013 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
71014 ELSE
71015 IF(I1.EQ.N+1) ZM=V(IM,1)
71016 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
71017 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
71018 & 4D0*V(N+1,5)*V(N+2,5))
71019 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
71020 & V(IM,5)
71021 ENDIF
71022 IF(MOD(MSTJ(43),2).EQ.1) THEN
71023 PMQTH3=0.5D0*PARJ(82)
71024 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
71025 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
71026 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
71027 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
71028 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
71029 & 4D0*PMQ1*PMQ2)))
71030 ZH=1D0+PMQ1-PMQ2
71031 ELSE
71032 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
71033 ZH=1D0
71034 ENDIF
71035 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
71036 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71037 ELSE
71038 ZL=0.5D0*(ZH-ZD)
71039 ZU=0.5D0*(ZH+ZD)
71040 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
71041 & ISSET(1).EQ.0) THEN
71042 ISL(1)=1
71043 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
71044 & ISSET(2).EQ.0) THEN
71045 ISL(2)=1
71046 ENDIF
71047 ENDIF
71048 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
71049 & ZL*(1D0-ZU)))
71050 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
71051 480 CONTINUE
71052 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
71053 ISL(3-ISLM)=0
71054 ISLM=3-ISLM
71055 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
71056 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
71057 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
71058 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
71059 IF(ISL(1).EQ.1) ISL(2)=0
71060 IF(ISL(1).EQ.0) ISLM=1
71061 IF(ISL(2).EQ.0) ISLM=2
71062 ENDIF
71063 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
71064 ENDIF
71065 IRD1=IREF(N+1-NS)
71066 IRD2=IREF(N+2-NS)
71067 IF(IGM.GT.0) THEN
71068 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
71069 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
71070 PMQ1=V(N+1,5)/V(IM,5)
71071 PMQ2=V(N+2,5)/V(IM,5)
71072 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
71073 & 4D0*PMQ1*PMQ2)))
71074 ZH=1D0+PMQ1-PMQ2
71075 ZL=0.5D0*(ZH-ZD)
71076 ZU=0.5D0*(ZH+ZD)
71077 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
71078 ENDIF
71079 ENDIF
71080
71081C...Accepted branch. Construct four-momentum for initial partons.
71082 490 MAZIP=0
71083 MAZIC=0
71084 IF(NEP.EQ.1) THEN
71085 P(N+1,1)=0D0
71086 P(N+1,2)=0D0
71087 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
71088 & P(N+1,5))))
71089 P(N+1,4)=P(IPA(1),4)
71090 V(N+1,2)=P(N+1,4)
71091 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
71092 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
71093 P(N+1,1)=0D0
71094 P(N+1,2)=0D0
71095 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
71096 P(N+1,4)=PED1
71097 P(N+2,1)=0D0
71098 P(N+2,2)=0D0
71099 P(N+2,3)=-P(N+1,3)
71100 P(N+2,4)=P(IM,5)-PED1
71101 V(N+1,2)=P(N+1,4)
71102 V(N+2,2)=P(N+2,4)
71103 ELSEIF(NEP.GE.3) THEN
71104C...Rescale all momenta for energy conservation.
71105 LOOP=0
71106 PES=0D0
71107 PQS=0D0
71108 DO 510 I=1,NEP
71109 DO 500 J=1,4
71110 P(N+I,J)=P(IPA(I),J)
71111 500 CONTINUE
71112 PES=PES+P(N+I,4)
71113 PQS=PQS+P(N+I,5)**2/P(N+I,4)
71114 510 CONTINUE
71115 520 LOOP=LOOP+1
71116 FAC=(PS(5)-PQS)/(PES-PQS)
71117 PES=0D0
71118 PQS=0D0
71119 DO 540 I=1,NEP
71120 DO 530 J=1,3
71121 P(N+I,J)=FAC*P(N+I,J)
71122 530 CONTINUE
71123 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)
71124 V(N+I,2)=P(N+I,4)
71125 PES=PES+P(N+I,4)
71126 PQS=PQS+P(N+I,5)**2/P(N+I,4)
71127 540 CONTINUE
71128 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
71129
71130C...Construct transverse momentum for ordinary branching in shower.
71131 ELSE
71132 ZM=V(IM,1)
71133 LOOPPT=0
71134 550 LOOPPT=LOOPPT+1
71135 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
71136 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
71137 IF(PZM.LE.0D0) THEN
71138 PTS=0D0
71139 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
71140 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71141 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
71142 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
71143 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
71144 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
71145 ELSE
71146 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
71147 ENDIF
71148 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
71149 ZM=0.05D0+0.9D0*ZM
71150 GOTO 550
71151 ELSEIF(PTS.LT.0D0) THEN
71152 GOTO 280
71153 ENDIF
71154 PT=SQRT(MAX(0D0,PTS))
71155
71156C...Global statistics.
71157 MINT(353)=MINT(353)+1
71158 VINT(353)=VINT(353)+PT
71159 IF (MINT(353).EQ.1) VINT(358)=PT
71160
71161C...Find coefficient of azimuthal asymmetry due to gluon polarization.
71162 HAZIP=0D0
71163 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
71164 & .AND.IAU.NE.0) THEN
71165 IF(K(IGM,3).NE.0) MAZIP=1
71166 ZAU=V(IGM,1)
71167 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
71168 IF(MAZIP.EQ.0) ZAU=0D0
71169 IF(K(IGM,2).NE.21) THEN
71170 HAZIP=2D0*ZAU/(1D0+ZAU**2)
71171 ELSE
71172 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
71173 ENDIF
71174 IF(K(N+1,2).NE.21) THEN
71175 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
71176 ELSE
71177 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
71178 ENDIF
71179 ENDIF
71180
71181C...Find coefficient of azimuthal asymmetry due to soft gluon
71182C...interference.
71183 HAZIC=0D0
71184 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
71185 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
71186 IF(K(IGM,3).NE.0) MAZIC=N+1
71187 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
71188 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
71189 & ZM.GT.0.5D0) MAZIC=N+2
71190 IF(K(IAU,2).EQ.22) MAZIC=0
71191 ZS=ZM
71192 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
71193 ZGM=V(IGM,1)
71194 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
71195 IF(MAZIC.EQ.0) ZGM=1D0
71196 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
71197 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
71198 HAZIC=MIN(0.95D0,HAZIC)
71199 ENDIF
71200 ENDIF
71201
71202C...Construct energies for ordinary branching in shower.
71203 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
71204 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
71205 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71206 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
71207 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
71208 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
71209 P(N+1,4)=PEM*V(IM,1)
71210 ELSE
71211 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
71212 & SQRT(PMLS)*ZM)/V(IM,5)
71213 ENDIF
71214
71215C...Already predetermined choice of phi angle or not
71216 PHI=PARU(2)*PYR(0)
71217 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
71218 IPSPD=IP1+IM-NS-2
71219 IF(K(IPSPD,4).GT.0) THEN
71220 IPSGD1=K(IPSPD,4)
71221 IF(IM.EQ.NS+2) THEN
71222 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
71223 ELSE
71224 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
71225 ENDIF
71226 ENDIF
71227 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
71228 IPSPD=IP1+IM-NS-2
71229 IF(K(IPSPD,4).GT.0) THEN
71230 IPSGD1=K(IPSPD,4)
71231 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
71232 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
71233 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
71234 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
71235 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
71236 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
71237 ENDIF
71238 ENDIF
71239
71240C...Construct momenta for ordinary branching in shower.
71241 P(N+1,1)=PT*COS(PHI)
71242 P(N+1,2)=PT*SIN(PHI)
71243 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
71244 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71245 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
71246 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
71247 ELSEIF(PZM.GT.0D0) THEN
71248 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
71249 & 2D0*PEM*P(N+1,4))/PZM
71250 ELSE
71251 P(N+1,3)=0D0
71252 ENDIF
71253 P(N+2,1)=-P(N+1,1)
71254 P(N+2,2)=-P(N+1,2)
71255 P(N+2,3)=PZM-P(N+1,3)
71256 P(N+2,4)=PEM-P(N+1,4)
71257 IF(MSTJ(43).LE.2) THEN
71258 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
71259 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
71260 ENDIF
71261 ENDIF
71262
71263C...Rotate and boost daughters.
71264 IF(IGM.GT.0) THEN
71265 IF(MSTJ(43).LE.2) THEN
71266 BEX=P(IGM,1)/P(IGM,4)
71267 BEY=P(IGM,2)/P(IGM,4)
71268 BEZ=P(IGM,3)/P(IGM,4)
71269 GA=P(IGM,4)/P(IGM,5)
71270 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
71271 & P(IM,4))
71272 ELSE
71273 BEX=0D0
71274 BEY=0D0
71275 BEZ=0D0
71276 GA=1D0
71277 GABEP=0D0
71278 ENDIF
71279 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
71280 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
71281 IF(PTIMB.GT.1D-4) THEN
71282 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
71283 ELSE
71284 PHI=0D0
71285 ENDIF
71286 DO 570 I=N+1,N+2
71287 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
71288 & SIN(THE)*COS(PHI)*P(I,3)
71289 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
71290 & SIN(THE)*SIN(PHI)*P(I,3)
71291 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
71292 DP(4)=P(I,4)
71293 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
71294 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
71295 P(I,1)=DP(1)+DGABP*BEX
71296 P(I,2)=DP(2)+DGABP*BEY
71297 P(I,3)=DP(3)+DGABP*BEZ
71298 P(I,4)=GA*(DP(4)+DBP)
71299 570 CONTINUE
71300 ENDIF
71301
71302C...Weight with azimuthal distribution, if required.
71303 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
71304 DO 580 J=1,3
71305 DPT(1,J)=P(IM,J)
71306 DPT(2,J)=P(IAU,J)
71307 DPT(3,J)=P(N+1,J)
71308 580 CONTINUE
71309 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
71310 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
71311 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
71312 DO 590 J=1,3
71313 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
71314 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
71315 590 CONTINUE
71316 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
71317 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
71318 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
71319 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
71320 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
71321 IF(MAZIP.NE.0) THEN
71322 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
71323 & GOTO 560
71324 ENDIF
71325 IF(MAZIC.NE.0) THEN
71326 IF(MAZIC.EQ.N+2) CAD=-CAD
71327 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
71328 & .LT.PYR(0)) GOTO 560
71329 ENDIF
71330 ENDIF
71331 ENDIF
71332
71333C...Azimuthal anisotropy due to interference with initial state partons.
71334 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
71335 &K(N+2,2).EQ.21)) THEN
71336 III=IM-NS-1
71337 IF(ISII(III).GE.1) THEN
71338 IAZIID=N+1
71339 IF(K(N+1,2).NE.21) IAZIID=N+2
71340 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
71341 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
71342 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
71343 IF(III.EQ.2) THEIID=PARU(1)-THEIID
71344 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
71345 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
71346 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
71347 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
71348 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
71349 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
71350 & .LT.PYR(0)) GOTO 560
71351 ENDIF
71352 ENDIF
71353
71354C...Continue loop over partons that may branch, until none left.
71355 IF(IGM.GE.0) K(IM,1)=14
71356 N=N+NEP
71357 NEP=2
71358 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
71359 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
71360 IF(MSTU(21).GE.1) N=NS
71361 IF(MSTU(21).GE.1) RETURN
71362 ENDIF
71363 GOTO 290
71364
71365C...Set information on imagined shower initiator.
71366 600 IF(NPA.GE.2) THEN
71367 K(NS+1,1)=11
71368 K(NS+1,2)=94
71369 K(NS+1,3)=IP1
71370 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
71371 K(NS+1,4)=NS+2
71372 K(NS+1,5)=NS+1+NPA
71373 IIM=1
71374 ELSE
71375 IIM=0
71376 ENDIF
71377
71378C...Reconstruct string drawing information.
71379 DO 610 I=NS+1+IIM,N
71380 KQ=KCHG(PYCOMP(K(I,2)),2)
71381 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
71382 K(I,1)=1
71383 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
71384 & IABS(K(I,2)).LE.18) THEN
71385 K(I,1)=1
71386 ELSEIF(K(I,1).LE.10) THEN
71387 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
71388 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
71389 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
71390 ID1=MOD(K(I,4),MSTU(5))
71391 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
71392 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
71393 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
71394 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
71395 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
71396 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
71397 K(ID1,4)=K(ID1,4)+MSTU(5)*I
71398 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
71399 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
71400 K(ID2,5)=K(ID2,5)+MSTU(5)*I
71401 ELSE
71402 ID1=MOD(K(I,4),MSTU(5))
71403 ID2=ID1+1
71404 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
71405 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
71406 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
71407 K(ID1,4)=K(ID1,4)+MSTU(5)*I
71408 K(ID1,5)=K(ID1,5)+MSTU(5)*I
71409 ELSE
71410 K(ID1,4)=0
71411 K(ID1,5)=0
71412 ENDIF
71413 K(ID2,4)=0
71414 K(ID2,5)=0
71415 ENDIF
71416 610 CONTINUE
71417
71418C...Transformation from CM frame.
71419 IF(NPA.EQ.1) THEN
71420 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
71421 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
71422 MSTU(33)=1
71423 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
71424 ELSEIF(NPA.EQ.2) THEN
71425 BEX=PS(1)/PS(4)
71426 BEY=PS(2)/PS(4)
71427 BEZ=PS(3)/PS(4)
71428 GA=PS(4)/PS(5)
71429 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
71430 & /(1D0+GA)-P(IPA(1),4))
71431 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
71432 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
71433 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
71434 MSTU(33)=1
71435 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
71436 ELSE
71437 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
71438 & PS(3)/PS(4))
71439 MSTU(33)=1
71440 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
71441 ENDIF
71442
71443C...Decay vertex of shower.
71444 DO 630 I=NS+1,N
71445 DO 620 J=1,5
71446 V(I,J)=V(IP1,J)
71447 620 CONTINUE
71448 630 CONTINUE
71449
71450C...Delete trivial shower, else connect initiators.
71451 IF(N.LE.NS+NPA+IIM) THEN
71452 N=NS
71453 ELSE
71454 DO 640 IP=1,NPA
71455 K(IPA(IP),1)=14
71456 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
71457 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
71458 K(NS+IIM+IP,3)=IPA(IP)
71459 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
71460 IF(K(NS+IIM+IP,1).NE.1) THEN
71461 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
71462 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
71463 ENDIF
71464 640 CONTINUE
71465 ENDIF
71466
71467 RETURN
71468 END
71469
71470C*********************************************************************
71471
71472C...PYPTFS
71473C...Generates pT-ordered timelike final-state parton showers.
71474
71475C...MODE defines how to find radiators and recoilers.
71476C... = 0 : based on colour flow between undecayed partons.
71477C... = 1 : for IPART <= NPARTD only consider primary partons,
71478C... whether decayed or not; else as above.
71479C... = 2 : based on common history, whether decayed or not.
71480C... = 3 : use (or create) MCT color information to shower partons
71481
71482 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
71483
71484C...Double precision and integer declarations.
71485 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71486 IMPLICIT INTEGER(I-N)
71487 INTEGER PYK,PYCHGE,PYCOMP
71488C...Parameter statement to help give large particle numbers.
71489 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71490 &KEXCIT=4000000,KDIMEN=5000000)
71491C...Parameter statement for maximum size of showers.
71492 PARAMETER (MAXNUR=1000)
71493C...Commonblocks.
71494 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
71495 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71496 COMMON/PYCTAG/NCT,MCT(4000,2)
71497 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71498 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71499 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
71500 COMMON/PYINT1/MINT(400),VINT(400)
71501 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
71502 &/PYINT1/
71503C...Local arrays.
71504 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
71505 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
71506 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
71507 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
71508C...Statement functions.
71509 SHAT(L,J)=(P(L,4)+P(J,4))**2-(P(L,1)+P(J,1))**2-
71510 &(P(L,2)+P(J,2))**2-(P(L,3)+P(J,3))**2
71511 DOTP(L,J)=P(L,4)*P(J,4)-P(L,1)*P(J,1)-P(L,2)*P(J,2)-P(L,3)*P(J,3)
71512
71513C...Initial values. Check that valid system.
71514 PTGEN=0D0
71515 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
71516 &MSTJ(41).NE.12) RETURN
71517 IF(NPART.LE.0) THEN
71518 CALL PYERRM(2,'(PYPTFS:) showering system too small')
71519 RETURN
71520 ENDIF
71521 PT2CMX=PTMAX**2
71522 IORD=1
71523
71524C...Mass thresholds and Lambda for QCD evolution.
71525 PMB=PMAS(5,1)
71526 PMC=PMAS(4,1)
71527 ALAM5=PARJ(81)
71528 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
71529 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
71530 PMBS=PMB**2
71531 PMCS=PMC**2
71532 ALAM5S=ALAM5**2
71533 ALAM4S=ALAM4**2
71534 ALAM3S=ALAM3**2
71535
71536C...Cutoff scale for QCD evolution. Starting pT2.
71537 NFLAV=MAX(0,MIN(5,MSTJ(45)))
71538 PT0C=0.5D0*PARJ(82)
71539 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
71540
71541C...Parameters for QED evolution.
71542 AEM2PI=PARU(101)/PARU(2)
71543 PT0EQ=0.5D0*PARJ(83)
71544 PT0EL=0.5D0*PARJ(90)
71545
71546C...Reset. Remove irrelevant colour tags.
71547 NEVOL=0
71548 DO 100 J=1,4
71549 PSUM(J)=0D0
71550 100 CONTINUE
71551 DO 110 I=MINT(84)+1,N
71552 IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
71553 K(I,5)=0
71554 MCT(I,2)=0
71555 ENDIF
71556 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
71557 K(I,4)=0
71558 MCT(I,1)=0
71559 ENDIF
71560 110 CONTINUE
71561 NPARTS=NPART
71562
71563C...Begin loop to set up showering partons. Sum four-momenta.
71564 DO 230 IP=1,NPART
71565 I=IPART(IP)
71566 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
71567 IF(K(I,1).GT.10) GOTO 230
71568 ELSEIF(K(I,3).GT.MINT(84)) THEN
71569 IF(K(I,3).GT.MINT(84)+2) GOTO 230
71570 ELSE
71571 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 230
71572 ENDIF
71573 DO 120 J=1,4
71574 PSUM(J)=PSUM(J)+P(I,J)
71575 120 CONTINUE
71576
71577C...Find colour and charge, but skip diquarks.
71578 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 230
71579 KCOL=PYK(I,12)
71580 KCHA=PYK(I,6)
71581
71582C...QUARKONIA++
71583 IF (IABS(K(I,2)).GE.9900101.AND.IABS(K(I,2)).LE.9910555) THEN
71584 IF (MSTP(148).GE.1) THEN
71585C...Temporary: force no radiation from quarkonia since not yet treated
71586 CALL PYERRM(11,'(PYPTFS:) quarkonia showers not yet in'
71587 & //' PYPTFS, switched off')
71588 CALL PYGIVE('MSTP(148)=0')
71589 ENDIF
71590 IF (MSTP(148).EQ.0) THEN
71591C...Skip quarkonia if radiation switched off
71592 GOTO 230
71593 ENDIF
71594 ENDIF
71595C...QUARKONIA--
71596
71597C...Option to switch off radiation from particle KF = MSTJ(39) entirely
71598C...(only intended for studying the effects of switching such rad on/off)
71599 IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) THEN
71600 GOTO 230
71601 ENDIF
71602
71603C...Either colour or anticolour charge radiates; for gluon both.
71604 DO 180 JSGCOL=1,-1,-2
71605 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
71606 JCOL=4+(1-JSGCOL)/2
71607 JCOLR=9-JCOL
71608
71609C...Basic info about radiating parton.
71610 NEVOL=NEVOL+1
71611 IPOS(NEVOL)=I
71612 IFLG(NEVOL)=0
71613 ISCOL(NEVOL)=JSGCOL
71614 ISCHG(NEVOL)=0
71615 PTSCA(NEVOL)=PTPART(IP)
71616
71617C...Begin search for colour recoiler when MODE = 0 or 1.
71618 IF(MODE.LE.1) THEN
71619C...Find sister with matching anticolour to the radiating parton.
71620 IROLD=I
71621 IRNEW=K(IROLD,JCOL)/MSTU(5)
71622 MOVE=1
71623
71624C...Skip radiation off loose colour ends.
71625 130 IF(IRNEW.EQ.0) THEN
71626 NEVOL=NEVOL-1
71627 GOTO 180
71628
71629C...Optionally skip radiation on dipole to beam remnant.
71630 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
71631 NEVOL=NEVOL-1
71632 GOTO 180
71633
71634C...For now always skip radiation on dipole to junction.
71635 ELSEIF(K(IRNEW,2).EQ.88) THEN
71636 NEVOL=NEVOL-1
71637 GOTO 180
71638
71639C...For MODE=1: if reached primary then done.
71640 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
71641 & IRNEW.LE.NPARTD) THEN
71642
71643C...If sister stable and points back then done.
71644 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
71645 & THEN
71646 IF(K(IRNEW,1).LT.10) THEN
71647
71648C...If sister unstable then go to her daughter.
71649 ELSE
71650 IROLD=IRNEW
71651 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
71652 MOVE=2
71653 GOTO 130
71654 ENDIF
71655
71656C...If found mother then look for aunt.
71657 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
71658 & IROLD) THEN
71659 IROLD=IRNEW
71660 IRNEW=K(IROLD,JCOL)/MSTU(5)
71661 GOTO 130
71662
71663C...If daughter stable then done.
71664 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
71665 & THEN
71666 IF(K(IRNEW,1).LT.10) THEN
71667
71668C...If daughter unstable then go to granddaughter.
71669 ELSE
71670 IROLD=IRNEW
71671 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
71672 MOVE=2
71673 GOTO 130
71674 ENDIF
71675
71676C...If daughter points to another daughter then done or move up.
71677 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
71678 & IROLD) THEN
71679 IF(K(IRNEW,1).LT.10) THEN
71680 ELSE
71681 IROLD=IRNEW
71682 IRNEW=K(IRNEW,JCOL)/MSTU(5)
71683 MOVE=1
71684 GOTO 130
71685 ENDIF
71686 ENDIF
71687
71688C...Begin search for colour recoiler when MODE = 2.
71689 ELSEIF (MODE.EQ.2) THEN
71690 IROLD=I
71691 IRNEW=K(IROLD,JCOL)/MSTU(5)
71692 140 IF (IRNEW.LE.0.OR.IRNEW.GT.N) THEN
71693C...If no color partner found, pick at random among other primaries
71694C...(e.g., when the color line is traced all the way to the beam)
71695 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
71696 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
71697 ELSEIF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
71698C...Step up to mother if radiating parton already branched.
71699 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
71700 IROLD=IRNEW
71701 IRNEW=K(IROLD,JCOL)/MSTU(5)
71702 GOTO 140
71703C...Pick sister by history if no anticolour available.
71704 ELSE
71705 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
71706 IRNEW=IROLD-1
71707 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
71708 & THEN
71709 IRNEW=IROLD+1
71710C...Last resort: pick at random among other primaries.
71711 ELSE
71712 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
71713 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
71714 ENDIF
71715 ENDIF
71716 ENDIF
71717C...Trace down if sister branched.
71718 150 IF(K(IRNEW,1).GT.10) THEN
71719 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
71720C...If no correct color-daughter found, swap.
71721 IF (IRTMP.EQ.0) THEN
71722 JCOL=9-JCOL
71723 JCOLR=9-JCOLR
71724 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
71725 ENDIF
71726 IRNEW=IRTMP
71727 GOTO 150
71728 ENDIF
71729 ELSEIF (MODE.EQ.3) THEN
71730C...The following will add MCT colour tracing for unprepped events
71731C...If not done, trace Les Houches colour tags for this dipole
71732 JCOLSV=JCOL
71733 IF (MCT(I,JCOL-3).EQ.0) THEN
71734C...Special end code -1 : trace to color partner or 0, return in IEND
71735 IEND=-1
71736 CALL PYCTTR(I,JCOL,IEND)
71737C...Clean up mother/daughter 'read' tags set by PYCTTR
71738 JCOL=JCOLSV
71739 DO 160 IR=1,N
71740 K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
71741 K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
71742 MCT(IR,1)=0
71743 MCT(IR,2)=0
71744 160 CONTINUE
71745 ELSE
71746 IEND=0
71747 DO 170 IR=1,N
71748 IF (K(IR,1).GT.0.AND.MCT(IR,6-JCOL).EQ.MCT(I,JCOL-3))
71749 & IEND=IR
71750 170 CONTINUE
71751 ENDIF
71752C...If no color partner, then we hit beam
71753 IF (IEND.LE.0) THEN
71754C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate
71755 IF (MSTP(72).LE.1) THEN
71756 NEVOL=NEVOL-1
71757 GOTO 180
71758 ELSE
71759C...Else try a random partner
71760 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
71761 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
71762 ENDIF
71763 ELSE
71764C...Else save recoiling colour partner
71765 IRNEW=IEND
71766 ENDIF
71767
71768 ENDIF
71769
71770C...Now found other end of colour dipole.
71771 IREC(NEVOL)=IRNEW
71772 ENDIF
71773 180 CONTINUE
71774
71775C...Also electrical charge may radiate; so far only quarks and leptons.
71776 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
71777 & IABS(K(I,2)).LE.18) THEN
71778
71779C...Basic info about radiating parton.
71780 NEVOL=NEVOL+1
71781 IPOS(NEVOL)=I
71782 IFLG(NEVOL)=0
71783 ISCOL(NEVOL)=0
71784 ISCHG(NEVOL)=KCHA
71785 PTSCA(NEVOL)=PTPART(IP)
71786
71787C...Pick nearest (= smallest invariant mass) charged particle
71788C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
71789 IF(MODE.LE.1) THEN
71790 IRNEW=0
71791 PM2MIN=VINT(2)
71792 DO 190 IP2=1,NPART+N-MINT(53)
71793 IF(IP2.EQ.IP) GOTO 190
71794 IF(IP2.LE.NPART) THEN
71795 I2=IPART(IP2)
71796 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
71797 IF(K(I2,1).GT.10) GOTO 190
71798 ELSEIF(K(I2,3).GT.MINT(84)) THEN
71799 IF(K(I2,3).GT.MINT(84)+2) GOTO 190
71800 ELSE
71801 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 190
71802 ENDIF
71803 ELSE
71804 I2=MINT(53)+IP2-NPART
71805 ENDIF
71806 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 190
71807 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
71808 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
71809 IF(PM2INV.LT.PM2MIN) THEN
71810 IRNEW=I2
71811 PM2MIN=PM2INV
71812 ENDIF
71813 190 CONTINUE
71814 IF(IRNEW.EQ.0) THEN
71815 NEVOL=NEVOL-1
71816 GOTO 230
71817 ENDIF
71818
71819C...Begin search for charge recoiler when MODE = 2.
71820 ELSE
71821 IROLD=I
71822C...Pick sister by history; step up if parton already branched.
71823 200 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
71824 IROLD=K(IROLD,3)
71825 GOTO 200
71826 ENDIF
71827 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
71828 IRNEW=IROLD-1
71829 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
71830 IRNEW=IROLD+1
71831C...Last resort: pick at random among other primaries.
71832 ELSE
71833 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
71834 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
71835 ENDIF
71836C...Trace down if sister branched.
71837 210 IF(K(IRNEW,1).GT.10) THEN
71838 DO 220 IR=IRNEW+1,N
71839 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
71840 IRNEW=IR
71841 GOTO 210
71842 ENDIF
71843 220 CONTINUE
71844 ENDIF
71845 ENDIF
71846 IREC(NEVOL)=IRNEW
71847 ENDIF
71848
71849C...End loop to set up showering partons. System invariant mass.
71850 230 CONTINUE
71851 IF(NEVOL.LE.0) RETURN
71852 IF (MODE.EQ.3.AND.NEVOL.LE.1) RETURN
71853 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
71854
71855C...Check if 3-jet matrix elements to be used.
71856 M3JC=0
71857 ALPHA=0.5D0
71858 NMESYS=0
71859 IF(MSTJ(47).GE.1) THEN
71860
71861C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
71862 KFSRCE=0
71863 IPART1=K(IPART(1),3)
71864 IPART2=K(IPART(2),3)
71865 240 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
71866 KFSRCE=IABS(K(IPART1,2))
71867 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
71868 IPART1=K(IPART1,3)
71869 GOTO 240
71870 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
71871 IPART2=K(IPART2,3)
71872 GOTO 240
71873 ENDIF
71874 ITYPES=0
71875 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
71876 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
71877 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
71878 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
71879 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
71880 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
71881 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
71882 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
71883
71884C...Identify two primary showerers.
71885 KFLA1=IABS(K(IPART(1),2))
71886 ITYPE1=0
71887 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
71888 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
71889 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
71890 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
71891 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
71892 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
71893 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
71894 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
71895 KFLA2=IABS(K(IPART(2),2))
71896 ITYPE2=0
71897 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
71898 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
71899 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
71900 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
71901 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
71902 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
71903 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
71904 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
71905
71906C...Order of showerers. Presence of gluino.
71907 ITYPMN=MIN(ITYPE1,ITYPE2)
71908 ITYPMX=MAX(ITYPE1,ITYPE2)
71909 IORD=1
71910 IF(ITYPE1.GT.ITYPE2) IORD=2
71911 IGLUI=0
71912 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
71913
71914C...Require exactly two primary showerers for ME corrections.
71915 NPRIM=0
71916 IF(IPART1.GT.0) THEN
71917 DO 250 I=1,N
71918 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
71919 250 CONTINUE
71920 ENDIF
71921 IF(NPRIM.NE.2) THEN
71922
71923C...Predetermined and default matrix element kinds.
71924 ELSEIF(MSTJ(38).NE.0) THEN
71925 M3JC=MSTJ(38)
71926 ALPHA=PARJ(80)
71927 MSTJ(38)=0
71928 ELSEIF(MSTJ(47).GE.6) THEN
71929 M3JC=MSTJ(47)
71930 ELSE
71931 ICLASS=1
71932 ICOMBI=4
71933
71934C...Vector/axial vector -> q + qbar; q -> q + V.
71935 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
71936 & ITYPES.EQ.3)) THEN
71937 ICLASS=2
71938 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
71939 ICOMBI=1
71940 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
71941 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
71942C...gamma*/Z0: assume e+e- initial state if unknown.
71943 EI=-1D0
71944 IF(KFSRCE.EQ.23) THEN
71945 IANNFL=IPART1
71946 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
71947 IF(IANNFL.GT.0) THEN
71948 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
71949 ENDIF
71950 IF(IANNFL.NE.0) THEN
71951 KANNFL=IABS(K(IANNFL,2))
71952 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
71953 ENDIF
71954 ENDIF
71955 AI=SIGN(1D0,EI+0.1D0)
71956 VI=AI-4D0*EI*PARU(102)
71957 EF=KCHG(KFLA1,1)/3D0
71958 AF=SIGN(1D0,EF+0.1D0)
71959 VF=AF-4D0*EF*PARU(102)
71960 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
71961 SH=PSUM(5)**2
71962 SQMZ=PMAS(23,1)**2
71963 SQWZ=PSUM(5)*PMAS(23,2)
71964 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
71965 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
71966 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
71967 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
71968 ICOMBI=3
71969 ALPHA=VECT/(VECT+AXIV)
71970 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
71971 ICOMBI=4
71972 ENDIF
71973C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
71974 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
71975 ICLASS=2
71976 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
71977 & ITYPES.EQ.1)) THEN
71978 ICLASS=3
71979
71980C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
71981 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
71982 ICLASS=4
71983 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
71984 ICOMBI=1
71985 ELSEIF(KFSRCE.EQ.36) THEN
71986 ICOMBI=2
71987 ENDIF
71988 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
71989 & ITYPES.EQ.1)) THEN
71990 ICLASS=5
71991
71992C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
71993 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
71994 & ITYPES.EQ.3)) THEN
71995 ICLASS=6
71996 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
71997 & ITYPES.EQ.2)) THEN
71998 ICLASS=7
71999 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
72000 ICLASS=8
72001 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
72002 & ITYPES.EQ.2)) THEN
72003 ICLASS=9
72004
72005C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
72006 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
72007 & ITYPES.EQ.5)) THEN
72008 ICLASS=10
72009 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
72010 & ITYPES.EQ.2)) THEN
72011 ICLASS=11
72012 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
72013 & ITYPES.EQ.1)) THEN
72014 ICLASS=12
72015
72016C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
72017 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
72018 ICLASS=13
72019 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
72020 & ITYPES.EQ.2)) THEN
72021 ICLASS=14
72022 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
72023 & ITYPES.EQ.1)) THEN
72024 ICLASS=15
72025
72026C...g -> ~g + ~g (eikonal approximation).
72027 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
72028 ICLASS=16
72029 ENDIF
72030 M3JC=5*ICLASS+ICOMBI
72031 ENDIF
72032
72033C...Store pair that together define matrix element treatment.
72034 IF(M3JC.NE.0) THEN
72035 NMESYS=1
72036 MESYS(NMESYS,0)=M3JC
72037 MESYS(NMESYS,1)=IPART(1)
72038 MESYS(NMESYS,2)=IPART(2)
72039 ENDIF
72040
72041C...Store qqbar or l+l- pairs for QED radiation.
72042 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
72043 NMESYS=NMESYS+1
72044 MESYS(NMESYS,0)=101
72045 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
72046 MESYS(NMESYS,1)=IPART(1)
72047 MESYS(NMESYS,2)=IPART(2)
72048 ENDIF
72049
72050C...Store other qqbar/l+l- pairs from g/gamma branchings.
72051 DO 290 I1=1,N
72052 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 290
72053 I1M=K(I1,3)
72054 260 IF(I1M.GT.0) THEN
72055 IF(K(I1M,2).EQ.K(I1,2)) THEN
72056 I1M=K(I1M,3)
72057 GOTO 260
72058 ENDIF
72059 ENDIF
72060C...Move up this check to avoid out-of-bounds.
72061 IF(I1M.EQ.0) GOTO 290
72062 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 290
72063 DO 280 I2=I1+1,N
72064 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 280
72065 I2M=K(I2,3)
72066 270 IF(I2M.GT.0) THEN
72067 IF(K(I2M,2).EQ.K(I2,2)) THEN
72068 I2M=K(I2M,3)
72069 GOTO 270
72070 ENDIF
72071 ENDIF
72072 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
72073 NMESYS=NMESYS+1
72074 MESYS(NMESYS,0)=66
72075 MESYS(NMESYS,1)=I1
72076 MESYS(NMESYS,2)=I2
72077 NMESYS=NMESYS+1
72078 MESYS(NMESYS,0)=102
72079 MESYS(NMESYS,1)=I1
72080 MESYS(NMESYS,2)=I2
72081 ENDIF
72082 280 CONTINUE
72083 290 CONTINUE
72084 ENDIF
72085
72086C..Loopback point for counting number of emissions.
72087 NGEN=0
72088 300 NGEN=NGEN+1
72089
72090C...Begin loop to evolve all existing partons, if required.
72091 310 IMX=0
72092 PT2MX=0D0
72093 DO 380 IEVOL=1,NEVOL
72094 IF(IFLG(IEVOL).EQ.0) THEN
72095
72096C...Basic info on radiator and recoil.
72097 I=IPOS(IEVOL)
72098 IR=IREC(IEVOL)
72099 SHT=SHAT(I,IR)
72100 PM2I=P(I,5)**2
72101 PM2R=P(IR,5)**2
72102
72103C...Skip any particles that are "turned off"
72104 IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) GOTO 380
72105
72106C...Invariant mass of "dipole".Starting value for pT evolution.
72107 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
72108 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
72109
72110C...Case of evolution by QCD branching.
72111 IF(ISCOL(IEVOL).NE.0) THEN
72112
72113C...Parton-by-parton maximum scale from initial conditions.
72114 IF(MSTP(72).EQ.0) THEN
72115 DO 320 IPRT=1,NPARTS
72116 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
72117 320 CONTINUE
72118 ENDIF
72119
72120C...If kinematically impossible then do not evolve.
72121 IF(PT2.LT.PT2CMN) THEN
72122 IFLG(IEVOL)=-1
72123 GOTO 380
72124 ENDIF
72125
72126C...Check if part of system for which ME corrections should be applied.
72127 IMESYS=0
72128 DO 330 IME=1,NMESYS
72129 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
72130 & MESYS(IME,0).LT.100) IMESYS=IME
72131 330 CONTINUE
72132
72133C...Special flag for colour octet states.
72134C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot.
72135 MOCT=0
72136 KC = PYCOMP(K(I,2))
72137 IF(K(I,2).EQ.21) THEN
72138 MOCT=1
72139 ELSEIF(KCHG(KC,2).EQ.2) THEN
72140 MOCT=2
72141 ENDIF
72142C...QUARKONIA++
72143 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).EQ.9900101.AND.
72144 & IABS(K(I,2)).LE.9910555) MOCT=2
72145C...QUARKONIA--
72146
72147
72148C...Upper estimate for matrix element weighting and colour factor.
72149C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
72150 WTPSGL=2D0
72151 COLFAC=4D0/3D0
72152 IF(MOCT.GE.1) COLFAC=3D0/2D0
72153 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
72154 WTPSQQ=0.5D0*0.5D0*NFLAV
72155
72156C...Determine overestimated z range: switch at c and b masses.
72157 340 IZRG=1
72158 PT2MNE=PT2CMN
72159 B0=27D0/6D0
72160 ALAMS=ALAM3S
72161 IF(PT2.GT.1.01D0*PMCS) THEN
72162 IZRG=2
72163 PT2MNE=PMCS
72164 B0=25D0/6D0
72165 ALAMS=ALAM4S
72166 ENDIF
72167 IF(PT2.GT.1.01D0*PMBS) THEN
72168 IZRG=3
72169 PT2MNE=PMBS
72170 B0=23D0/6D0
72171 ALAMS=ALAM5S
72172 ENDIF
72173 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
72174 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
72175
72176C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
72177 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
72178 EVCOEF=EVEMGL
72179 IF(MOCT.EQ.1) THEN
72180 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
72181 EVCOEF=EVCOEF+EVEMQQ
72182 ENDIF
72183
72184C...Pick pT2 (in overestimated z range).
72185 350 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
72186
72187C...Loopback if crossed c/b mass thresholds.
72188 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
72189 PT2=PMBS
72190 GOTO 340
72191 ENDIF
72192 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
72193 PT2=PMCS
72194 GOTO 340
72195 ENDIF
72196
72197C...Finish if below lower cutoff.
72198 IF(PT2.LT.PT2CMN) THEN
72199 IFLG(IEVOL)=-1
72200 GOTO 380
72201 ENDIF
72202
72203C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
72204C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting
72205 IFLAG=1
72206 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
72207
72208C...Pick z: dz/(1-z) or dz.
72209 IF(IFLAG.EQ.1) THEN
72210 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
72211 ELSE
72212 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
72213 ENDIF
72214
72215C...Loopback if outside allowed range for given pT2.
72216 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
72217 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
72218 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
72219 PM2=PM2I+PT2/(Z*(1D0-Z))
72220 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
72221
72222C...No weighting for primary partons; to be done later on.
72223 IF(IMESYS.GT.0) THEN
72224
72225C...Weighting of q->qg/X->Xg branching.
72226 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
72227 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 350
72228
72229C...Weighting of g->gg branching.
72230 ELSEIF(IFLAG.EQ.1) THEN
72231 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 350
72232
72233C...Flavour choice and weighting of g->qqbar branching.
72234 ELSE
72235 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
72236 PMQ=PMAS(KFQ,1)
72237 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
72238 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
72239 IF(WTME.LT.PYR(0)) GOTO 350
72240 IFLAG=10+KFQ
72241 ENDIF
72242
72243C...Case of evolution by QED branching.
72244 ELSEIF(ISCHG(IEVOL).NE.0) THEN
72245
72246C...If kinematically impossible then do not evolve.
72247 PT2EMN=PT0EQ**2
72248 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
72249 IF(PT2.LT.PT2EMN) THEN
72250 IFLG(IEVOL)=-1
72251 GOTO 380
72252 ENDIF
72253
72254C...Check if part of system for which ME corrections should be applied.
72255 IMESYS=0
72256 DO 360 IME=1,NMESYS
72257 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
72258 & MESYS(IME,0).GT.100) IMESYS=IME
72259 360 CONTINUE
72260
72261C...Charge. Matrix element weighting factor.
72262 CHG=ISCHG(IEVOL)/3D0
72263 WTPSGA=2D0
72264
72265C...Determine overestimated z range. Find evolution coefficient.
72266 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
72267 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
72268 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
72269
72270C...Pick pT2 (in overestimated z range).
72271 370 PT2=PT2*PYR(0)**(1D0/EVCOEF)
72272
72273C...Finish if below lower cutoff.
72274 IF(PT2.LT.PT2EMN) THEN
72275 IFLG(IEVOL)=-1
72276 GOTO 380
72277 ENDIF
72278
72279C...Pick z: dz/(1-z).
72280 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
72281
72282C...Loopback if outside allowed range for given pT2.
72283 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
72284 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
72285 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 370
72286 PM2=PM2I+PT2/(Z*(1D0-Z))
72287 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 370
72288
72289C...Weighting by branching kernel, except if ME weighting later.
72290 IF(IMESYS.EQ.0) THEN
72291 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 370
72292 ENDIF
72293 IFLAG=3
72294 ENDIF
72295
72296C...Save acceptable branching.
72297 IFLG(IEVOL)=IFLAG
72298 IMESAV(IEVOL)=IMESYS
72299 PT2SAV(IEVOL)=PT2
72300 ZSAV(IEVOL)=Z
72301 SHTSAV(IEVOL)=SHT
72302 ENDIF
72303
72304C...Check if branching has highest pT.
72305 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
72306 IMX=IEVOL
72307 PT2MX=PT2SAV(IEVOL)
72308 ENDIF
72309 380 CONTINUE
72310
72311C...Finished if no more branchings to be done.
72312 IF(IMX.EQ.0) GOTO 520
72313
72314C...Restore info on hardest branching to be processed.
72315 I=IPOS(IMX)
72316 IR=IREC(IMX)
72317 KCOL=ISCOL(IMX)
72318 KCHA=ISCHG(IMX)
72319 IMESYS=IMESAV(IMX)
72320 PT2=PT2SAV(IMX)
72321 Z=ZSAV(IMX)
72322 SHT=SHTSAV(IMX)
72323 PM2I=P(I,5)**2
72324 PM2R=P(IR,5)**2
72325 PM2=PM2I+PT2/(Z*(1D0-Z))
72326
72327C...Special flag for colour octet states.
72328 MOCT=0
72329 KC = PYCOMP(K(I,2))
72330 IF(K(I,2).EQ.21) THEN
72331 MOCT=1
72332 ELSEIF(KCHG(KC,2).EQ.2) THEN
72333 MOCT=2
72334 ENDIF
72335C...QUARKONIA++
72336 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).GE.9900101.AND.
72337 & IABS(K(I,2)).LE.9910555) MOCT=2
72338C...QUARKONIA--
72339
72340C...Restore further info for g->qqbar branching.
72341 KFQ=0
72342 IF(IFLG(IMX).GT.10) THEN
72343 KFQ=IFLG(IMX)-10
72344 PMQ=PMAS(KFQ,1)
72345 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
72346 ENDIF
72347
72348C...For branching g include azimuthal asymmetries from polarization.
72349 ASYPOL=0D0
72350 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
72351C...Trace grandmother via intermediate recoil copies.
72352 KFGM=0
72353 IM=I
72354 390 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
72355 & K(IM,3).GT.0) THEN
72356 IM=K(IM,3)
72357 IF(IM.GT.MINT(84)) GOTO 390
72358 ENDIF
72359 IGM=K(IM,3)
72360 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
72361 & KFGM=IABS(K(IGM,2))
72362C...Define approximate energy sharing by identifying aunt.
72363 IAU=IM+1
72364 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
72365 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
72366 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
72367C...Coefficient from gluon production.
72368 IF(KFGM.LE.6) THEN
72369 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
72370 ELSE
72371 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
72372 ENDIF
72373C...Coefficient from gluon decay.
72374 IF(KFQ.EQ.0) THEN
72375 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
72376 ELSE
72377 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
72378 ENDIF
72379 ENDIF
72380 ENDIF
72381
72382C...Create new slots for branching products and recoil.
72383 INEW=N+1
72384 IGNEW=N+2
72385 IRNEW=N+3
72386 N=N+3
72387
72388C...Set status, flavour and mother of new ones.
72389 K(INEW,1)=K(I,1)
72390 K(IGNEW,1)=3
72391 IF(KCHA.NE.0) K(IGNEW,1)=1
72392 K(IRNEW,1)=K(IR,1)
72393 IF(KFQ.EQ.0) THEN
72394 K(INEW,2)=K(I,2)
72395 K(IGNEW,2)=21
72396 IF(KCHA.NE.0) K(IGNEW,2)=22
72397 ELSE
72398 K(INEW,2)=-ISIGN(KFQ,KCOL)
72399 K(IGNEW,2)=-K(INEW,2)
72400 ENDIF
72401 K(IRNEW,2)=K(IR,2)
72402 K(INEW,3)=I
72403 K(IGNEW,3)=I
72404 K(IRNEW,3)=IR
72405
72406C...Find rest frame and angles of branching+recoil.
72407 DO 400 J=1,5
72408 P(INEW,J)=P(I,J)
72409 P(IGNEW,J)=0D0
72410 P(IRNEW,J)=P(IR,J)
72411 400 CONTINUE
72412 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
72413 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
72414 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
72415 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
72416 PHI=PYANGL(P(INEW,1),P(INEW,2))
72417 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
72418
72419C...Derive kinematics of branching: generics (like g->gg).
72420 DO 410 J=1,4
72421 P(INEW,J)=0D0
72422 P(IRNEW,J)=0D0
72423 410 CONTINUE
72424 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
72425 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
72426 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
72427 PTCOR=SQRT(MAX(0D0,PT2COR))
72428 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
72429 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
72430C...Specific kinematics reduction for q->qg with m_q > 0.
72431 IF(MOCT.NE.1) THEN
72432 PTCOR=(1D0-PM2I/PM2)*PTCOR
72433 PZN=PZN+PM2I*PZG/PM2
72434 PZG=(1D0-PM2I/PM2)*PZG
72435C...Specific kinematics reduction for g->qqbar with m_q > 0.
72436 ELSEIF(KFQ.NE.0) THEN
72437 P(INEW,5)=PMQ
72438 P(IGNEW,5)=PMQ
72439 PTCOR=ROOTQQ*PTCOR
72440 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
72441 PZG=PZM-PZN
72442 ENDIF
72443
72444C...Pick phi and construct kinematics of branching.
72445 420 PHIROT=PARU(2)*PYR(0)
72446 P(INEW,1)=PTCOR*COS(PHIROT)
72447 P(INEW,2)=PTCOR*SIN(PHIROT)
72448 P(INEW,3)=PZN
72449 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
72450 P(IGNEW,1)=-P(INEW,1)
72451 P(IGNEW,2)=-P(INEW,2)
72452 P(IGNEW,3)=PZG
72453 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
72454 P(IRNEW,1)=0D0
72455 P(IRNEW,2)=0D0
72456 P(IRNEW,3)=-PZM
72457 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
72458
72459C...Boost branching system to lab frame.
72460 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
72461
72462C...Renew choice of phi angle according to polarization asymmetry.
72463 IF(ABS(ASYPOL).GT.1D-3) THEN
72464 DO 430 J=1,3
72465 DPT(1,J)=P(I,J)
72466 DPT(2,J)=P(IAU,J)
72467 DPT(3,J)=P(INEW,J)
72468 430 CONTINUE
72469 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
72470 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
72471 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
72472 DO 440 J=1,3
72473 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
72474 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
72475 440 CONTINUE
72476 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
72477 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
72478 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
72479 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
72480 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
72481 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
72482 & GOTO 420
72483 ENDIF
72484 ENDIF
72485
72486C...Matrix element corrections for primary partons when requested.
72487 IF(IMESYS.GT.0) THEN
72488 M3JC=MESYS(IMESYS,0)
72489
72490C...Identify recoiling partner and set up three-body kinematics.
72491 IRP=MESYS(IMESYS,1)
72492 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
72493 IF(IRP.EQ.IR) IRP=IRNEW
72494 DO 450 J=1,4
72495 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
72496 450 CONTINUE
72497 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
72498 & PSUM(3)**2))
72499 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
72500 & PSUM(3)*P(INEW,3))/PSUM(5)**2
72501 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
72502 & PSUM(3)*P(IRP,3))/PSUM(5)**2
72503 X3=2D0-X1-X2
72504 R1ME=P(INEW,5)/PSUM(5)
72505 R2ME=P(IRP,5)/PSUM(5)
72506
72507C...Matrix elements for gluon emission.
72508 IF(M3JC.LT.100) THEN
72509
72510C...Call ME, with right order important for two inequivalent showerers.
72511 IF(MESYS(IMESYS,IORD).EQ.I) THEN
72512 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
72513 ELSE
72514 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
72515 ENDIF
72516
72517C...Split up total ME when two radiating partons.
72518 ISPRAD=1
72519 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
72520 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
72521 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
72522 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
72523 & MAX(1D-10,2D0-X1-X2)
72524
72525C...Evaluate shower rate.
72526 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
72527 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
72528 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
72529
72530C...Matrix elements for photon emission: still rather primitive.
72531 ELSE
72532
72533C...For generic charge combination currently only massless expression.
72534 IF(M3JC.EQ.101) THEN
72535 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
72536 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
72537 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
72538 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
72539
72540C...For flavour neutral system assume vector source and include masses.
72541 ELSE
72542 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
72543 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
72544 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
72545 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
72546 ENDIF
72547 ENDIF
72548
72549C...Perform weighting with W_ME/W_PS.
72550 IF(WME.LT.PYR(0)*WPS) THEN
72551 N=N-3
72552 IFLG(IMX)=0
72553 PT2CMX=PT2
72554 GOTO 310
72555 ENDIF
72556 ENDIF
72557
72558C...Now for sure accepted branching. Save highest pT.
72559 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
72560
72561C...Update status for obsolete ones. Bookkkep the moved original parton
72562C...and new daughter (arbitrary choice for g->gg or g->qqbar).
72563C...Do not bookkeep radiated photon, since it cannot radiate further.
72564 K(I,1)=K(I,1)+10
72565 K(IR,1)=K(IR,1)+10
72566 DO 460 IP=1,NPART
72567 IF(IPART(IP).EQ.I) IPART(IP)=INEW
72568 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
72569 460 CONTINUE
72570 IF(KCHA.EQ.0) THEN
72571 NPART=NPART+1
72572 IPART(NPART)=IGNEW
72573 ENDIF
72574
72575C...Initialize colour flow of branching.
72576C...Use both old and new style colour tags for flexibility.
72577 K(INEW,4)=0
72578 K(IGNEW,4)=0
72579 K(INEW,5)=0
72580 K(IGNEW,5)=0
72581 JCOLP=4+(1-KCOL)/2
72582 JCOLN=9-JCOLP
72583 MCT(INEW,1)=0
72584 MCT(INEW,2)=0
72585 MCT(IGNEW,1)=0
72586 MCT(IGNEW,2)=0
72587 MCT(IRNEW,1)=0
72588 MCT(IRNEW,2)=0
72589
72590C...Trivial colour flow for l->lgamma and q->qgamma.
72591 IF(IABS(KCHA).EQ.3) THEN
72592 K(I,4)=INEW
72593 K(I,5)=IGNEW
72594 ELSEIF(KCHA.NE.0) THEN
72595 IF(K(I,4).NE.0) THEN
72596 K(I,4)=K(I,4)+INEW
72597 K(INEW,4)=MSTU(5)*I
72598 MCT(INEW,1)=MCT(I,1)
72599 ENDIF
72600 IF(K(I,5).NE.0) THEN
72601 K(I,5)=K(I,5)+INEW
72602 K(INEW,5)=MSTU(5)*I
72603 MCT(INEW,2)=MCT(I,2)
72604 ENDIF
72605
72606C...Set colour flow for q->qg and g->gg.
72607 ELSEIF(KFQ.EQ.0) THEN
72608 K(I,JCOLP)=K(I,JCOLP)+IGNEW
72609 K(IGNEW,JCOLP)=MSTU(5)*I
72610 K(INEW,JCOLP)=MSTU(5)*IGNEW
72611 K(IGNEW,JCOLN)=MSTU(5)*INEW
72612 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
72613 NCT=NCT+1
72614 MCT(INEW,JCOLP-3)=NCT
72615 MCT(IGNEW,JCOLN-3)=NCT
72616 IF(MOCT.GE.1) THEN
72617 K(I,JCOLN)=K(I,JCOLN)+INEW
72618 K(INEW,JCOLN)=MSTU(5)*I
72619 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
72620 ENDIF
72621
72622C...Set colour flow for g->qqbar.
72623 ELSE
72624 K(I,JCOLN)=K(I,JCOLN)+INEW
72625 K(INEW,JCOLN)=MSTU(5)*I
72626 K(I,JCOLP)=K(I,JCOLP)+IGNEW
72627 K(IGNEW,JCOLP)=MSTU(5)*I
72628 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
72629 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
72630 ENDIF
72631
72632C...Daughter info for colourless recoiling parton.
72633 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
72634 K(IR,4)=IRNEW
72635 K(IR,5)=IRNEW
72636 K(IRNEW,4)=0
72637 K(IRNEW,5)=0
72638
72639C...Colour of recoiling parton sails through unchanged.
72640 ELSE
72641 IF(K(IR,4).NE.0) THEN
72642 K(IR,4)=K(IR,4)+IRNEW
72643 K(IRNEW,4)=MSTU(5)*IR
72644 MCT(IRNEW,1)=MCT(IR,1)
72645 ENDIF
72646 IF(K(IR,5).NE.0) THEN
72647 K(IR,5)=K(IR,5)+IRNEW
72648 K(IRNEW,5)=MSTU(5)*IR
72649 MCT(IRNEW,2)=MCT(IR,2)
72650 ENDIF
72651 ENDIF
72652
72653C...Vertex information trivial.
72654 DO 470 J=1,5
72655 V(INEW,J)=V(I,J)
72656 V(IGNEW,J)=V(I,J)
72657 V(IRNEW,J)=V(IR,J)
72658 470 CONTINUE
72659
72660C...Update list of old radiators.
72661 DO 480 IEVOL=1,NEVOL
72662C... A) radiator-recoiler mother pair for this branching
72663 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
72664 IPOS(IEVOL)=INEW
72665C... A2) QCD branching and color side matches, radiated parton follows recoiler
72666 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
72667 IREC(IEVOL)=IRNEW
72668 IFLG(IEVOL)=0
72669 ELSEIF(IPOS(IEVOL).EQ.I) THEN
72670C... B) other dipoles with I as radiator simply get INEW as new radiator
72671 IPOS(IEVOL)=INEW
72672 IFLG(IEVOL)=0
72673 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
72674C... C) the "mirror image" of the parent dipole
72675 IPOS(IEVOL)=IRNEW
72676 IREC(IEVOL)=INEW
72677C... C2) QCD branching and color side matches, radiated parton follows recoiler
72678 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL.AND.ISCOL(IEVOL).NE.0)
72679 & IREC(IEVOL)=IGNEW
72680 IFLG(IEVOL)=0
72681 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
72682C... D) other dipoles with IR as radiator simply get IRNEW as new radiator
72683 IPOS(IEVOL)=IRNEW
72684 IFLG(IEVOL)=0
72685 ENDIF
72686C... Update links of old connected partons.
72687 IF(IREC(IEVOL).EQ.I) THEN
72688 IREC(IEVOL)=INEW
72689 IFLG(IEVOL)=0
72690 ELSEIF(IREC(IEVOL).EQ.IR) THEN
72691 IREC(IEVOL)=IRNEW
72692 IFLG(IEVOL)=0
72693 ENDIF
72694 480 CONTINUE
72695
72696C...q->qg or g->gg: create new gluon radiators.
72697 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
72698 NEVOL=NEVOL+1
72699 IPOS(NEVOL)=INEW
72700 IREC(NEVOL)=IGNEW
72701 IFLG(NEVOL)=0
72702 ISCOL(NEVOL)=KCOL
72703 ISCHG(NEVOL)=0
72704 PTSCA(NEVOL)=SQRT(PT2)
72705 NEVOL=NEVOL+1
72706 IPOS(NEVOL)=IGNEW
72707 IREC(NEVOL)=INEW
72708 IFLG(NEVOL)=0
72709 ISCOL(NEVOL)=-KCOL
72710 ISCHG(NEVOL)=0
72711 PTSCA(NEVOL)=PTSCA(NEVOL-1)
72712C...g->qqbar: create new photon radiators.
72713 ELSEIF(KCOL.EQ.2.AND.KFQ.NE.0) THEN
72714 NEVOL=NEVOL+1
72715 IPOS(NEVOL)=INEW
72716 IREC(NEVOL)=IGNEW
72717 IFLG(NEVOL)=0
72718 ISCOL(NEVOL)=0
72719 ISCHG(NEVOL)=PYK(INEW,6)
72720 PTSCA(NEVOL)=SQRT(PT2)
72721 NEVOL=NEVOL+1
72722 IPOS(NEVOL)=IGNEW
72723 IREC(NEVOL)=INEW
72724 IFLG(NEVOL)=0
72725 ISCOL(NEVOL)=0
72726 ISCHG(NEVOL)=PYK(IGNEW,6)
72727 PTSCA(NEVOL)=SQRT(PT2)
72728 CALL PYLIST(4)
72729 print*, 'created new QED dipole ',INEW,'<->',IGNEW
72730 ENDIF
72731
72732C...Check color and charge connections,
72733C...Rewire if better partners can be found (screening, etc)
72734 DO 500 IEVOL=1,NEVOL
72735 KCOL = ISCOL(IEVOL)
72736 KCHA = ISCHG(IEVOL)
72737 IRTMP = IREC(IEVOL)
72738 ITMP = IPOS(IEVOL)
72739C...Do not modify QED dipoles
72740 IF (KCHA.NE.0) THEN
72741 GOTO 500
72742C...Also skip dipole ends that are switched off
72743 ELSEIF (IFLG(IEVOL).LE.-1) THEN
72744 GOTO 500
72745 ELSEIF (KCOL.NE.0) THEN
72746C...QCD dipoles. Check if current recoiler has appropriate color charge
72747 KCOLR = PYK(IRTMP,12)
72748 IF (KCOLR.EQ.2.OR.KCOLR.EQ.-KCOL) GOTO 500
72749C...If not, look for closest recoiler with appropriate color charge
72750 RM2MIN = PSUM(5)**2
72751 JMX = 0
72752 ISGOOD = 0
72753 DO 490 JEVOL=1,NEVOL
72754C...Skip self
72755 IF (JEVOL.EQ.IEVOL) GOTO 490
72756 JTMP = IPOS(JEVOL)
72757 IF (JTMP.EQ.ITMP) GOTO 490
72758 JCOL = ISCOL(JEVOL)
72759C...Skip dipole ends that are switched off
72760 IF (IFLG(JEVOL).LE.-1) GOTO 490
72761C...Skip QED dipole ends
72762 IF (ISCHG(JEVOL).NE.0) GOTO 490
72763C... Skip wrong-color if at least one correct-color partner already found
72764 IF (ISGOOD.NE.0.AND.JCOL.NE.-KCOL.AND.JCOL.NE.2) GOTO 490
72765C...Accept if smallest m2 so far, or if first with correct color
72766 RM2 = DOTP(ITMP,JTMP)
72767 ISGNOW = 0
72768 IF (JCOL.EQ.-KCOL.OR.JCOL.EQ.2) ISGNOW=1
72769 IF (RM2.LT.RM2MIN.OR.ISGNOW.GT.ISGOOD) THEN
72770 ISGOOD = ISGNOW
72771 RM2MIN = RM2
72772 JMX = JEVOL
72773 ENDIF
72774 490 CONTINUE
72775C...Update recoiler and reset dipole if new best partner found
72776 IF (JMX.NE.0) THEN
72777 IREC(IEVOL) = IPOS(JMX)
72778 IFLG(IEVOL) = 0
72779 ENDIF
72780 ENDIF
72781 500 CONTINUE
72782
72783C...TMP! print out list of dipoles
72784C DO 580 IEVOL=1,NEVOL
72785C KCHA = ISCHG(IEVOL)
72786C IF (KCHA.NE.0) THEN
72787C print*, 'qed dip',IPOS(IEVOL),IREC(IEVOL)
72788C ELSE
72789C print*, 'qcd dip',IPOS(IEVOL),IREC(IEVOL)
72790C ENDIF
72791C 580 CONTINUE
72792
72793C...Update matrix elements parton list and add new for g/gamma->qqbar.
72794 DO 510 IME=1,NMESYS
72795 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
72796 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
72797 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
72798 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
72799 510 CONTINUE
72800 IF(KFQ.NE.0) THEN
72801 NMESYS=NMESYS+1
72802 MESYS(NMESYS,0)=66
72803 MESYS(NMESYS,1)=INEW
72804 MESYS(NMESYS,2)=IGNEW
72805 NMESYS=NMESYS+1
72806 MESYS(NMESYS,0)=102
72807 MESYS(NMESYS,1)=INEW
72808 MESYS(NMESYS,2)=IGNEW
72809 ENDIF
72810
72811C...Global statistics.
72812 MINT(353)=MINT(353)+1
72813 VINT(353)=VINT(353)+PTCOR
72814 IF (MINT(353).EQ.1) VINT(358)=PTCOR
72815
72816C...Loopback for more emissions if enough space.
72817 PT2CMX=PT2
72818 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
72819 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
72820 GOTO 300
72821 ELSE
72822 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
72823 ENDIF
72824
72825C...Done.
72826 520 CONTINUE
72827
72828 RETURN
72829 END
72830
72831C*********************************************************************
72832
72833C...PYMAEL
72834C...Auxiliary to PYSHOW and PYPTFS.
72835C...Matrix elements for gluon (or photon) emission from
72836C...a two-body state; to be used by the parton shower routine.
72837C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
72838C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
72839C... = (alpha-strong/2 pi) * CF * PYMAEL,
72840C...i.e. normalization is such that one recovers the familiar
72841C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
72842C...Coupling structure:
72843C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
72844C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
72845C... = 16-19 : q -> q V
72846C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
72847C... = 26-29 : q -> q S
72848C... = 31-34 : V -> ~q ~qbar (~q = squark)
72849C... = 36-39 : ~q -> ~q V
72850C... = 41-44 : S -> ~q ~qbar
72851C... = 46-49 : ~q -> ~q S
72852C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
72853C... = 56-59 : ~q -> q chi
72854C... = 61-64 : q -> ~q chi
72855C... = 66-69 : ~g -> q ~qbar
72856C... = 71-74 : ~q -> q ~g
72857C... = 76-79 : q -> ~q ~g
72858C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
72859C...Note that the order of the decay products is important.
72860C...In each set of four, the variants are ordered as:
72861C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
72862C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
72863C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
72864C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
72865
72866 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
72867
72868C...Double precision and integer declarations.
72869 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72870 IMPLICIT INTEGER(I-N)
72871
72872C...Check input values. Return zero outside allowed phase space.
72873 PYMAEL=0D0
72874 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
72875 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
72876 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
72877 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
72878 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
72879 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
72880
72881C...Initial values and flags.
72882 ICLASS=NI/5
72883 ICOMBI=NI-5*ICLASS
72884 ISSET1=0
72885 ISSET2=0
72886 ISSET4=0
72887
72888C... Phase space.
72889 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
72890
72891C...Eikonal expression; also acts as default.
72892 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
72893 RLO=PS
72894 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
72895 ANUM=0D0
72896 ELSEIF(ICOMBI.EQ.2) THEN
72897 ANUM=(2D0-X1-X2)**2
72898 ELSEIF(ICOMBI.EQ.3) THEN
72899 ANUM=ALPCOR*(2D0-X1-X2)**2
72900 ELSE
72901 ANUM=0.5D0*(2D0-X1-X2)**2
72902 ENDIF
72903 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
72904 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
72905 & R1**2/(1D0+R2**2-R1**2-X2)**2-
72906 & R2**2/(1D0+R1**2-R2**2-X1)**2)
72907 ICOMBI=0
72908
72909C...V -> q qbar (V = gamma*/Z0/W+-/...).
72910 ELSEIF(ICLASS.EQ.2) THEN
72911 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
72912 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
72913 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
72914 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
72915 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
72916 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
72917 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
72918 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
72919 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
72920 & (-1+R1**2-R2**2+X2)**2
72921 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
72922 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
72923 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
72924 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
72925 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
72926 & -X1-X2)**2+X1*(2-X1-X2)**2)/
72927 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
72928 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
72929 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
72930 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
72931 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
72932 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
72933 RFO1=RFO1/2.D0
72934 ISSET1=1
72935 ENDIF
72936 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
72937 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
72938 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
72939 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
72940 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
72941 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
72942 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
72943 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
72944 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
72945 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
72946 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
72947 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
72948 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
72949 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
72950 & -X1-X2)**2+X1*(2-X1-X2)**2)/
72951 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
72952 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
72953 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
72954 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
72955 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
72956 & +X2)/(-1-R1**2+R2**2+X1)**2
72957 RFO2=RFO2/2.D0
72958 ISSET2=1
72959 ENDIF
72960 IF(ICOMBI.EQ.4) THEN
72961 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
72962 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
72963 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
72964 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
72965 & (-1-R1**2+R2**2+X1)**2
72966 RFO4=RFO4
72967 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
72968 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
72969 & -R1**2*X2**2+X1*X2**2)/
72970 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
72971 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
72972 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
72973 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
72974 & (-1+R1**2-R2**2+X2)**2
72975 RFO4=RFO4/2.D0
72976 ISSET4=1
72977 ENDIF
72978
72979C...q -> q V.
72980 ELSEIF(ICLASS.EQ.3) THEN
72981 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
72982 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
72983 & +R1**2*R2**2-2D0*R2**4)
72984 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
72985 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
72986 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
72987 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
72988 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
72989 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
72990 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
72991 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
72992 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
72993 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
72994 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
72995 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
72996 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
72997 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
72998 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
72999 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
73000 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
73001 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
73002 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
73003 ISSET1=1
73004 ENDIF
73005 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73006 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
73007 & +R1**2*R2**2-2D0*R2**4)
73008 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
73009 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
73010 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
73011 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
73012 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
73013 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
73014 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
73015 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
73016 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
73017 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
73018 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
73019 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
73020 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
73021 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
73022 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
73023 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
73024 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
73025 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
73026 & +X1*X2**2)/(-2+X1+X2)**2
73027 ISSET2=1
73028 ENDIF
73029 IF(ICOMBI.EQ.4) THEN
73030 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
73031 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
73032 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
73033 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
73034 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
73035 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
73036 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
73037 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
73038 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
73039 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
73040 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
73041 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
73042 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
73043 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
73044 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
73045 & +X1*X2**2)/(2-X1-X2)**2
73046 ISSET4=1
73047 ENDIF
73048
73049C...S -> q qbar (S = h0/H0/A0/H+-/...).
73050 ELSEIF(ICLASS.EQ.4) THEN
73051 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73052 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
73053 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73054 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
73055 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
73056 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
73057 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
73058 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73059 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73060 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
73061 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73062 ISSET1=1
73063 ENDIF
73064 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73065 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
73066 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
73067 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
73068 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
73069 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
73070 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
73071 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73072 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
73073 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
73074 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
73075 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73076 ISSET2=1
73077 ENDIF
73078 IF(ICOMBI.EQ.4) THEN
73079 RLO4=PS*(1D0-R1**2-R2**2)
73080 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
73081 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
73082 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
73083 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
73084 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73085 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
73086 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73087 ISSET4=1
73088 ENDIF
73089
73090C...q -> q S.
73091 ELSEIF(ICLASS.EQ.5) THEN
73092 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73093 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
73094 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
73095 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
73096 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
73097 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73098 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
73099 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
73100 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73101 & (-1+R1**2-R2**2+X2)**2
73102 ISSET1=1
73103 ENDIF
73104 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73105 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
73106 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
73107 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
73108 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
73109 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73110 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
73111 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
73112 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73113 & (-1+R1**2-R2**2+X2)**2
73114 ISSET2=1
73115 ENDIF
73116 IF(ICOMBI.EQ.4) THEN
73117 RLO4=PS*(1D0+R1**2-R2**2)
73118 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
73119 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
73120 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
73121 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
73122 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
73123 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
73124 ISSET4=1
73125 ENDIF
73126
73127C...V -> ~q ~qbar (~q = squark).
73128 ELSEIF(ICLASS.EQ.6) THEN
73129 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
73130 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
73131 & (-1-R1**2+R2**2+X1)**2
73132 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
73133 & (-1-R1**2+R2**2+X1)
73134 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
73135 & /(-1+R1**2-R2**2+X2)**2
73136 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
73137 & (-1+R1**2-R2**2+X2)
73138 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
73139 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
73140 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
73141 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73142 ISSET1=1
73143
73144C...~q -> ~q V.
73145 ELSEIF(ICLASS.EQ.7) THEN
73146 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
73147 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
73148 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
73149 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
73150 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
73151 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
73152 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
73153 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
73154 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
73155 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
73156 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
73157 & (3*(-2+X1+X2))
73158 RFO1=3D0*RFO1/8D0
73159 ISSET1=1
73160
73161C...S -> ~q ~qbar.
73162 ELSEIF(ICLASS.EQ.8) THEN
73163 RLO1=PS
73164 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
73165 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
73166 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
73167 & -R1**2*X2**2+X1*X2**2)/
73168 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
73169 RFO1=2D0*RFO1
73170 ISSET1=1
73171
73172C...~q -> ~q S.
73173 ELSEIF(ICLASS.EQ.9) THEN
73174 RLO1=PS
73175 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
73176 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
73177 & -(X1+X2)/(-2+X1+X2)**2
73178 ISSET1=1
73179
73180C...chi -> q ~qbar (chi = neutralino/chargino).
73181 ELSEIF(ICLASS.EQ.10) THEN
73182 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73183 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
73184 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
73185 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
73186 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
73187 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73188 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
73189 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73190 & (-1+R1**2-R2**2+X2)**2
73191 ISSET1=1
73192 ENDIF
73193 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73194 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
73195 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
73196 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
73197 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
73198 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73199 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
73200 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73201 & (-1+R1**2-R2**2+X2)**2
73202 ISSET2=1
73203 ENDIF
73204 IF(ICOMBI.EQ.4) THEN
73205 RLO4=PS*(1+R1**2-R2**2)
73206 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
73207 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
73208 & +X2+R1**2*X2-X1*X2/2)/
73209 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73210 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
73211 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
73212 ISSET4=1
73213 ENDIF
73214
73215C...~q -> q chi.
73216 ELSEIF(ICLASS.EQ.11) THEN
73217 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73218 RLO1=PS*(1D0-(R1+R2)**2)
73219 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
73220 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73221 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
73222 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73223 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
73224 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
73225 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
73226 ISSET1=1
73227 ENDIF
73228 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73229 RLO2=PS*(1D0-(R1-R2)**2)
73230 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
73231 & (-2+X1+X2)**2
73232 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
73233 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
73234 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73235 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
73236 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
73237 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
73238 ISSET2=1
73239 ENDIF
73240 IF(ICOMBI.EQ.4) THEN
73241 RLO4=PS*(1D0-R1**2-R2**2)
73242 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
73243 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
73244 & +3*R1**2*X2-R2**2*X2-X1*X2)/
73245 & (-1+R1**2-R2**2+X2)**2
73246 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
73247 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
73248 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
73249 ISSET4=1
73250 ENDIF
73251
73252C...q -> ~q chi.
73253 ELSEIF(ICLASS.EQ.12) THEN
73254 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73255 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
73256 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
73257 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
73258 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
73259 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
73260 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
73261 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
73262 ISSET1=1
73263 END IF
73264 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73265 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
73266 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
73267 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
73268 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
73269 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
73270 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
73271 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
73272 ISSET2=1
73273 END IF
73274 IF(ICOMBI.EQ.4) THEN
73275 RLO4=PS*(1D0-R1**2+R2**2)
73276 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
73277 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
73278 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
73279 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
73280 & +R1**2*X2-X1*X2/2-X2**2/2)/
73281 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
73282 ISSET4=1
73283 END IF
73284
73285C...~g -> q ~qbar.
73286 ELSEIF(ICLASS.EQ.13) THEN
73287 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73288 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
73289 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
73290 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
73291 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
73292 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
73293 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
73294 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
73295 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
73296 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
73297 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
73298 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
73299 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
73300 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73301 & (3*(-1+R1**2-R2**2+X2)**2)
73302 RFO1=3D0*RFO1/4D0
73303 ISSET1=1
73304 ENDIF
73305 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73306 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
73307 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
73308 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
73309 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
73310 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
73311 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
73312 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
73313 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
73314 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
73315 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
73316 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73317 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
73318 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
73319 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73320 & (3*(-1+R1**2-R2**2+X2)**2)
73321 RFO2=3D0*RFO2/4D0
73322 ISSET2=1
73323 ENDIF
73324 IF(ICOMBI.EQ.4) THEN
73325 RLO4=PS*(1D0+R1**2-R2**2)
73326 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
73327 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
73328 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
73329 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
73330 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
73331 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73332 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
73333 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73334 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
73335 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73336 & (3*(-1+R1**2-R2**2+X2)**2)
73337 RFO4=3D0*RFO4/8D0
73338 ISSET4=1
73339 ENDIF
73340
73341C...~q -> q ~g.
73342 ELSEIF(ICLASS.EQ.14) THEN
73343 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73344 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
73345 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
73346 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73347 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
73348 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
73349 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
73350 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
73351 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
73352 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73353 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
73354 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
73355 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
73356 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
73357 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
73358 RFO1=RFO1
73359 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
73360 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
73361 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
73362 RFO1=9D0*RFO1/64D0
73363 ISSET1=1
73364 ENDIF
73365 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73366 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
73367 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
73368 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
73369 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
73370 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
73371 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
73372 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
73373 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
73374 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
73375 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
73376 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
73377 RFO2=RFO2
73378 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
73379 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
73380 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
73381 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
73382 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
73383 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
73384 RFO2=9D0*RFO2/64D0
73385 ISSET2=1
73386 ENDIF
73387 IF(ICOMBI.EQ.4) THEN
73388 RLO4=PS*(1-R1**2-R2**2)
73389 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
73390 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
73391 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
73392 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
73393 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
73394 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
73395 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
73396 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
73397 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
73398 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
73399 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
73400 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
73401 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
73402 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
73403 RFO4=9D0*RFO4/128D0
73404 ISSET4=1
73405 ENDIF
73406
73407C...q -> ~q ~g.
73408 ELSEIF(ICLASS.EQ.15) THEN
73409 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73410 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
73411 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
73412 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
73413 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
73414 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
73415 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
73416 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
73417 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
73418 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
73419 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
73420 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
73421 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
73422 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
73423 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
73424 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
73425 RFO1=9D0*RFO1/32D0
73426 ISSET1=1
73427 END IF
73428 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73429 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
73430 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
73431 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
73432 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
73433 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
73434 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
73435 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
73436 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
73437 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
73438 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
73439 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
73440 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
73441 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
73442 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
73443 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
73444 RFO2=9D0*RFO2/32D0
73445 ISSET2=1
73446 END IF
73447 IF(ICOMBI.EQ.4) THEN
73448 RLO4=PS*(1D0-R1**2+R2**2)
73449 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
73450 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
73451 & -R2**2*X2/2-X1*X2/2)/
73452 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
73453 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
73454 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
73455 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
73456 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
73457 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
73458 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
73459 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
73460 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
73461 RFO4=9D0*RFO4/64D0
73462 ISSET4=1
73463 END IF
73464
73465C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
73466 ELSEIF(ICLASS.EQ.16) THEN
73467 RLO=PS
73468 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
73469 ANUM=0D0
73470 ELSEIF(ICOMBI.EQ.2) THEN
73471 ANUM=(2D0-X1-X2)**2
73472 ELSEIF(ICOMBI.EQ.3) THEN
73473 ANUM=ALPCOR*(2D0-X1-X2)**2
73474 ELSE
73475 ANUM=0.5D0*(2D0-X1-X2)**2
73476 ENDIF
73477 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
73478 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
73479 & R1**2/(1D0+R2**2-R1**2-X2)**2-
73480 & R2**2/(1D0+R1**2-R2**2-X1)**2)
73481 RFO=9D0*RFO/4D0
73482 ICOMBI=0
73483 ENDIF
73484
73485C...Find relevant LO and FO expression.
73486 IF(ICOMBI.EQ.0) THEN
73487 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
73488 RLO=RLO1
73489 RFO=RFO1
73490 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
73491 RLO=RLO2
73492 RFO=RFO2
73493 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
73494 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
73495 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
73496 ELSEIF(ISSET4.EQ.1) THEN
73497 RLO=RLO4
73498 RFO=RFO4
73499 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
73500 RLO=0.5D0*(RLO1+RLO2)
73501 RFO=0.5D0*(RFO1+RFO2)
73502 ELSEIF(ISSET1.EQ.1) THEN
73503 RLO=RLO1
73504 RFO=RFO1
73505 ELSE
73506 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
73507 RLO=1D0
73508 RFO=0D0
73509 ENDIF
73510
73511C...Output.
73512 PYMAEL=RFO/RLO
73513
73514 RETURN
73515 END
73516
73517C*********************************************************************
73518
73519C...PYBOEI
73520C...Modifies an event so as to approximately take into account
73521C...Bose-Einstein effects according to a simple phenomenological
73522C...parametrization.
73523
73524 SUBROUTINE PYBOEI(NSAV)
73525
73526C...Double precision and integer declarations.
73527 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73528 IMPLICIT INTEGER(I-N)
73529 INTEGER PYK,PYCHGE,PYCOMP
73530C...Parameter statement to help give large particle numbers.
73531 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
73532 &KEXCIT=4000000,KDIMEN=5000000)
73533C...Commonblocks.
73534 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73535 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73536 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73537 COMMON/PYINT1/MINT(400),VINT(400)
73538 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
73539C...Local arrays and data.
73540 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
73541 &BEIW(100),BEI3W(100)
73542 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
73543C...Statement function: squared invariant mass.
73544 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
73545 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
73546
73547C...Boost event to overall CM frame. Calculate CM energy.
73548 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
73549 DO 100 J=1,4
73550 DPS(J)=0D0
73551 100 CONTINUE
73552 DO 120 I=1,N
73553 KFA=IABS(K(I,2))
73554 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
73555 & .AND.K(I,3).GT.0) THEN
73556 KFMA=IABS(K(K(I,3),2))
73557 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
73558 ENDIF
73559 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
73560 DO 110 J=1,4
73561 DPS(J)=DPS(J)+P(I,J)
73562 110 CONTINUE
73563 120 CONTINUE
73564 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
73565 &-DPS(3)/DPS(4))
73566 PECM=0D0
73567 DO 130 I=1,N
73568 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
73569 130 CONTINUE
73570
73571C...Check if we have separated strings
73572
73573C...Reserve copy of particles by species at end of record.
73574 IWP=0
73575 IWN=0
73576 NBE(0)=N+MSTU(3)
73577 NMAX=NBE(0)
73578 SMMIN=PECM
73579 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
73580 NBE(IBE)=NBE(IBE-1)
73581 DO 180 I=NSAV+1,N
73582 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
73583 DO 140 IIBE=1,IBE-1
73584 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
73585 140 CONTINUE
73586 ELSE
73587 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
73588 ENDIF
73589 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
73590 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
73591 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
73592 RETURN
73593 ENDIF
73594 NBE(IBE)=NBE(IBE)+1
73595 NMAX=NBE(IBE)
73596 K(NBE(IBE),1)=I
73597 K(NBE(IBE),2)=0
73598 K(NBE(IBE),3)=0
73599 K(NBE(IBE),4)=0
73600 K(NBE(IBE),5)=0
73601 P(NBE(IBE),1)=0.0D0
73602 P(NBE(IBE),2)=0.0D0
73603 P(NBE(IBE),3)=0.0D0
73604 P(NBE(IBE),4)=0.0D0
73605 P(NBE(IBE),5)=0.0D0
73606 SMMIN=MIN(SMMIN,P(I,5))
73607C...Check if particles comes from different W's or Z's
73608 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
73609 IM=I
73610 150 IF(K(IM,3).GT.0) THEN
73611 IM=K(IM,3)
73612 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
73613 K(NBE(IBE),5)=IM
73614 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
73615 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
73616 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
73617 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
73618 ENDIF
73619 ENDIF
73620C...Check if particles comes from different strings.
73621 IF(PARJ(94).GT.0.0D0) THEN
73622 IM=I
73623 160 IF(K(IM,3).GT.0) THEN
73624 IM=K(IM,3)
73625 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
73626 K(NBE(IBE),5)=IM
73627 ENDIF
73628 ENDIF
73629 DO 170 J=1,3
73630 P(NBE(IBE),J)=0D0
73631 V(NBE(IBE),J)=0D0
73632 170 CONTINUE
73633 P(NBE(IBE),5)=-1.0D0
73634 180 CONTINUE
73635 190 CONTINUE
73636 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
73637
73638C...Calculate separation between W+ and W- or between two Z0's.
73639C...No separation if there has been re-connections.
73640 SIGW=PARJ(93)
73641 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
73642 IF(K(IWP,2).EQ.23) THEN
73643 DMW=PMAS(23,1)
73644 DGW=PMAS(23,2)
73645 ELSE
73646 DMW=PMAS(24,1)
73647 DGW=PMAS(24,2)
73648 ENDIF
73649 DMP=P(IWP,5)
73650 DMN=P(IWN,5)
73651 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
73652 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
73653 TAUP=-TAUPD*LOG(PYR(IDUM))
73654 TAUN=-TAUND*LOG(PYR(IDUM))
73655 DXP=TAUP*PYP(IWP,8)/DMP
73656 DXN=TAUN*PYP(IWN,8)/DMN
73657 DX=DXP+DXN
73658 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
73659 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
73660 ENDIF
73661
73662C...Add separation between strings.
73663 IF(PARJ(94).GT.0.0D0) THEN
73664 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
73665 IWP=-1
73666 IWN=-1
73667 ENDIF
73668
73669 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
73670 DO 220 IBE=1,MIN(9,MSTJ(52))
73671 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
73672 Q2MIN=PECM**2
73673 I1=K(I1M,1)
73674 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
73675 IF(I2M.EQ.I1M) GOTO 200
73676 I2=K(I2M,1)
73677 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
73678 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
73679 & (P(I1,5)+P(I2,5))**2
73680 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
73681 Q2MIN=Q2
73682 ENDIF
73683 200 CONTINUE
73684 P(I1M,5)=Q2MIN
73685 210 CONTINUE
73686 220 CONTINUE
73687 ENDIF
73688
73689C...Tabulate integral for subsequent momentum shift.
73690 DO 400 IBE=1,MIN(9,MSTJ(52))
73691 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
73692 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
73693 & .LE.1) GOTO 270
73694 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
73695 & NBE(7)-NBE(6)).LE.1) GOTO 270
73696 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
73697 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
73698 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
73699 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
73700 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
73701 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
73702 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
73703 QDELW=0.1D0*MIN(PMHQ,SIGW)
73704 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
73705 IF(MSTJ(51).EQ.1) THEN
73706 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
73707 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
73708 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
73709 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
73710 BEEX=EXP(0.5D0*QDEL/PARJ(93))
73711 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
73712 BEEXW=EXP(0.5D0*QDELW/SIGW)
73713 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
73714 BERT=EXP(-QDEL/PARJ(93))
73715 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
73716 BERTW=EXP(-QDELW/SIGW)
73717 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
73718 ELSE
73719 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
73720 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
73721 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
73722 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
73723 ENDIF
73724 DO 230 IBIN=1,NBIN
73725 QBIN=QDEL*(IBIN-0.5D0)
73726 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
73727 IF(MSTJ(51).EQ.1) THEN
73728 BEEX=BEEX*BERT
73729 BEI(IBIN)=BEI(IBIN)*BEEX
73730 ELSE
73731 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
73732 ENDIF
73733 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
73734 230 CONTINUE
73735 DO 240 IBIN=1,NBIN3
73736 QBIN=QDEL3*(IBIN-0.5D0)
73737 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
73738 IF(MSTJ(51).EQ.1) THEN
73739 BEEX3=BEEX3*BERT3
73740 BEI3(IBIN)=BEI3(IBIN)*BEEX3
73741 ELSE
73742 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
73743 ENDIF
73744 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
73745 240 CONTINUE
73746 DO 250 IBIN=1,NBINW
73747 QBIN=QDELW*(IBIN-0.5D0)
73748 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
73749 IF(MSTJ(51).EQ.1) THEN
73750 BEEXW=BEEXW*BERTW
73751 BEIW(IBIN)=BEIW(IBIN)*BEEXW
73752 ELSE
73753 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
73754 ENDIF
73755 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
73756 250 CONTINUE
73757 DO 260 IBIN=1,NBIN3W
73758 QBIN=QDEL3W*(IBIN-0.5D0)
73759 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
73760 & SQRT(QBIN**2+PMHQ**2)
73761 IF(MSTJ(51).EQ.1) THEN
73762 BEEX3W=BEEX3W*BERT3W
73763 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
73764 ELSE
73765 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
73766 ENDIF
73767 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
73768 260 CONTINUE
73769
73770C...Loop through particle pairs and find old relative momentum.
73771 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
73772 I1=K(I1M,1)
73773 DO 380 I2M=I1M+1,NBE(IBE)
73774 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
73775 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
73776 I2=K(I2M,1)
73777 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
73778 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
73779 IF(Q2OLD.LE.0.0D0) GOTO 380
73780 QOLD=SQRT(Q2OLD)
73781
73782C...Calculate new relative momentum.
73783 QMOV=0.0D0
73784 QMOV3=0.0D0
73785 QMOVW=0.0D0
73786 QMOV3W=0.0D0
73787 IF(QOLD.LT.1D-3*QDEL) THEN
73788 GOTO 280
73789 ELSEIF(QOLD.LE.QDEL) THEN
73790 QMOV=QOLD/3D0
73791 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
73792 RBIN=QOLD/QDEL
73793 IBIN=RBIN
73794 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
73795 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
73796 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
73797 ELSE
73798 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
73799 ENDIF
73800 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
73801 IF(QOLD.LT.1D-3*QDEL3) THEN
73802 GOTO 290
73803 ELSEIF(QOLD.LE.QDEL3) THEN
73804 QMOV3=QOLD/3D0
73805 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
73806 RBIN3=QOLD/QDEL3
73807 IBIN3=RBIN3
73808 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
73809 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
73810 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
73811 ELSE
73812 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
73813 ENDIF
73814 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
73815 RSCALE=1.0D0
73816 IF(MSTJ(54).EQ.2)
73817 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
73818 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
73819 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
73820
73821 IF(QOLD.LT.1D-3*QDELW) THEN
73822 GOTO 300
73823 ELSEIF(QOLD.LE.QDELW) THEN
73824 QMOVW=QOLD/3D0
73825 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
73826 RBINW=QOLD/QDELW
73827 IBINW=RBINW
73828 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
73829 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
73830 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
73831 ELSE
73832 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
73833 ENDIF
73834 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
73835 IF(QOLD.LT.1D-3*QDEL3W) THEN
73836 GOTO 310
73837 ELSEIF(QOLD.LE.QDEL3W) THEN
73838 QMOV3W=QOLD/3D0
73839 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
73840 RBIN3W=QOLD/QDEL3W
73841 IBIN3W=RBIN3W
73842 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
73843 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
73844 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
73845 ELSE
73846 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
73847 ENDIF
73848 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
73849 IF(MSTJ(54).EQ.2)
73850 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
73851
73852 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
73853 DO 330 J=1,3
73854 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
73855 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
73856 330 CONTINUE
73857 IF(MSTJ(54).GE.1) THEN
73858 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
73859 DO 340 J=1,3
73860 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
73861 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
73862 340 CONTINUE
73863 ELSEIF(MSTJ(54).LE.-1) THEN
73864 EDEL=P(I1,4)+P(I2,4)-
73865 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
73866 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
73867 & (P(I1,3)-P(I2,3))**2
73868 WMAX=-1.0D20
73869 MI3=0
73870 MI4=0
73871 S12=SDIP(I1,I2)
73872 SM1=(P(I1,5)+SMMIN)**2
73873 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
73874 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
73875 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
73876 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
73877 & K(I3M,5).NE.K(I1M,5)) GOTO 360
73878 I3=K(I3M,1)
73879 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
73880 S13=SDIP(I1,I3)
73881 S23=SDIP(I2,I3)
73882 SM3=(P(I3,5)+SMMIN)**2
73883 IF(MSTJ(54).EQ.-2) THEN
73884 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
73885 & S23*MIN(SM1,SM3))*SM1)
73886 ELSE
73887 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
73888 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
73889 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
73890 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
73891 ENDIF
73892 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
73893 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
73894 & GOTO 360
73895 ELSE
73896 IF(WMAX*WI.GE.1.0) GOTO 360
73897 ENDIF
73898 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
73899 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
73900 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
73901 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
73902 & K(I4M,5).NE.K(I1M,5)) GOTO 350
73903 I4=K(I4M,1)
73904 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
73905 & GOTO 350
73906 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
73907 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
73908 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
73909 & GOTO 350
73910 IF(MSTJ(54).EQ.-2) THEN
73911 S14=SDIP(I1,I4)
73912 S24=SDIP(I2,I4)
73913 S34=SDIP(I3,I4)
73914 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
73915 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
73916 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
73917 W=MIN(W,MIN(S23,S24)*S13*S14)
73918 W=1.0D0/W
73919 ELSE
73920C...weight=1-cos(theta)/mtot2
73921 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
73922 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
73923 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
73924 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
73925 W=1.0D0/S1234
73926 IF(W.LE.WMAX) GOTO 350
73927 ENDIF
73928 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
73929 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
73930 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
73931 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
73932 IF(W.LE.WMAX) GOTO 350
73933 MI3=I3M
73934 MI4=I4M
73935 WMAX=W
73936 350 CONTINUE
73937 360 CONTINUE
73938 IF(MI4.EQ.0) GOTO 380
73939 I3=K(MI3,1)
73940 I4=K(MI4,1)
73941 EOLD=P(I3,4)+P(I4,4)
73942 ENEW=EOLD+EDEL
73943 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
73944 & (P(I3,3)+P(I4,3))**2
73945 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
73946 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
73947 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
73948 DO 370 J=1,3
73949 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
73950 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
73951 370 CONTINUE
73952 ENDIF
73953 380 CONTINUE
73954 390 CONTINUE
73955 400 CONTINUE
73956
73957C...Shift momenta and recalculate energies.
73958 ESUMP=0.0D0
73959 ESUM=0.0D0
73960 PROD=0.0D0
73961 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
73962 I=K(IM,1)
73963 ESUMP=ESUMP+P(I,4)
73964 DO 410 J=1,3
73965 P(I,J)=P(I,J)+P(IM,J)
73966 410 CONTINUE
73967 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
73968 ESUM=ESUM+P(I,4)
73969 DO 420 J=1,3
73970 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
73971 420 CONTINUE
73972 430 CONTINUE
73973
73974 PARJ(96)=0.0D0
73975 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
73976 440 ALPHA=(ESUMP-ESUM)/PROD
73977 PARJ(96)=PARJ(96)+ALPHA
73978 PROD=0.0D0
73979 ESUM=0.0D0
73980 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
73981 I=K(IM,1)
73982 DO 450 J=1,3
73983 P(I,J)=P(I,J)+ALPHA*V(IM,J)
73984 450 CONTINUE
73985 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
73986 ESUM=ESUM+P(I,4)
73987 DO 460 J=1,3
73988 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
73989 460 CONTINUE
73990 470 CONTINUE
73991 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
73992 & GOTO 440
73993 ENDIF
73994
73995C...Rescale all momenta for energy conservation.
73996 PES=0D0
73997 PQS=0D0
73998 DO 480 I=1,N
73999 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
74000 PES=PES+P(I,4)
74001 PQS=PQS+P(I,5)**2/P(I,4)
74002 480 CONTINUE
74003 PARJ(95)=PES-PECM
74004 FAC=(PECM-PQS)/(PES-PQS)
74005 DO 500 I=1,N
74006 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
74007 DO 490 J=1,3
74008 P(I,J)=FAC*P(I,J)
74009 490 CONTINUE
74010 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
74011 500 CONTINUE
74012
74013C...Boost back to correct reference frame.
74014 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
74015 DO 520 I=1,N
74016 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
74017 520 CONTINUE
74018
74019 RETURN
74020 END
74021
74022C*********************************************************************
74023
74024C...PYBESQ
74025C...Calculates the momentum shift in a system of two particles assuming
74026C...the relative momentum squared should be shifted to Q2NEW. NI is the
74027C...last position occupied in /PYJETS/.
74028
74029 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
74030
74031C...Double precision and integer declarations.
74032 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74033 IMPLICIT INTEGER(I-N)
74034 INTEGER PYK,PYCHGE,PYCOMP
74035C...Parameter statement to help give large particle numbers.
74036 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74037 &KEXCIT=4000000,KDIMEN=5000000)
74038C...Commonblocks.
74039 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74040 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74041 SAVE /PYJETS/,/PYDAT1/
74042C...Local arrays and data.
74043 DIMENSION DP(5)
74044 SAVE HC1
74045
74046 IF(MSTJ(55).EQ.0) THEN
74047 DQ2=Q2NEW-Q2OLD
74048 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
74049 & (P(I1,3)-P(I2,3))**2
74050 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
74051 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
74052 SE=P(I1,4)+P(I2,4)
74053 DE=P(I1,4)-P(I2,4)
74054 DQ2SE=DQ2+SE**2
74055 DA=SE*DE*DP12-DP2*DQ2SE
74056 DB=DP2*DQ2SE-DP12**2
74057 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
74058 DO 100 J=1,3
74059 PD=HA*(P(I1,J)-P(I2,J))
74060 P(NI+1,J)=PD
74061 P(NI+2,J)=-PD
74062 100 CONTINUE
74063 RETURN
74064 ENDIF
74065
74066 K(NI+1,1)=1
74067 K(NI+2,1)=1
74068 DO 110 J=1,5
74069 P(NI+1,J)=P(I1,J)
74070 P(NI+2,J)=P(I2,J)
74071 DP(J)=P(I1,J)+P(I2,J)
74072 110 CONTINUE
74073
74074C...Boost to cms and rotate first particle to z-axis
74075 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
74076 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
74077 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
74078 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
74079 S=Q2NEW+(P(I1,5)+P(I2,5))**2
74080 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
74081 P(NI+1,1)=0.0D0
74082 P(NI+1,2)=0.0D0
74083 P(NI+1,3)=PZ
74084 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
74085 P(NI+2,1)=0.0D0
74086 P(NI+2,2)=0.0D0
74087 P(NI+2,3)=-PZ
74088 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
74089 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
74090 CALL PYROBO(NI+1,NI+2,THE,PHI,
74091 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
74092
74093 DO 120 J=1,3
74094 P(NI+1,J)=P(NI+1,J)-P(I1,J)
74095 P(NI+2,J)=P(NI+2,J)-P(I2,J)
74096 120 CONTINUE
74097
74098 RETURN
74099 END
74100
74101C*********************************************************************
74102
74103C...PYMASS
74104C...Gives the mass of a particle/parton.
74105
74106 FUNCTION PYMASS(KF)
74107
74108C...Double precision and integer declarations.
74109 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74110 IMPLICIT INTEGER(I-N)
74111 INTEGER PYK,PYCHGE,PYCOMP
74112C...Commonblocks.
74113 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74114 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74115 SAVE /PYDAT1/,/PYDAT2/
74116
74117C...Reset variables. Compressed code. Special case for popcorn diquarks.
74118 PYMASS=0D0
74119 KFA=IABS(KF)
74120 KC=PYCOMP(KF)
74121 IF(KC.EQ.0) THEN
74122 MSTJ(93)=0
74123 RETURN
74124 ENDIF
74125
74126C...Guarantee use of constituent masses for internal checks.
74127 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
74128 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
74129 IF(KFA.LE.5) THEN
74130 PYMASS=PARF(100+KFA)
74131 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
74132 ELSEIF(KFA.LE.10) THEN
74133 PYMASS=PMAS(KFA,1)
74134 ELSEIF(MSTJ(93).EQ.1) THEN
74135 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
74136 ELSE
74137 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
74138 ENDIF
74139
74140C...Other masses can be read directly off table.
74141 ELSE
74142 PYMASS=PMAS(KC,1)
74143 ENDIF
74144
74145C...Optional mass broadening according to truncated Breit-Wigner
74146C...(either in m or in m^2).
74147 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
74148 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
74149 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
74150 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
74151 ELSE
74152 PM0=PYMASS
74153 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
74154 & (PM0*PMAS(KC,2)))
74155 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
74156 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
74157 & (PMUPP-PMLOW)*PYR(0))))
74158 ENDIF
74159 ENDIF
74160 MSTJ(93)=0
74161
74162 RETURN
74163 END
74164
74165C*********************************************************************
74166
74167C...PYMRUN
74168C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
74169C...for Higgs couplings. Everything else sent on to PYMASS.
74170
74171 FUNCTION PYMRUN(KF,Q2)
74172
74173C...Double precision and integer declarations.
74174 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74175 IMPLICIT INTEGER(I-N)
74176 INTEGER PYK,PYCHGE,PYCOMP
74177C...Commonblocks.
74178 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74179 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74180 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
74181 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
74182
74183C...Most masses not handled here.
74184 KFA=IABS(KF)
74185 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
74186 PYMRUN=PYMASS(KF)
74187
74188C...Current-algebra masses, but no Q2 dependence.
74189 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
74190 PYMRUN=PARF(90+KFA)
74191
74192C...Running current-algebra masses.
74193 ELSE
74194 AS=PYALPS(Q2)
74195 PYMRUN=PARF(90+KFA)*
74196 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
74197 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
74198 ENDIF
74199
74200 RETURN
74201 END
74202
74203C*********************************************************************
74204
74205C...PYNAME
74206C...Gives the particle/parton name as a character string.
74207
74208 SUBROUTINE PYNAME(KF,CHAU)
74209
74210C...Double precision and integer declarations.
74211 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74212 IMPLICIT INTEGER(I-N)
74213 INTEGER PYK,PYCHGE,PYCOMP
74214C...Commonblocks.
74215 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74216 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74217 COMMON/PYDAT4/CHAF(500,2)
74218 CHARACTER CHAF*16
74219 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
74220C...Local character variable.
74221 CHARACTER CHAU*16
74222
74223C...Read out code with distinction particle/antiparticle.
74224 CHAU=' '
74225 KC=PYCOMP(KF)
74226 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
74227
74228
74229 RETURN
74230 END
74231
74232C*********************************************************************
74233
74234C...PYCHGE
74235C...Gives three times the charge for a particle/parton.
74236
74237 FUNCTION PYCHGE(KF)
74238
74239C...Double precision and integer declarations.
74240 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74241 IMPLICIT INTEGER(I-N)
74242 INTEGER PYK,PYCHGE,PYCOMP
74243C...Commonblocks.
74244 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74245 SAVE /PYDAT2/
74246
74247C...Read out charge and change sign for antiparticle.
74248 PYCHGE=0
74249 KC=PYCOMP(KF)
74250 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
74251
74252 RETURN
74253 END
74254
74255C*********************************************************************
74256
74257C...PYCOMP
74258C...Compress the standard KF codes for use in mass and decay arrays;
74259C...also checks whether a given code actually is defined.
74260
74261 FUNCTION PYCOMP(KF)
74262
74263C...Double precision and integer declarations.
74264 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74265 IMPLICIT INTEGER(I-N)
74266 INTEGER PYK,PYCHGE,PYCOMP
74267C...Commonblocks.
74268 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74269 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74270 SAVE /PYDAT1/,/PYDAT2/
74271C...Local arrays and saved data.
74272 DIMENSION KFORD(100:500),KCORD(101:500)
74273 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
74274
74275C...Whenever necessary reorder codes for faster search.
74276 IF(MSTU(20).EQ.0) THEN
74277 NFORD=100
74278 KFORD(100)=0
74279 DO 120 I=101,500
74280 KFA=KCHG(I,4)
74281 IF(KFA.LE.100) GOTO 120
74282 NFORD=NFORD+1
74283 DO 100 I1=NFORD-1,0,-1
74284 IF(KFA.GE.KFORD(I1)) GOTO 110
74285 KFORD(I1+1)=KFORD(I1)
74286 KCORD(I1+1)=KCORD(I1)
74287 100 CONTINUE
74288 110 KFORD(I1+1)=KFA
74289 KCORD(I1+1)=I
74290 120 CONTINUE
74291 MSTU(20)=1
74292 KFLAST=0
74293 KCLAST=0
74294 ENDIF
74295
74296C...Fast action if same code as in latest call.
74297 IF(KF.EQ.KFLAST) THEN
74298 PYCOMP=KCLAST
74299 RETURN
74300 ENDIF
74301
74302C...Starting values. Remove internal diquark flags.
74303 PYCOMP=0
74304 KFA=IABS(KF)
74305 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
74306 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
74307
74308C...Simple cases: direct translation.
74309 IF(KFA.GT.KFORD(NFORD)) THEN
74310 ELSEIF(KFA.LE.100) THEN
74311 PYCOMP=KFA
74312
74313C...Else binary search.
74314 ELSE
74315 IMIN=100
74316 IMAX=NFORD+1
74317 130 IAVG=(IMIN+IMAX)/2
74318 IF(KFORD(IAVG).GT.KFA) THEN
74319 IMAX=IAVG
74320 IF(IMAX.GT.IMIN+1) GOTO 130
74321 ELSEIF(KFORD(IAVG).LT.KFA) THEN
74322 IMIN=IAVG
74323 IF(IMAX.GT.IMIN+1) GOTO 130
74324 ELSE
74325 PYCOMP=KCORD(IAVG)
74326 ENDIF
74327 ENDIF
74328
74329C...Check if antiparticle allowed.
74330 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
74331 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
74332 ENDIF
74333
74334C...Save codes for possible future fast action.
74335 KFLAST=KF
74336 KCLAST=PYCOMP
74337
74338 RETURN
74339 END
74340
74341C*********************************************************************
74342
74343C...PYERRM
74344C...Informs user of errors in program execution.
74345
74346 SUBROUTINE PYERRM(MERR,CHMESS)
74347
74348C...Double precision and integer declarations.
74349 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74350 IMPLICIT INTEGER(I-N)
74351 INTEGER PYK,PYCHGE,PYCOMP
74352C...Commonblocks.
74353 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74354 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74355 SAVE /PYJETS/,/PYDAT1/
74356C...Local character variable.
74357 CHARACTER CHMESS*(*)
74358
74359C...Write first few warnings, then be silent.
74360 IF(MERR.LE.10) THEN
74361 MSTU(27)=MSTU(27)+1
74362 MSTU(28)=MERR
74363 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
74364 & MERR,MSTU(31),CHMESS
74365
74366C...Write first few errors, then be silent or stop program.
74367 ELSEIF(MERR.LE.20) THEN
74368 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
74369 MSTU(30)=MSTU(30)+1
74370 MSTU(24)=MERR-10
74371 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
74372 & MERR-10,MSTU(31),CHMESS
74373 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
74374 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
74375 WRITE(MSTU(11),5200)
74376 IF(MERR.NE.17) CALL PYLIST(2)
74377 CALL PYSTOP(3)
74378 ENDIF
74379
74380C...Stop program in case of irreparable error.
74381 ELSE
74382 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
74383 CALL PYSTOP(3)
74384 ENDIF
74385
74386C...Formats for output.
74387 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
74388 &' PYEXEC calls:'/5X,A)
74389 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
74390 &' PYEXEC calls:'/5X,A)
74391 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
74392 &'event!')
74393 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
74394 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
74395
74396 RETURN
74397 END
74398
74399C*********************************************************************
74400
74401C...PYALEM
74402C...Calculates the running alpha_electromagnetic.
74403
74404 FUNCTION PYALEM(Q2)
74405
74406C...Double precision and integer declarations.
74407 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74408 IMPLICIT INTEGER(I-N)
74409 INTEGER PYK,PYCHGE,PYCOMP
74410C...Commonblocks.
74411 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74412 SAVE /PYDAT1/
74413
74414C...Calculate real part of photon vacuum polarization.
74415C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
74416C...For hadrons use parametrization of H. Burkhardt et al.
74417C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
74418 AEMPI=PARU(101)/(3D0*PARU(1))
74419 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
74420 RPIGG=0D0
74421 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
74422 RPIGG=0D0
74423 ELSEIF(MSTU(101).EQ.2) THEN
74424 RPIGG=1D0-PARU(101)/PARU(103)
74425 ELSEIF(Q2.LT.0.09D0) THEN
74426 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
74427 ELSEIF(Q2.LT.9D0) THEN
74428 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
74429 & 0.00238D0*LOG(1D0+3.927D0*Q2)
74430 ELSEIF(Q2.LT.1D4) THEN
74431 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
74432 & 0.00299D0*LOG(1D0+Q2)
74433 ELSE
74434 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
74435 & 0.00293D0*LOG(1D0+Q2)
74436 ENDIF
74437
74438C...Calculate running alpha_em.
74439 PYALEM=PARU(101)/(1D0-RPIGG)
74440 PARU(108)=PYALEM
74441
74442 RETURN
74443 END
74444
74445C*********************************************************************
74446
74447C...PYALPS
74448C...Gives the value of alpha_strong.
74449
74450 FUNCTION PYALPS(Q2)
74451
74452C...Double precision and integer declarations.
74453 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74454 IMPLICIT INTEGER(I-N)
74455 INTEGER PYK,PYCHGE,PYCOMP
74456C...Commonblocks.
74457 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74458 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74459 SAVE /PYDAT1/,/PYDAT2/
74460C...Coefficients for second-order threshold matching.
74461C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
74462 DIMENSION STEPDN(6),STEPUP(6)
74463c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
74464c &(2D0*321D0/3703D0),0D0/
74465c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
74466c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
74467 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
74468 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
74469
74470C...Constant alpha_strong trivial. Pick artificial Lambda.
74471 IF(MSTU(111).LE.0) THEN
74472 PYALPS=PARU(111)
74473 MSTU(118)=MSTU(112)
74474 PARU(117)=0.2D0
74475 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
74476 & ((33D0-2D0*MSTU(112))*PARU(111)))
74477 PARU(118)=PARU(111)
74478 RETURN
74479 ENDIF
74480
74481C...Find effective Q2, number of flavours and Lambda.
74482 Q2EFF=Q2
74483 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
74484 NF=MSTU(112)
74485 ALAM2=PARU(112)**2
74486 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
74487 Q2THR=PARU(113)*PMAS(NF,1)**2
74488 IF(Q2EFF.LT.Q2THR) THEN
74489 NF=NF-1
74490 Q2RAT=Q2THR/ALAM2
74491 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
74492 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
74493 GOTO 100
74494 ENDIF
74495 ENDIF
74496 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
74497 Q2THR=PARU(113)*PMAS(NF+1,1)**2
74498 IF(Q2EFF.GT.Q2THR) THEN
74499 NF=NF+1
74500 Q2RAT=Q2THR/ALAM2
74501 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
74502 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
74503 GOTO 110
74504 ENDIF
74505 ENDIF
74506 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
74507 PARU(117)=SQRT(ALAM2)
74508
74509C...Evaluate first or second order alpha_strong.
74510 B0=(33D0-2D0*NF)/6D0
74511 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
74512 IF(MSTU(111).EQ.1) THEN
74513 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
74514 ELSE
74515 B1=(153D0-19D0*NF)/6D0
74516 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
74517 & (B0**2*ALGQ)))
74518 ENDIF
74519 MSTU(118)=NF
74520 PARU(118)=PYALPS
74521
74522 RETURN
74523 END
74524
74525C*********************************************************************
74526
74527C...PYANGL
74528C...Reconstructs an angle from given x and y coordinates.
74529
74530 FUNCTION PYANGL(X,Y)
74531
74532C...Double precision and integer declarations.
74533 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74534 IMPLICIT INTEGER(I-N)
74535 INTEGER PYK,PYCHGE,PYCOMP
74536C...Commonblocks.
74537 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74538 SAVE /PYDAT1/
74539
74540 PYANGL=0D0
74541 R=SQRT(X**2+Y**2)
74542 IF(R.LT.1D-20) RETURN
74543 IF(ABS(X)/R.LT.0.8D0) THEN
74544 PYANGL=SIGN(ACOS(X/R),Y)
74545 ELSE
74546 PYANGL=ASIN(Y/R)
74547 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
74548 PYANGL=PARU(1)-PYANGL
74549 ELSEIF(X.LT.0D0) THEN
74550 PYANGL=-PARU(1)-PYANGL
74551 ENDIF
74552 ENDIF
74553
74554 RETURN
74555 END
74556
74557C*********************************************************************
74558C*********************************************************************
74559
74560C...PYROBO
74561C...Performs rotations and boosts.
74562
74563 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
74564
74565C...Double precision and integer declarations.
74566 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74567 IMPLICIT INTEGER(I-N)
74568 INTEGER PYK,PYCHGE,PYCOMP
74569C...Commonblocks.
74570 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74571 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74572 SAVE /PYJETS/,/PYDAT1/
74573C...Local arrays.
74574 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
74575
74576C...Find and check range of rotation/boost.
74577 IMIN=IMI
74578 IF(IMIN.LE.0) IMIN=1
74579 IF(MSTU(1).GT.0) IMIN=MSTU(1)
74580 IMAX=IMA
74581 IF(IMAX.LE.0) IMAX=N
74582 IF(MSTU(2).GT.0) IMAX=MSTU(2)
74583 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
74584 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
74585 RETURN
74586 ENDIF
74587
74588C...Optional resetting of V (when not set before.)
74589 IF(MSTU(33).NE.0) THEN
74590 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
74591 DO 100 J=1,5
74592 V(I,J)=0D0
74593 100 CONTINUE
74594 110 CONTINUE
74595 MSTU(33)=0
74596 ENDIF
74597
74598C...Rotate, typically from z axis to direction (theta,phi).
74599 IF(THE**2+PHI**2.GT.1D-20) THEN
74600 ROT(1,1)=COS(THE)*COS(PHI)
74601 ROT(1,2)=-SIN(PHI)
74602 ROT(1,3)=SIN(THE)*COS(PHI)
74603 ROT(2,1)=COS(THE)*SIN(PHI)
74604 ROT(2,2)=COS(PHI)
74605 ROT(2,3)=SIN(THE)*SIN(PHI)
74606 ROT(3,1)=-SIN(THE)
74607 ROT(3,2)=0D0
74608 ROT(3,3)=COS(THE)
74609 DO 140 I=IMIN,IMAX
74610 IF(K(I,1).LE.0) GOTO 140
74611 DO 120 J=1,3
74612 PR(J)=P(I,J)
74613 VR(J)=V(I,J)
74614 120 CONTINUE
74615 DO 130 J=1,3
74616 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
74617 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
74618 130 CONTINUE
74619 140 CONTINUE
74620 ENDIF
74621
74622C...Boost, typically from rest to momentum/energy=beta.
74623 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
74624 DBX=BEX
74625 DBY=BEY
74626 DBZ=BEZ
74627 DB=SQRT(DBX**2+DBY**2+DBZ**2)
74628 EPS1=1D0-1D-12
74629 IF(DB.GT.EPS1) THEN
74630C...Rescale boost vector if too close to unity.
74631 CALL PYERRM(3,'(PYROBO:) boost vector too large')
74632 DBX=DBX*(EPS1/DB)
74633 DBY=DBY*(EPS1/DB)
74634 DBZ=DBZ*(EPS1/DB)
74635 DB=EPS1
74636 ENDIF
74637 DGA=1D0/SQRT(1D0-DB**2)
74638 DO 160 I=IMIN,IMAX
74639 IF(K(I,1).LE.0) GOTO 160
74640 DO 150 J=1,4
74641 DP(J)=P(I,J)
74642 DV(J)=V(I,J)
74643 150 CONTINUE
74644 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
74645 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
74646 P(I,1)=DP(1)+DGABP*DBX
74647 P(I,2)=DP(2)+DGABP*DBY
74648 P(I,3)=DP(3)+DGABP*DBZ
74649 P(I,4)=DGA*(DP(4)+DBP)
74650 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
74651 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
74652 V(I,1)=DV(1)+DGABV*DBX
74653 V(I,2)=DV(2)+DGABV*DBY
74654 V(I,3)=DV(3)+DGABV*DBZ
74655 V(I,4)=DGA*(DV(4)+DBV)
74656 160 CONTINUE
74657 ENDIF
74658
74659 RETURN
74660 END
74661
74662C*********************************************************************
74663
74664C...PYEDIT
74665C...Performs global manipulations on the event record, in particular
74666C...to exclude unstable or undetectable partons/particles.
74667
74668 SUBROUTINE PYEDIT(MEDIT)
74669
74670C...Double precision and integer declarations.
74671 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74672 IMPLICIT INTEGER(I-N)
74673 INTEGER PYK,PYCHGE,PYCOMP
74674C...Parameter statement to help give large particle numbers.
74675 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74676 &KEXCIT=4000000,KDIMEN=5000000)
74677C...Commonblocks.
74678 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74679 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74680 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74681 COMMON/PYCTAG/NCT,MCT(4000,2)
74682 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
74683C...Local arrays.
74684 DIMENSION NS(2),PTS(2),PLS(2)
74685
74686C...Remove unwanted partons/particles.
74687 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
74688 IMAX=N
74689 IF(MSTU(2).GT.0) IMAX=MSTU(2)
74690 I1=MAX(1,MSTU(1))-1
74691 DO 110 I=MAX(1,MSTU(1)),IMAX
74692 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
74693 IF(MEDIT.EQ.1) THEN
74694 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
74695 ELSEIF(MEDIT.EQ.2) THEN
74696 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
74697 KC=PYCOMP(K(I,2))
74698 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74699 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74700 & K(I,2).EQ.KSUSY1+39) GOTO 110
74701 ELSEIF(MEDIT.EQ.3) THEN
74702 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
74703 KC=PYCOMP(K(I,2))
74704 IF(KC.EQ.0) GOTO 110
74705 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
74706 ELSEIF(MEDIT.EQ.5) THEN
74707 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
74708 KC=PYCOMP(K(I,2))
74709 IF(KC.EQ.0) GOTO 110
74710 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
74711 & KCHG(KC,2).EQ.0) GOTO 110
74712 ENDIF
74713
74714C...Pack remaining partons/particles. Origin no longer known.
74715 I1=I1+1
74716 DO 100 J=1,5
74717 K(I1,J)=K(I,J)
74718 P(I1,J)=P(I,J)
74719 V(I1,J)=V(I,J)
74720 100 CONTINUE
74721 K(I1,3)=0
74722 110 CONTINUE
74723 IF(I1.LT.N) MSTU(3)=0
74724 IF(I1.LT.N) MSTU(70)=0
74725 N=I1
74726
74727C...Selective removal of class of entries. New position of retained.
74728 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
74729 I1=0
74730 DO 120 I=1,N
74731 K(I,3)=MOD(K(I,3),MSTU(5))
74732 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
74733 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
74734 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
74735 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
74736 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
74737 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
74738 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
74739 I1=I1+1
74740 K(I,3)=K(I,3)+MSTU(5)*I1
74741 120 CONTINUE
74742
74743C...Find new event history information and replace old.
74744 DO 140 I=1,N
74745 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
74746 & K(I,3)/MSTU(5).EQ.0) GOTO 140
74747 ID=I
74748 130 IM=MOD(K(ID,3),MSTU(5))
74749 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
74750 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
74751 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
74752 ID=IM
74753 GOTO 130
74754 ENDIF
74755 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
74756 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
74757 & K(IM,2).EQ.94) THEN
74758 ID=IM
74759 GOTO 130
74760 ENDIF
74761 ENDIF
74762 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
74763 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
74764 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
74765 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
74766 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
74767 & K(K(I,4),3)/MSTU(5)
74768 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
74769 & K(K(I,5),3)/MSTU(5)
74770 ELSE
74771 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
74772 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
74773 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
74774 KCD=MOD(K(I,4),MSTU(5))
74775 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
74776 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
74777 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
74778 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
74779 KCD=MOD(K(I,5),MSTU(5))
74780 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
74781 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
74782 ENDIF
74783 140 CONTINUE
74784
74785C...Pack remaining entries.
74786 I1=0
74787 MSTU90=MSTU(90)
74788 MSTU(90)=0
74789 DO 170 I=1,N
74790 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
74791 I1=I1+1
74792 DO 150 J=1,5
74793 K(I1,J)=K(I,J)
74794 P(I1,J)=P(I,J)
74795 V(I1,J)=V(I,J)
74796 150 CONTINUE
74797C...Also update LHA1 colour tags
74798 MCT(I1,1)=MCT(I,1)
74799 MCT(I1,2)=MCT(I,2)
74800 K(I1,3)=MOD(K(I1,3),MSTU(5))
74801 DO 160 IZ=1,MSTU90
74802 IF(I.EQ.MSTU(90+IZ)) THEN
74803 MSTU(90)=MSTU(90)+1
74804 MSTU(90+MSTU(90))=I1
74805 PARU(90+MSTU(90))=PARU(90+IZ)
74806 ENDIF
74807 160 CONTINUE
74808 170 CONTINUE
74809 IF(I1.LT.N) MSTU(3)=0
74810 IF(I1.LT.N) MSTU(70)=0
74811 N=I1
74812
74813C...Fill in some missing daughter pointers (lost in colour flow).
74814 ELSEIF(MEDIT.EQ.16) THEN
74815 DO 220 I=1,N
74816 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
74817 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
74818C...Find daughters who point to mother.
74819 DO 180 I1=I+1,N
74820 IF(K(I1,3).NE.I) THEN
74821 ELSEIF(K(I,4).EQ.0) THEN
74822 K(I,4)=I1
74823 ELSE
74824 K(I,5)=I1
74825 ENDIF
74826 180 CONTINUE
74827 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
74828 IF(K(I,4).NE.0) GOTO 220
74829C...Find daughters who point to documentation version of mother.
74830 IM=K(I,3)
74831 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
74832 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
74833 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
74834 DO 190 I1=I+1,N
74835 IF(K(I1,3).NE.IM) THEN
74836 ELSEIF(K(I,4).EQ.0) THEN
74837 K(I,4)=I1
74838 ELSE
74839 K(I,5)=I1
74840 ENDIF
74841 190 CONTINUE
74842 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
74843 IF(K(I,4).NE.0) GOTO 220
74844C...Find daughters who point to documentation daughters who,
74845C...in their turn, point to documentation mother.
74846 ID1=IM
74847 ID2=IM
74848 DO 200 I1=IM+1,I-1
74849 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
74850 ID2=I1
74851 IF(ID1.EQ.IM) ID1=I1
74852 ENDIF
74853 200 CONTINUE
74854 DO 210 I1=I+1,N
74855 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
74856 ELSEIF(K(I,4).EQ.0) THEN
74857 K(I,4)=I1
74858 ELSE
74859 K(I,5)=I1
74860 ENDIF
74861 210 CONTINUE
74862 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
74863 220 CONTINUE
74864
74865C...Save top entries at bottom of PYJETS commonblock.
74866 ELSEIF(MEDIT.EQ.21) THEN
74867 IF(2*N.GE.MSTU(4)) THEN
74868 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
74869 RETURN
74870 ENDIF
74871 DO 240 I=1,N
74872 DO 230 J=1,5
74873 K(MSTU(4)-I,J)=K(I,J)
74874 P(MSTU(4)-I,J)=P(I,J)
74875 V(MSTU(4)-I,J)=V(I,J)
74876 230 CONTINUE
74877 240 CONTINUE
74878 MSTU(32)=N
74879
74880C...Restore bottom entries of commonblock PYJETS to top.
74881 ELSEIF(MEDIT.EQ.22) THEN
74882 DO 260 I=1,MSTU(32)
74883 DO 250 J=1,5
74884 K(I,J)=K(MSTU(4)-I,J)
74885 P(I,J)=P(MSTU(4)-I,J)
74886 V(I,J)=V(MSTU(4)-I,J)
74887 250 CONTINUE
74888 260 CONTINUE
74889 N=MSTU(32)
74890
74891C...Mark primary entries at top of commonblock PYJETS as untreated.
74892 ELSEIF(MEDIT.EQ.23) THEN
74893 I1=0
74894 DO 270 I=1,N
74895 KH=K(I,3)
74896 IF(KH.GE.1) THEN
74897 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
74898 ENDIF
74899 IF(KH.NE.0) GOTO 280
74900 I1=I1+1
74901 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
74902 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
74903 270 CONTINUE
74904 280 N=I1
74905
74906C...Place largest axis along z axis and second largest in xy plane.
74907 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
74908 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
74909 & P(MSTU(61),2)),0D0,0D0,0D0)
74910 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
74911 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
74912 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
74913 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
74914 IF(MEDIT.EQ.31) RETURN
74915
74916C...Rotate to put slim jet along +z axis.
74917 DO 290 IS=1,2
74918 NS(IS)=0
74919 PTS(IS)=0D0
74920 PLS(IS)=0D0
74921 290 CONTINUE
74922 DO 300 I=1,N
74923 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
74924 IF(MSTU(41).GE.2) THEN
74925 KC=PYCOMP(K(I,2))
74926 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74927 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74928 & K(I,2).EQ.KSUSY1+39) GOTO 300
74929 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
74930 & .EQ.0) GOTO 300
74931 ENDIF
74932 IS=2D0-SIGN(0.5D0,P(I,3))
74933 NS(IS)=NS(IS)+1
74934 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
74935 300 CONTINUE
74936 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
74937 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
74938
74939C...Rotate to put second largest jet into -z,+x quadrant.
74940 DO 310 I=1,N
74941 IF(P(I,3).GE.0D0) GOTO 310
74942 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
74943 IF(MSTU(41).GE.2) THEN
74944 KC=PYCOMP(K(I,2))
74945 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74946 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74947 & K(I,2).EQ.KSUSY1+39) GOTO 310
74948 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
74949 & .EQ.0) GOTO 310
74950 ENDIF
74951 IS=2D0-SIGN(0.5D0,P(I,1))
74952 PLS(IS)=PLS(IS)-P(I,3)
74953 310 CONTINUE
74954 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
74955 & 0D0,0D0,0D0)
74956 ENDIF
74957
74958 RETURN
74959 END
74960
74961C*********************************************************************
74962
74963C...PYLIST
74964C...Gives program heading, or lists an event, or particle
74965C...data, or current parameter values.
74966
74967 SUBROUTINE PYLIST(MLIST)
74968
74969C...Double precision and integer declarations.
74970 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74971 IMPLICIT INTEGER(I-N)
74972 INTEGER PYK,PYCHGE,PYCOMP
74973C...Parameter statement to help give large particle numbers.
74974 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74975 &KEXCIT=4000000,KDIMEN=5000000)
74976
74977C...HEPEVT commonblock.
74978 PARAMETER (NMXHEP=4000)
74979 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
74980 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
74981 DOUBLE PRECISION PHEP,VHEP
74982 SAVE /HEPEVT/
74983
74984C...User process event common block.
74985 INTEGER MAXNUP
74986 PARAMETER (MAXNUP=500)
74987 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
74988 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
74989 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
74990 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
74991 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
74992 SAVE /HEPEUP/
74993
74994C...Commonblocks.
74995 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74996 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74997 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74998 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
74999 COMMON/PYCTAG/NCT,MCT(4000,2)
75000 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
75001C...Local arrays, character variables and data.
75002 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
75003 DIMENSION PS(6)
75004 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
75005
75006C...Initialization printout: version number and date of last change.
75007 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
75008 CALL PYLOGO
75009 MSTU(12)=12345
75010 IF(MLIST.EQ.0) RETURN
75011 ENDIF
75012
75013C...List event data, including additional lines after N.
75014 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
75015 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
75016 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
75017 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
75018 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
75019 LMX=12
75020 IF(MLIST.GE.2) LMX=16
75021 ISTR=0
75022 IMAX=N
75023 IF(MSTU(2).GT.0) IMAX=MSTU(2)
75024 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
75025 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
75026 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
75027 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
75028
75029C...Get particle name, pad it and check it is not too long.
75030 CALL PYNAME(K(I,2),CHAP)
75031 LEN=0
75032 DO 100 LEM=1,16
75033 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
75034 100 CONTINUE
75035 MDL=(K(I,1)+19)/10
75036 LDL=0
75037 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
75038 CHAC=CHAP
75039 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
75040 ELSE
75041 LDL=1
75042 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
75043 IF(LEN.EQ.0) THEN
75044 CHAC=CHDL(MDL)(1:2*LDL)//' '
75045 ELSE
75046 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
75047 & CHDL(MDL)(LDL+1:2*LDL)//' '
75048 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
75049 ENDIF
75050 ENDIF
75051
75052C...Add information on string connection.
75053 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
75054 & THEN
75055 KC=PYCOMP(K(I,2))
75056 KCC=0
75057 IF(KC.NE.0) KCC=KCHG(KC,2)
75058 IF(IABS(K(I,2)).EQ.39) THEN
75059 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
75060 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
75061 ISTR=1
75062 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
75063 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
75064 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
75065 ELSEIF(KCC.NE.0) THEN
75066 ISTR=0
75067 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
75068 ENDIF
75069 ENDIF
75070 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
75071 & CHAC(LMX-1:LMX-1)='I'
75072
75073C...Write data for particle/jet.
75074 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
75075 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
75076 & (P(I,J2),J2=1,5)
75077 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
75078 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
75079 & (P(I,J2),J2=1,5)
75080 ELSEIF(MLIST.EQ.1) THEN
75081 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
75082 & (P(I,J2),J2=1,5)
75083 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
75084 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
75085 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
75086 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
75087 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
75088 & (P(I,J2),J2=1,5)
75089 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
75090 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
75091 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
75092 & ,10000),MCT(I,1),MCT(I,2)
75093 ELSE
75094 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
75095 & (P(I,J2),J2=1,5)
75096 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
75097 & ,MCT(I,1),MCT(I,2)
75098 ENDIF
75099 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
75100
75101C...Insert extra separator lines specified by user.
75102 IF(MSTU(70).GE.1) THEN
75103 ISEP=0
75104 DO 110 J=1,MIN(10,MSTU(70))
75105 IF(I.EQ.MSTU(70+J)) ISEP=1
75106 110 CONTINUE
75107 IF(ISEP.EQ.1) THEN
75108 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
75109 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
75110 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
75111 ENDIF
75112 ENDIF
75113 120 CONTINUE
75114
75115C...Sum of charges and momenta.
75116 DO 130 J=1,6
75117 PS(J)=PYP(0,J)
75118 130 CONTINUE
75119 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
75120 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
75121 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
75122 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
75123 ELSEIF(MLIST.EQ.1) THEN
75124 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
75125 ELSEIF(MLIST.LE.3) THEN
75126 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
75127 ELSE
75128 WRITE(MSTU(11),7000) PS(6)
75129 ENDIF
75130
75131C...Simple listing of HEPEVT entries (mainly for test purposes).
75132 ELSEIF(MLIST.EQ.5) THEN
75133 WRITE(MSTU(11),7100)
75134 DO 140 I=1,NHEP
75135 IF(ISTHEP(I).EQ.0) GOTO 140
75136 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
75137 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
75138 140 CONTINUE
75139
75140
75141C...Simple listing of user-process entries (mainly for test purposes).
75142 ELSEIF(MLIST.EQ.7) THEN
75143 WRITE(MSTU(11),7300)
75144 DO 150 I=1,NUP
75145 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
75146 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
75147 150 CONTINUE
75148
75149C...Give simple list of KF codes defined in program.
75150 ELSEIF(MLIST.EQ.11) THEN
75151 WRITE(MSTU(11),7500)
75152 DO 160 KF=1,80
75153 CALL PYNAME(KF,CHAP)
75154 CALL PYNAME(-KF,CHAN)
75155 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
75156 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
75157 160 CONTINUE
75158 DO 190 KFLS=1,3,2
75159 DO 180 KFLA=1,5
75160 DO 170 KFLB=1,KFLA-(3-KFLS)/2
75161 KF=1000*KFLA+100*KFLB+KFLS
75162 CALL PYNAME(KF,CHAP)
75163 CALL PYNAME(-KF,CHAN)
75164 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
75165 170 CONTINUE
75166 180 CONTINUE
75167 190 CONTINUE
75168 DO 220 KMUL=0,5
75169 KFLS=3
75170 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
75171 IF(KMUL.EQ.5) KFLS=5
75172 KFLR=0
75173 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
75174 IF(KMUL.EQ.4) KFLR=2
75175 DO 210 KFLB=1,5
75176 DO 200 KFLC=1,KFLB-1
75177 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
75178 CALL PYNAME(KF,CHAP)
75179 CALL PYNAME(-KF,CHAN)
75180 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
75181 IF(KF.EQ.311) THEN
75182 KFK=130
75183 CALL PYNAME(KFK,CHAP)
75184 WRITE(MSTU(11),7600) KFK,CHAP
75185 KFK=310
75186 CALL PYNAME(KFK,CHAP)
75187 WRITE(MSTU(11),7600) KFK,CHAP
75188 ENDIF
75189 200 CONTINUE
75190 KF=10000*KFLR+110*KFLB+KFLS
75191 CALL PYNAME(KF,CHAP)
75192 WRITE(MSTU(11),7600) KF,CHAP
75193 210 CONTINUE
75194 220 CONTINUE
75195 KF=100443
75196 CALL PYNAME(KF,CHAP)
75197 WRITE(MSTU(11),7600) KF,CHAP
75198 KF=100553
75199 CALL PYNAME(KF,CHAP)
75200 WRITE(MSTU(11),7600) KF,CHAP
75201 DO 260 KFLSP=1,3
75202 KFLS=2+2*(KFLSP/3)
75203 DO 250 KFLA=1,5
75204 DO 240 KFLB=1,KFLA
75205 DO 230 KFLC=1,KFLB
75206 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
75207 & GOTO 230
75208 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
75209 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
75210 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
75211 CALL PYNAME(KF,CHAP)
75212 CALL PYNAME(-KF,CHAN)
75213 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
75214 230 CONTINUE
75215 240 CONTINUE
75216 250 CONTINUE
75217 260 CONTINUE
75218 DO 270 KC=1,500
75219 KF=KCHG(KC,4)
75220 IF(KF.LT.1000000) GOTO 270
75221 CALL PYNAME(KF,CHAP)
75222 CALL PYNAME(-KF,CHAN)
75223 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
75224 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
75225 270 CONTINUE
75226
75227C...List parton/particle data table. Check whether to be listed.
75228 ELSEIF(MLIST.EQ.12) THEN
75229 WRITE(MSTU(11),7700)
75230 DO 300 KC=1,MSTU(6)
75231 KF=KCHG(KC,4)
75232 IF(KF.EQ.0) GOTO 300
75233 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
75234 & GOTO 300
75235
75236C...Find particle name and mass. Print information.
75237 CALL PYNAME(KF,CHAP)
75238 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
75239 CALL PYNAME(-KF,CHAN)
75240 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
75241 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
75242
75243C...Particle decay: channel number, branching ratios, matrix element,
75244C...decay products.
75245 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
75246 DO 280 J=1,5
75247 CALL PYNAME(KFDP(IDC,J),CHAD(J))
75248 280 CONTINUE
75249 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
75250 & (CHAD(J),J=1,5)
75251 290 CONTINUE
75252 300 CONTINUE
75253
75254C...List parameter value table.
75255 ELSEIF(MLIST.EQ.13) THEN
75256 WRITE(MSTU(11),8000)
75257 DO 310 I=1,200
75258 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
75259 310 CONTINUE
75260 ENDIF
75261
75262C...Format statements for output on unit MSTU(11) (by default 6).
75263 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
75264 &5X,'KF orig p_x p_y p_z E m'/)
75265 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
75266 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
75267 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
75268 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
75269 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
75270 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
75271 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
75272 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
75273 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
75274 & ,' C tag AC tag'/)
75275 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
75276 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
75277 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
75278 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
75279 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
75280 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
75281 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
75282 6200 FORMAT(66X,5(1X,F12.3))
75283 6300 FORMAT(1X,78('='))
75284 6400 FORMAT(1X,130('='))
75285 6500 FORMAT(1X,65('='))
75286 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
75287 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
75288 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
75289 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
75290 &5F13.5)
75291 7000 FORMAT(19X,'sum charge:',F6.2)
75292 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
75293 &//' I IST ID Mothers Daughters p_x p_y p_z',
75294 &' E m')
75295 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
75296 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
75297 &//' I IST ID Mothers Colours p_x p_y p_z',
75298 &' E m')
75299 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
75300 7500 FORMAT(///20X,'List of KF codes in program'/)
75301 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
75302 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
75303 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
75304 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
75305 &1X,'ME',3X,'Br.rat.',4X,'decay products')
75306 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
75307 &1X,1P,E13.5,3X,I2)
75308 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
75309 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
75310 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
75311 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
75312
75313 RETURN
75314 END
75315
75316C*********************************************************************
75317
75318C...PYLOGO
75319C...Writes a logo for the program.
75320
75321 SUBROUTINE PYLOGO
75322
75323C...Double precision and integer declarations.
75324 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75325 IMPLICIT INTEGER(I-N)
75326 INTEGER PYK,PYCHGE,PYCOMP
75327C...Parameter for length of information block.
75328 PARAMETER (IREFER=19)
75329C...Commonblocks.
75330 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75331 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75332 SAVE /PYDAT1/,/PYPARS/
75333C...Local arrays and character variables.
75334 INTEGER IDATI(6)
75335 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
75336 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
75337
75338C...Data on months, logo, titles, and references.
75339 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
75340 &'Oct','Nov','Dec'/
75341 DATA (LOGO(J),J=1,19)/
75342 &' *......* ',
75343 &' *:::!!:::::::::::* ',
75344 &' *::::::!!::::::::::::::* ',
75345 &' *::::::::!!::::::::::::::::* ',
75346 &' *:::::::::!!:::::::::::::::::* ',
75347 &' *:::::::::!!:::::::::::::::::* ',
75348 &' *::::::::!!::::::::::::::::*! ',
75349 &' *::::::!!::::::::::::::* !! ',
75350 &' !! *:::!!:::::::::::* !! ',
75351 &' !! !* -><- * !! ',
75352 &' !! !! !! ',
75353 &' !! !! !! ',
75354 &' !! !! ',
75355 &' !! lh !! ',
75356 &' !! !! ',
75357 &' !! hh !! ',
75358 &' !! ll !! ',
75359 &' !! !! ',
75360 &' !! '/
75361 DATA (LOGO(J),J=20,38)/
75362 &'Welcome to the Lund Monte Carlo!',
75363 &' ',
75364 &'PPP Y Y TTTTT H H III A ',
75365 &'P P Y Y T H H I A A ',
75366 &'PPP Y T HHHHH I AAAAA',
75367 &'P Y T H H I A A',
75368 &'P Y T H H III A A',
75369 &' ',
75370 &'This is PYTHIA version x.xxx ',
75371 &'Last date of change: xx xxx 201x',
75372 &' ',
75373 &'Now is xx xxx 201x at xx:xx:xx ',
75374 &' ',
75375 &'Disclaimer: this program comes ',
75376 &'without any guarantees. Beware ',
75377 &'of errors and use common sense ',
75378 &'when interpreting results. ',
75379 &' ',
75380 &'Copyright T. Sjostrand (2011) '/
75381 DATA (REFER(J),J=1,14)/
75382 &'An archive of program versions and d',
75383 &'ocumentation is found on the web: ',
75384 &'http://www.thep.lu.se/~torbjorn/Pyth',
75385 &'ia.html ',
75386 &' ',
75387 &' ',
75388 &'When you cite this program, the offi',
75389 &'cial reference is to the 6.4 manual:',
75390 &'T. Sjostrand, S. Mrenna and P. Skand',
75391 &'s, JHEP05 (2006) 026 ',
75392 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
75393 &'-T) [hep-ph/0603175]. ',
75394 &' ',
75395 &' '/
75396 DATA (REFER(J),J=15,32)/
75397 &'Also remember that the program, to a',
75398 &' large extent, represents original ',
75399 &'physics research. Other publications',
75400 &' of special relevance to your ',
75401 &'studies may therefore deserve separa',
75402 &'te mention. ',
75403 &' ',
75404 &' ',
75405 &'Main author: Torbjorn Sjostrand; Dep',
75406 &'artment of Theoretical Physics, ',
75407 &' Lund University, Solvegatan 14A, S',
75408 &'-223 62 Lund, Sweden; ',
75409 &' phone: + 46 - 46 - 222 48 16; e-ma',
75410 &'il: torbjorn@thep.lu.se ',
75411 &'Author: Stephen Mrenna; Computing Di',
75412 &'vision, GDS Group, ',
75413 &' Fermi National Accelerator Laborat',
75414 &'ory, MS 234, Batavia, IL 60510, USA;'/
75415 DATA (REFER(J),J=33,2*IREFER)/
75416 &' phone: + 1 - 630 - 840 - 2556; e-m',
75417 &'ail: mrenna@fnal.gov ',
75418 &'Author: Peter Skands; CERN/PH-TH, CH',
75419 &'-1211 Geneva, Switzerland ',
75420 &' phone: + 41 - 22 - 767 24 47; e-ma',
75421 &'il: peter.skands@cern.ch '/
75422
75423C...Check that PYDATA linked (check we are in the year 20xx)
75424 IF(MSTP(183)/100.NE.20) THEN
75425 WRITE(*,'(1X,A)')
75426 & 'Error: PYDATA has not been linked.'
75427 WRITE(*,'(1X,A)') 'Execution stopped!'
75428 CALL PYSTOP(8)
75429
75430C...Write current version number and current date+time.
75431 ELSE
75432 WRITE(VERS,'(I1)') MSTP(181)
75433 LOGO(28)(24:24)=VERS
75434 WRITE(SUBV,'(I3)') MSTP(182)
75435 LOGO(28)(26:28)=SUBV
75436 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
75437 WRITE(DATE,'(I2)') MSTP(185)
75438 LOGO(29)(22:23)=DATE
75439 LOGO(29)(25:27)=MONTH(MSTP(184))
75440 WRITE(YEAR,'(I4)') MSTP(183)
75441 LOGO(29)(29:32)=YEAR
75442 CALL PYTIME(IDATI)
75443 IF(IDATI(1).LE.0) THEN
75444 LOGO(31)=' '
75445 ELSE
75446 WRITE(DATE,'(I2)') IDATI(3)
75447 LOGO(31)(8:9)=DATE
75448 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
75449 WRITE(YEAR,'(I4)') IDATI(1)
75450 LOGO(31)(15:18)=YEAR
75451 WRITE(HOUR,'(I2)') IDATI(4)
75452 LOGO(31)(23:24)=HOUR
75453 WRITE(MINU,'(I2)') IDATI(5)
75454 LOGO(31)(26:27)=MINU
75455 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
75456 WRITE(SECO,'(I2)') IDATI(6)
75457 LOGO(31)(29:30)=SECO
75458 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
75459 ENDIF
75460 ENDIF
75461
75462C...Loop over lines in header. Define page feed and side borders.
75463 DO 100 ILIN=1,29+IREFER
75464 LINE=' '
75465 IF(ILIN.EQ.1) THEN
75466 LINE(1:1)='1'
75467 ELSE
75468 LINE(2:3)='**'
75469 LINE(78:79)='**'
75470 ENDIF
75471
75472C...Separator lines and logos.
75473 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
75474 LINE(4:77)='***********************************************'//
75475 & '***************************'
75476 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
75477 LINE(6:37)=LOGO(ILIN-5)
75478 LINE(44:75)=LOGO(ILIN+14)
75479 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
75480 LINE(5:40)=REFER(2*ILIN-51)
75481 LINE(41:76)=REFER(2*ILIN-50)
75482 ENDIF
75483
75484C...Write lines to appropriate unit.
75485 WRITE(MSTU(11),'(A79)') LINE
75486 100 CONTINUE
75487
75488 RETURN
75489 END
75490
75491C*********************************************************************
75492
75493C...PYUPDA
75494C...Facilitates the updating of particle and decay data
75495C...by allowing it to be done in an external file.
75496
75497 SUBROUTINE PYUPDA(MUPDA,LFN)
75498
75499C...Double precision and integer declarations.
75500 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75501 IMPLICIT INTEGER(I-N)
75502 INTEGER PYK,PYCHGE,PYCOMP
75503C...Commonblocks.
75504 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75505 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75506 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
75507 COMMON/PYDAT4/CHAF(500,2)
75508 CHARACTER CHAF*16
75509 COMMON/PYINT4/MWID(500),WIDS(500,5)
75510 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
75511C...Local arrays, character variables and data.
75512 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
75513 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
75514 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
75515 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
75516 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
75517 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
75518 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
75519
75520C...Write header if not yet done.
75521 IF(MSTU(12).NE.12345) CALL PYLIST(0)
75522
75523C...Write information on file for editing.
75524 IF(MUPDA.EQ.1) THEN
75525 DO 110 KC=1,500
75526 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
75527 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
75528 & MWID(KC),MDCY(KC,1)
75529 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
75530 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
75531 & (KFDP(IDC,J),J=1,5)
75532 100 CONTINUE
75533 110 CONTINUE
75534
75535C...Read complete set of information from edited file or
75536C...read partial set of new or updated information from edited file.
75537 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
75538
75539C...Reset counters.
75540 KCC=100
75541 NDC=0
75542 CHKF=' '
75543 IF(MUPDA.EQ.2) THEN
75544 DO 120 I=1,MSTU(6)
75545 KCHG(I,4)=0
75546 120 CONTINUE
75547 ELSE
75548 DO 130 KC=1,MSTU(6)
75549 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
75550 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
75551 130 CONTINUE
75552 ENDIF
75553
75554C...Begin of loop: read new line; unknown whether particle or
75555C...decay data.
75556 140 READ(LFN,5200,END=190) CHINL
75557
75558C...Identify particle code and whether already defined (for MUPDA=3).
75559 IF(CHINL(2:10).NE.' ') THEN
75560 CHKF=CHINL(2:10)
75561 READ(CHKF,5300) KF
75562 IF(MUPDA.EQ.2) THEN
75563 IF(KF.LE.100) THEN
75564 KC=KF
75565 ELSE
75566 KCC=KCC+1
75567 KC=KCC
75568 ENDIF
75569 ELSE
75570 KCREP=0
75571 IF(KF.LE.100) THEN
75572 KCREP=KF
75573 ELSE
75574 DO 150 KCR=101,KCC
75575 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
75576 150 CONTINUE
75577 ENDIF
75578C...Remove duplicate old decay data.
75579 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
75580 IDCREP=MDCY(KCREP,2)
75581 NDCREP=MDCY(KCREP,3)
75582 DO 160 I=1,KCC
75583 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
75584 160 CONTINUE
75585 DO 180 I=IDCREP,NDC-NDCREP
75586 MDME(I,1)=MDME(I+NDCREP,1)
75587 MDME(I,2)=MDME(I+NDCREP,2)
75588 BRAT(I)=BRAT(I+NDCREP)
75589 DO 170 J=1,5
75590 KFDP(I,J)=KFDP(I+NDCREP,J)
75591 170 CONTINUE
75592 180 CONTINUE
75593 NDC=NDC-NDCREP
75594 KC=KCREP
75595 ELSEIF(KCREP.NE.0) THEN
75596 KC=KCREP
75597 ELSE
75598 KCC=KCC+1
75599 KC=KCC
75600 ENDIF
75601 ENDIF
75602
75603C...Study line with particle data.
75604 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
75605 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
75606 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
75607 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
75608 & MWID(KC),MDCY(KC,1)
75609 MDCY(KC,2)=0
75610 MDCY(KC,3)=0
75611
75612C...Study line with decay data.
75613 ELSE
75614 NDC=NDC+1
75615 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
75616 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
75617 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
75618 MDCY(KC,3)=MDCY(KC,3)+1
75619 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
75620 & (KFDP(NDC,J),J=1,5)
75621 ENDIF
75622
75623C...End of loop; ensure that PYCOMP tables are updated.
75624 GOTO 140
75625 190 CONTINUE
75626 MSTU(20)=0
75627
75628C...Perform possible tests that new information is consistent.
75629 DO 220 KC=1,MSTU(6)
75630 KF=KCHG(KC,4)
75631 IF(KF.EQ.0) GOTO 220
75632 WRITE(CHKF,5300) KF
75633 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
75634 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
75635 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
75636 BRSUM=0D0
75637 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
75638 IF(MDME(IDC,2).GT.80) GOTO 210
75639 KQ=KCHG(KC,1)
75640 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
75641 MERR=0
75642 DO 200 J=1,5
75643 KP=KFDP(IDC,J)
75644 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
75645 IF(KP.EQ.81) KQ=0
75646 ELSEIF(PYCOMP(KP).EQ.0) THEN
75647 MERR=3
75648 ELSE
75649 KQ=KQ-PYCHGE(KP)
75650 KPC=PYCOMP(KP)
75651 PMS=PMS-PMAS(KPC,1)
75652 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
75653 & PMAS(KPC,3))
75654 ENDIF
75655 200 CONTINUE
75656 IF(KQ.NE.0) MERR=MAX(2,MERR)
75657 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
75658 & MERR=MAX(1,MERR)
75659 IF(MERR.EQ.3) CALL PYERRM(17,
75660 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
75661 IF(MERR.EQ.2) CALL PYERRM(17,
75662 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
75663 IF(MERR.EQ.1) CALL PYERRM(7,
75664 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
75665 BRSUM=BRSUM+BRAT(IDC)
75666 210 CONTINUE
75667 WRITE(CHTMP,5500) BRSUM
75668 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
75669 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
75670 & CHTMP(9:16)//' for KF ='//CHKF)
75671 220 CONTINUE
75672
75673C...Write DATA statements for inclusion in program.
75674 ELSEIF(MUPDA.EQ.4) THEN
75675
75676C...Find out how many codes and decay channels are actually used.
75677 KCC=0
75678 NDC=0
75679 DO 230 I=1,MSTU(6)
75680 IF(KCHG(I,4).NE.0) THEN
75681 KCC=I
75682 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
75683 ENDIF
75684 230 CONTINUE
75685
75686C...Initialize writing of DATA statements for inclusion in program.
75687 DO 300 IVAR=1,22
75688 NDIM=MSTU(6)
75689 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
75690 NLIN=1
75691 CHLIN=' '
75692 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
75693 LLIN=35
75694 CHOLD='START'
75695
75696C...Loop through variables for conversion to characters.
75697 DO 280 IDIM=1,NDIM
75698 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
75699 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
75700 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
75701 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
75702 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
75703 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
75704 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
75705 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
75706 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
75707 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
75708 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
75709 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
75710 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
75711 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
75712 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
75713 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
75714 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
75715 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
75716 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
75717 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
75718 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
75719 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
75720
75721C...Replace variables beyond what is properly defined.
75722 IF(IVAR.LE.4) THEN
75723 IF(IDIM.GT.KCC) CHTMP=' 0'
75724 ELSEIF(IVAR.LE.8) THEN
75725 IF(IDIM.GT.KCC) CHTMP=' 0.0'
75726 ELSEIF(IVAR.LE.11) THEN
75727 IF(IDIM.GT.KCC) CHTMP=' 0'
75728 ELSEIF(IVAR.LE.13) THEN
75729 IF(IDIM.GT.NDC) CHTMP=' 0'
75730 ELSEIF(IVAR.LE.14) THEN
75731 IF(IDIM.GT.NDC) CHTMP=' 0.0'
75732 ELSEIF(IVAR.LE.19) THEN
75733 IF(IDIM.GT.NDC) CHTMP=' 0'
75734 ELSEIF(IVAR.LE.21) THEN
75735 IF(IDIM.GT.KCC) CHTMP=' '
75736 ELSE
75737 IF(IDIM.GT.KCC) CHTMP=' 0'
75738 ENDIF
75739
75740C...Length of variable, trailing decimal zeros, quotation marks.
75741 LLOW=1
75742 LHIG=1
75743 DO 240 LL=1,16
75744 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
75745 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
75746 240 CONTINUE
75747 CHNEW=CHTMP(LLOW:LHIG)//' '
75748 LNEW=1+LHIG-LLOW
75749 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
75750 LNEW=LNEW+1
75751 250 LNEW=LNEW-1
75752 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
75753 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
75754 IF(LNEW.EQ.0) THEN
75755 CHNEW(1:3)='0D0'
75756 LNEW=3
75757 ELSE
75758 CHNEW(LNEW+1:LNEW+2)='D0'
75759 LNEW=LNEW+2
75760 ENDIF
75761 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
75762 DO 260 LL=LNEW,1,-1
75763 IF(CHNEW(LL:LL).EQ.'''') THEN
75764 CHTMP=CHNEW
75765 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
75766 LNEW=LNEW+1
75767 ENDIF
75768 260 CONTINUE
75769 LNEW=MIN(14,LNEW)
75770 CHTMP=CHNEW
75771 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
75772 LNEW=LNEW+2
75773 ENDIF
75774
75775C...Form composite character string, often including repetition counter.
75776 IF(CHNEW.NE.CHOLD) THEN
75777 NRPT=1
75778 CHOLD=CHNEW
75779 CHCOM=CHNEW
75780 LCOM=LNEW
75781 ELSE
75782 LRPT=LNEW+1
75783 IF(NRPT.GE.2) LRPT=LNEW+3
75784 IF(NRPT.GE.10) LRPT=LNEW+4
75785 IF(NRPT.GE.100) LRPT=LNEW+5
75786 IF(NRPT.GE.1000) LRPT=LNEW+6
75787 LLIN=LLIN-LRPT
75788 NRPT=NRPT+1
75789 WRITE(CHTMP,5400) NRPT
75790 LRPT=1
75791 IF(NRPT.GE.10) LRPT=2
75792 IF(NRPT.GE.100) LRPT=3
75793 IF(NRPT.GE.1000) LRPT=4
75794 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
75795 LCOM=LRPT+1+LNEW
75796 ENDIF
75797
75798C...Add characters to end of line, to new line (after storing old line),
75799C...or to new block of lines (after writing old block).
75800 IF(LLIN+LCOM.LE.70) THEN
75801 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
75802 LLIN=LLIN+LCOM+1
75803 ELSEIF(NLIN.LE.19) THEN
75804 CHLIN(LLIN+1:72)=' '
75805 CHBLK(NLIN)=CHLIN
75806 NLIN=NLIN+1
75807 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
75808 LLIN=6+LCOM+1
75809 ELSE
75810 CHLIN(LLIN:72)='/'//' '
75811 CHBLK(NLIN)=CHLIN
75812 WRITE(CHTMP,5400) IDIM-NRPT
75813 CHBLK(1)(30:33)=CHTMP(13:16)
75814 DO 270 ILIN=1,NLIN
75815 WRITE(LFN,5700) CHBLK(ILIN)
75816 270 CONTINUE
75817 NLIN=1
75818 CHLIN=' '
75819 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
75820 & ',I= , )/'//CHCOM(1:LCOM)//','
75821 WRITE(CHTMP,5400) IDIM-NRPT+1
75822 CHLIN(25:28)=CHTMP(13:16)
75823 LLIN=35+LCOM+1
75824 ENDIF
75825 280 CONTINUE
75826
75827C...Write final block of lines.
75828 CHLIN(LLIN:72)='/'//' '
75829 CHBLK(NLIN)=CHLIN
75830 WRITE(CHTMP,5400) NDIM
75831 CHBLK(1)(30:33)=CHTMP(13:16)
75832 DO 290 ILIN=1,NLIN
75833 WRITE(LFN,5700) CHBLK(ILIN)
75834 290 CONTINUE
75835 300 CONTINUE
75836 ENDIF
75837
75838C...Formats for reading and writing particle data.
75839 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
75840 5100 FORMAT(10X,2I5,F12.6,5I10)
75841 5200 FORMAT(A120)
75842 5300 FORMAT(I9)
75843 5400 FORMAT(I16)
75844 5500 FORMAT(F16.5)
75845 5600 FORMAT(F16.6)
75846 5700 FORMAT(A72)
75847
75848 RETURN
75849 END
75850
75851C*********************************************************************
75852
75853C...PYK
75854C...Provides various integer-valued event related data.
75855
75856 FUNCTION PYK(I,J)
75857
75858C...Double precision and integer declarations.
75859 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75860 IMPLICIT INTEGER(I-N)
75861 INTEGER PYK,PYCHGE,PYCOMP
75862C...Commonblocks.
75863 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75864 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75865 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75866 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75867
75868C...Default value. For I=0 number of entries, number of stable entries
75869C...or 3 times total charge.
75870 PYK=0
75871 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
75872 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
75873 PYK=N
75874 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
75875 DO 100 I1=1,N
75876 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
75877 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
75878 & PYCHGE(K(I1,2))
75879 100 CONTINUE
75880 ELSEIF(I.EQ.0) THEN
75881
75882C...For I > 0 direct readout of K matrix or charge.
75883 ELSEIF(J.LE.5) THEN
75884 PYK=K(I,J)
75885 ELSEIF(J.EQ.6) THEN
75886 PYK=PYCHGE(K(I,2))
75887
75888C...Status (existing/fragmented/decayed), parton/hadron separation.
75889 ELSEIF(J.LE.8) THEN
75890 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
75891 IF(J.EQ.8) PYK=PYK*K(I,2)
75892 ELSEIF(J.LE.12) THEN
75893 KFA=IABS(K(I,2))
75894 KC=PYCOMP(KFA)
75895 KQ=0
75896 IF(KC.NE.0) KQ=KCHG(KC,2)
75897 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
75898 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
75899 IF(J.EQ.11) PYK=KC
75900 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
75901
75902C...Heaviest flavour in hadron/diquark.
75903 ELSEIF(J.EQ.13) THEN
75904 KFA=IABS(K(I,2))
75905 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
75906 IF(KFA.LT.10) PYK=KFA
75907 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
75908 PYK=PYK*ISIGN(1,K(I,2))
75909
75910C...Particle history: generation, ancestor, rank.
75911 ELSEIF(J.LE.15) THEN
75912 I2=I
75913 I1=I
75914 110 PYK=PYK+1
75915 I2=I1
75916 I1=K(I1,3)
75917 IF(I1.GT.0) THEN
75918 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
75919 ENDIF
75920 IF(J.EQ.15) PYK=I2
75921 ELSEIF(J.EQ.16) THEN
75922 KFA=IABS(K(I,2))
75923 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
75924 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
75925 I1=I
75926 120 I2=I1
75927 I1=K(I1,3)
75928 IF(I1.GT.0) THEN
75929 KFAM=IABS(K(I1,2))
75930 ILP=1
75931 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
75932 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
75933 & ILP=0
75934 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
75935 IF(ILP.EQ.1) GOTO 120
75936 ENDIF
75937 IF(K(I1,1).EQ.12) THEN
75938 DO 130 I3=I1+1,I2
75939 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
75940 & .AND.K(I3,2).NE.93) PYK=PYK+1
75941 130 CONTINUE
75942 ELSE
75943 I3=I2
75944 140 PYK=PYK+1
75945 I3=I3+1
75946 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
75947 ENDIF
75948 ENDIF
75949
75950C...Particle coming from collapsing jet system or not.
75951 ELSEIF(J.EQ.17) THEN
75952 I1=I
75953 150 PYK=PYK+1
75954 I3=I1
75955 I1=K(I1,3)
75956 I0=MAX(1,I1)
75957 KC=PYCOMP(K(I0,2))
75958 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
75959 IF(PYK.EQ.1) PYK=-1
75960 IF(PYK.GT.1) PYK=0
75961 RETURN
75962 ENDIF
75963 IF(KCHG(KC,2).EQ.0) GOTO 150
75964 IF(K(I1,1).NE.12) PYK=0
75965 IF(K(I1,1).NE.12) RETURN
75966 I2=I1
75967 160 I2=I2+1
75968 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
75969 K3M=K(I3-1,3)
75970 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
75971 K3P=K(I3+1,3)
75972 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
75973
75974C...Number of decay products. Colour flow.
75975 ELSEIF(J.EQ.18) THEN
75976 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
75977 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
75978 ELSEIF(J.LE.22) THEN
75979 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
75980 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
75981 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
75982 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
75983 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
75984 ELSE
75985 ENDIF
75986
75987 RETURN
75988 END
75989
75990C*********************************************************************
75991
75992C...PYP
75993C...Provides various real-valued event related data.
75994
75995 FUNCTION PYP(I,J)
75996
75997C...Double precision and integer declarations.
75998 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75999 IMPLICIT INTEGER(I-N)
76000 INTEGER PYK,PYCHGE,PYCOMP
76001C...Commonblocks.
76002 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76003 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76004 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76005 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76006C...Local array.
76007 DIMENSION PSUM(4)
76008
76009C...Set default value. For I = 0 sum of momenta or charges,
76010C...or invariant mass of system.
76011 PYP=0D0
76012 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
76013 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
76014 DO 100 I1=1,N
76015 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
76016 100 CONTINUE
76017 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
76018 DO 120 J1=1,4
76019 PSUM(J1)=0D0
76020 DO 110 I1=1,N
76021 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
76022 & P(I1,J1)
76023 110 CONTINUE
76024 120 CONTINUE
76025 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
76026 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
76027 DO 130 I1=1,N
76028 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
76029 130 CONTINUE
76030 ELSEIF(I.EQ.0) THEN
76031
76032C...Direct readout of P matrix.
76033 ELSEIF(J.LE.5) THEN
76034 PYP=P(I,J)
76035
76036C...Charge, total momentum, transverse momentum, transverse mass.
76037 ELSEIF(J.LE.12) THEN
76038 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
76039 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
76040 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
76041 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
76042 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
76043
76044C...Theta and phi angle in radians or degrees.
76045 ELSEIF(J.LE.16) THEN
76046 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
76047 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
76048 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
76049
76050C...True rapidity, rapidity with pion mass, pseudorapidity.
76051 ELSEIF(J.LE.19) THEN
76052 PMR=0D0
76053 IF(J.EQ.17) PMR=P(I,5)
76054 IF(J.EQ.18) PMR=PYMASS(211)
76055 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
76056 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
76057 & 1D20)),P(I,3))
76058
76059C...Energy and momentum fractions (only to be used in CM frame).
76060 ELSEIF(J.LE.25) THEN
76061 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
76062 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
76063 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
76064 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
76065 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
76066 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
76067 ENDIF
76068
76069 RETURN
76070 END
76071
76072C*********************************************************************
76073
76074C...PYSPHE
76075C...Performs sphericity tensor analysis to give sphericity,
76076C...aplanarity and the related event axes.
76077
76078 SUBROUTINE PYSPHE(SPH,APL)
76079
76080C...Double precision and integer declarations.
76081 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76082 IMPLICIT INTEGER(I-N)
76083 INTEGER PYK,PYCHGE,PYCOMP
76084C...Parameter statement to help give large particle numbers.
76085 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
76086 &KEXCIT=4000000,KDIMEN=5000000)
76087C...Commonblocks.
76088 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76089 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76090 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76091 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76092C...Local arrays.
76093 DIMENSION SM(3,3),SV(3,3)
76094
76095C...Calculate matrix to be diagonalized.
76096 NP=0
76097 DO 110 J1=1,3
76098 DO 100 J2=J1,3
76099 SM(J1,J2)=0D0
76100 100 CONTINUE
76101 110 CONTINUE
76102 PS=0D0
76103 DO 140 I=1,N
76104 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
76105 IF(MSTU(41).GE.2) THEN
76106 KC=PYCOMP(K(I,2))
76107 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76108 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76109 & K(I,2).EQ.KSUSY1+39) GOTO 140
76110 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
76111 & GOTO 140
76112 ENDIF
76113 NP=NP+1
76114 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
76115 PWT=1D0
76116 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
76117 & MAX(1D-10,PA)**(PARU(41)-2D0)
76118 DO 130 J1=1,3
76119 DO 120 J2=J1,3
76120 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
76121 120 CONTINUE
76122 130 CONTINUE
76123 PS=PS+PWT*PA**2
76124 140 CONTINUE
76125
76126C...Very low multiplicities (0 or 1) not considered.
76127 IF(NP.LE.1) THEN
76128 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
76129 SPH=-1D0
76130 APL=-1D0
76131 RETURN
76132 ENDIF
76133 DO 160 J1=1,3
76134 DO 150 J2=J1,3
76135 SM(J1,J2)=SM(J1,J2)/PS
76136 150 CONTINUE
76137 160 CONTINUE
76138
76139C...Find eigenvalues to matrix (third degree equation).
76140 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
76141 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
76142 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
76143 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
76144 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
76145 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
76146 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
76147 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
76148 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
76149 IF(P(N+2,4).LT.1D-5) THEN
76150 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
76151 SPH=-1D0
76152 APL=-1D0
76153 RETURN
76154 ENDIF
76155
76156C...Find first and last eigenvector by solving equation system.
76157 DO 240 I=1,3,2
76158 DO 180 J1=1,3
76159 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
76160 DO 170 J2=J1+1,3
76161 SV(J1,J2)=SM(J1,J2)
76162 SV(J2,J1)=SM(J1,J2)
76163 170 CONTINUE
76164 180 CONTINUE
76165 SMAX=0D0
76166 DO 200 J1=1,3
76167 DO 190 J2=1,3
76168 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
76169 JA=J1
76170 JB=J2
76171 SMAX=ABS(SV(J1,J2))
76172 190 CONTINUE
76173 200 CONTINUE
76174 SMAX=0D0
76175 DO 220 J3=JA+1,JA+2
76176 J1=J3-3*((J3-1)/3)
76177 RL=SV(J1,JB)/SV(JA,JB)
76178 DO 210 J2=1,3
76179 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
76180 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
76181 JC=J1
76182 SMAX=ABS(SV(J1,J2))
76183 210 CONTINUE
76184 220 CONTINUE
76185 JB1=JB+1-3*(JB/3)
76186 JB2=JB+2-3*((JB+1)/3)
76187 P(N+I,JB1)=-SV(JC,JB2)
76188 P(N+I,JB2)=SV(JC,JB1)
76189 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
76190 & SV(JA,JB)
76191 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
76192 SGN=(-1D0)**INT(PYR(0)+0.5D0)
76193 DO 230 J=1,3
76194 P(N+I,J)=SGN*P(N+I,J)/PA
76195 230 CONTINUE
76196 240 CONTINUE
76197
76198C...Middle axis orthogonal to other two. Fill other codes.
76199 SGN=(-1D0)**INT(PYR(0)+0.5D0)
76200 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
76201 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
76202 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
76203 DO 260 I=1,3
76204 K(N+I,1)=31
76205 K(N+I,2)=95
76206 K(N+I,3)=I
76207 K(N+I,4)=0
76208 K(N+I,5)=0
76209 P(N+I,5)=0D0
76210 DO 250 J=1,5
76211 V(I,J)=0D0
76212 250 CONTINUE
76213 260 CONTINUE
76214
76215C...Calculate sphericity and aplanarity. Select storing option.
76216 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
76217 APL=1.5D0*P(N+3,4)
76218 MSTU(61)=N+1
76219 MSTU(62)=NP
76220 IF(MSTU(43).LE.1) MSTU(3)=3
76221 IF(MSTU(43).GE.2) N=N+3
76222
76223 RETURN
76224 END
76225
76226C*********************************************************************
76227
76228C...PYTHRU
76229C...Performs thrust analysis to give thrust, oblateness
76230C...and the related event axes.
76231
76232 SUBROUTINE PYTHRU(THR,OBL)
76233
76234C...Double precision and integer declarations.
76235 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76236 IMPLICIT INTEGER(I-N)
76237 INTEGER PYK,PYCHGE,PYCOMP
76238C...Parameter statement to help give large particle numbers.
76239 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
76240 &KEXCIT=4000000,KDIMEN=5000000)
76241C...Commonblocks.
76242 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76243 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76244 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76245 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76246C...Local arrays.
76247 DIMENSION TDI(3),TPR(3)
76248
76249C...Take copy of particles that are to be considered in thrust analysis.
76250 NP=0
76251 PS=0D0
76252 DO 100 I=1,N
76253 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
76254 IF(MSTU(41).GE.2) THEN
76255 KC=PYCOMP(K(I,2))
76256 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76257 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76258 & K(I,2).EQ.KSUSY1+39) GOTO 100
76259 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
76260 & GOTO 100
76261 ENDIF
76262 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
76263 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
76264 THR=-2D0
76265 OBL=-2D0
76266 RETURN
76267 ENDIF
76268 NP=NP+1
76269 K(N+NP,1)=23
76270 P(N+NP,1)=P(I,1)
76271 P(N+NP,2)=P(I,2)
76272 P(N+NP,3)=P(I,3)
76273 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
76274 P(N+NP,5)=1D0
76275 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
76276 & P(N+NP,4)**(PARU(42)-1D0)
76277 PS=PS+P(N+NP,4)*P(N+NP,5)
76278 100 CONTINUE
76279
76280C...Very low multiplicities (0 or 1) not considered.
76281 IF(NP.LE.1) THEN
76282 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
76283 THR=-1D0
76284 OBL=-1D0
76285 RETURN
76286 ENDIF
76287
76288C...Loop over thrust and major. T axis along z direction in latter case.
76289 DO 320 ILD=1,2
76290 IF(ILD.EQ.2) THEN
76291 K(N+NP+1,1)=31
76292 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
76293 MSTU(33)=1
76294 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
76295 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
76296 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
76297 ENDIF
76298
76299C...Find and order particles with highest p (pT for major).
76300 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
76301 P(ILF,4)=0D0
76302 110 CONTINUE
76303 DO 160 I=N+1,N+NP
76304 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
76305 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
76306 IF(P(I,4).LE.P(ILF,4)) GOTO 140
76307 DO 120 J=1,5
76308 P(ILF+1,J)=P(ILF,J)
76309 120 CONTINUE
76310 130 CONTINUE
76311 ILF=N+NP+3
76312 140 DO 150 J=1,5
76313 P(ILF+1,J)=P(I,J)
76314 150 CONTINUE
76315 160 CONTINUE
76316
76317C...Find and order initial axes with highest thrust (major).
76318 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
76319 P(ILG,4)=0D0
76320 170 CONTINUE
76321 NC=2**(MIN(MSTU(44),NP)-1)
76322 DO 250 ILC=1,NC
76323 DO 180 J=1,3
76324 TDI(J)=0D0
76325 180 CONTINUE
76326 DO 200 ILF=1,MIN(MSTU(44),NP)
76327 SGN=P(N+NP+ILF+3,5)
76328 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
76329 DO 190 J=1,4-ILD
76330 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
76331 190 CONTINUE
76332 200 CONTINUE
76333 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
76334 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
76335 IF(TDS.LE.P(ILG,4)) GOTO 230
76336 DO 210 J=1,4
76337 P(ILG+1,J)=P(ILG,J)
76338 210 CONTINUE
76339 220 CONTINUE
76340 ILG=N+NP+MSTU(44)+4
76341 230 DO 240 J=1,3
76342 P(ILG+1,J)=TDI(J)
76343 240 CONTINUE
76344 P(ILG+1,4)=TDS
76345 250 CONTINUE
76346
76347C...Iterate direction of axis until stable maximum.
76348 P(N+NP+ILD,4)=0D0
76349 ILG=0
76350 260 ILG=ILG+1
76351 THP=0D0
76352 270 THPS=THP
76353 DO 280 J=1,3
76354 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
76355 IF(THP.GT.1D-10) TDI(J)=TPR(J)
76356 TPR(J)=0D0
76357 280 CONTINUE
76358 DO 300 I=N+1,N+NP
76359 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
76360 DO 290 J=1,4-ILD
76361 TPR(J)=TPR(J)+SGN*P(I,J)
76362 290 CONTINUE
76363 300 CONTINUE
76364 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
76365 IF(THP.GE.THPS+PARU(48)) GOTO 270
76366
76367C...Save good axis. Try new initial axis until a number of tries agree.
76368 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
76369 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
76370 IAGR=0
76371 SGN=(-1D0)**INT(PYR(0)+0.5D0)
76372 DO 310 J=1,3
76373 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
76374 310 CONTINUE
76375 P(N+NP+ILD,4)=THP
76376 P(N+NP+ILD,5)=0D0
76377 ENDIF
76378 IAGR=IAGR+1
76379 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
76380 320 CONTINUE
76381
76382C...Find minor axis and value by orthogonality.
76383 SGN=(-1D0)**INT(PYR(0)+0.5D0)
76384 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
76385 P(N+NP+3,2)=SGN*P(N+NP+2,1)
76386 P(N+NP+3,3)=0D0
76387 THP=0D0
76388 DO 330 I=N+1,N+NP
76389 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
76390 330 CONTINUE
76391 P(N+NP+3,4)=THP/PS
76392 P(N+NP+3,5)=0D0
76393
76394C...Fill axis information. Rotate back to original coordinate system.
76395 DO 350 ILD=1,3
76396 K(N+ILD,1)=31
76397 K(N+ILD,2)=96
76398 K(N+ILD,3)=ILD
76399 K(N+ILD,4)=0
76400 K(N+ILD,5)=0
76401 DO 340 J=1,5
76402 P(N+ILD,J)=P(N+NP+ILD,J)
76403 V(N+ILD,J)=0D0
76404 340 CONTINUE
76405 350 CONTINUE
76406 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
76407
76408C...Calculate thrust and oblateness. Select storing option.
76409 THR=P(N+1,4)
76410 OBL=P(N+2,4)-P(N+3,4)
76411 MSTU(61)=N+1
76412 MSTU(62)=NP
76413 IF(MSTU(43).LE.1) MSTU(3)=3
76414 IF(MSTU(43).GE.2) N=N+3
76415
76416 RETURN
76417 END
76418
76419C*********************************************************************
76420
76421C...PYCLUS
76422C...Subdivides the particle content of an event into jets/clusters.
76423
76424 SUBROUTINE PYCLUS(NJET)
76425
76426C...Double precision and integer declarations.
76427 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76428 IMPLICIT INTEGER(I-N)
76429 INTEGER PYK,PYCHGE,PYCOMP
76430C...Parameter statement to help give large particle numbers.
76431 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
76432 &KEXCIT=4000000,KDIMEN=5000000)
76433C...Commonblocks.
76434 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76435 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76436 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76437 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76438C...Local arrays and saved variables.
76439 DIMENSION PS(5)
76440 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
76441
76442C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
76443 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
76444 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
76445 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
76446 &P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
76447 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
76448 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
76449
76450C...If first time, reset. If reentering, skip preliminaries.
76451 IF(MSTU(48).LE.0) THEN
76452 NP=0
76453 DO 100 J=1,5
76454 PS(J)=0D0
76455 100 CONTINUE
76456 PSS=0D0
76457 PIMASS=PMAS(PYCOMP(211),1)
76458 ELSE
76459 NJET=NSAV
76460 IF(MSTU(43).GE.2) N=N-NJET
76461 DO 110 I=N+1,N+NJET
76462 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
76463 110 CONTINUE
76464 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
76465 R2ACC=PARU(44)**2
76466 ELSE
76467 R2ACC=PARU(45)*PS(5)**2
76468 ENDIF
76469 NLOOP=0
76470 GOTO 300
76471 ENDIF
76472
76473C...Find which particles are to be considered in cluster search.
76474 DO 140 I=1,N
76475 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
76476 IF(MSTU(41).GE.2) THEN
76477 KC=PYCOMP(K(I,2))
76478 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76479 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76480 & K(I,2).EQ.KSUSY1+39) GOTO 140
76481 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
76482 & GOTO 140
76483 ENDIF
76484 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
76485 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
76486 NJET=-1
76487 RETURN
76488 ENDIF
76489
76490C...Take copy of these particles, with space left for jets later on.
76491 NP=NP+1
76492 K(N+NP,3)=I
76493 DO 120 J=1,5
76494 P(N+NP,J)=P(I,J)
76495 120 CONTINUE
76496 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
76497 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
76498 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
76499 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
76500 DO 130 J=1,4
76501 PS(J)=PS(J)+P(N+NP,J)
76502 130 CONTINUE
76503 PSS=PSS+P(N+NP,5)
76504 140 CONTINUE
76505 DO 160 I=N+1,N+NP
76506 K(I+NP,3)=K(I,3)
76507 DO 150 J=1,5
76508 P(I+NP,J)=P(I,J)
76509 150 CONTINUE
76510 160 CONTINUE
76511 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
76512
76513C...Very low multiplicities not considered.
76514 IF(NP.LT.MSTU(47)) THEN
76515 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
76516 NJET=-1
76517 RETURN
76518 ENDIF
76519
76520C...Find precluster configuration. If too few jets, make harder cuts.
76521 NLOOP=0
76522 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
76523 R2ACC=PARU(44)**2
76524 ELSE
76525 R2ACC=PARU(45)*PS(5)**2
76526 ENDIF
76527 RINIT=1.25D0*PARU(43)
76528 IF(NP.LE.MSTU(47)+2) RINIT=0D0
76529 170 RINIT=0.8D0*RINIT
76530 NPRE=0
76531 NREM=NP
76532 DO 180 I=N+NP+1,N+2*NP
76533 K(I,4)=0
76534 180 CONTINUE
76535
76536C...Sum up small momentum region. Jet if enough absolute momentum.
76537 IF(MSTU(46).LE.2) THEN
76538 DO 190 J=1,4
76539 P(N+1,J)=0D0
76540 190 CONTINUE
76541 DO 210 I=N+NP+1,N+2*NP
76542 IF(P(I,5).GT.2D0*RINIT) GOTO 210
76543 NREM=NREM-1
76544 K(I,4)=1
76545 DO 200 J=1,4
76546 P(N+1,J)=P(N+1,J)+P(I,J)
76547 200 CONTINUE
76548 210 CONTINUE
76549 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
76550 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
76551 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
76552 IF(NREM.EQ.0) GOTO 170
76553 ENDIF
76554
76555C...Find fastest remaining particle.
76556 220 NPRE=NPRE+1
76557 PMAX=0D0
76558 DO 230 I=N+NP+1,N+2*NP
76559 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
76560 IMAX=I
76561 PMAX=P(I,5)
76562 230 CONTINUE
76563 DO 240 J=1,5
76564 P(N+NPRE,J)=P(IMAX,J)
76565 240 CONTINUE
76566 NREM=NREM-1
76567 K(IMAX,4)=NPRE
76568
76569C...Sum up precluster around it according to pT separation.
76570 IF(MSTU(46).LE.2) THEN
76571 DO 260 I=N+NP+1,N+2*NP
76572 IF(K(I,4).NE.0) GOTO 260
76573 R2=R2T(I,IMAX)
76574 IF(R2.GT.RINIT**2) GOTO 260
76575 NREM=NREM-1
76576 K(I,4)=NPRE
76577 DO 250 J=1,4
76578 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
76579 250 CONTINUE
76580 260 CONTINUE
76581 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
76582
76583C...Sum up precluster around it according to mass or
76584C...Durham pT separation.
76585 ELSE
76586 270 IMIN=0
76587 R2MIN=RINIT**2
76588 DO 280 I=N+NP+1,N+2*NP
76589 IF(K(I,4).NE.0) GOTO 280
76590 IF(MSTU(46).LE.4) THEN
76591 R2=R2M(I,N+NPRE)
76592 ELSE
76593 R2=R2D(I,N+NPRE)
76594 ENDIF
76595 IF(R2.GE.R2MIN) GOTO 280
76596 IMIN=I
76597 R2MIN=R2
76598 280 CONTINUE
76599 IF(IMIN.NE.0) THEN
76600 DO 290 J=1,4
76601 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
76602 290 CONTINUE
76603 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
76604 NREM=NREM-1
76605 K(IMIN,4)=NPRE
76606 GOTO 270
76607 ENDIF
76608 ENDIF
76609
76610C...Check if more preclusters to be found. Start over if too few.
76611 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
76612 IF(NREM.GT.0) GOTO 220
76613 NJET=NPRE
76614
76615C...Reassign all particles to nearest jet. Sum up new jet momenta.
76616 300 TSAV=0D0
76617 PSJT=0D0
76618 310 IF(MSTU(46).LE.1) THEN
76619 DO 330 I=N+1,N+NJET
76620 DO 320 J=1,4
76621 V(I,J)=0D0
76622 320 CONTINUE
76623 330 CONTINUE
76624 DO 360 I=N+NP+1,N+2*NP
76625 R2MIN=PSS**2
76626 DO 340 IJET=N+1,N+NJET
76627 IF(P(IJET,5).LT.RINIT) GOTO 340
76628 R2=R2T(I,IJET)
76629 IF(R2.GE.R2MIN) GOTO 340
76630 IMIN=IJET
76631 R2MIN=R2
76632 340 CONTINUE
76633 K(I,4)=IMIN-N
76634 DO 350 J=1,4
76635 V(IMIN,J)=V(IMIN,J)+P(I,J)
76636 350 CONTINUE
76637 360 CONTINUE
76638 PSJT=0D0
76639 DO 380 I=N+1,N+NJET
76640 DO 370 J=1,4
76641 P(I,J)=V(I,J)
76642 370 CONTINUE
76643 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
76644 PSJT=PSJT+P(I,5)
76645 380 CONTINUE
76646 ENDIF
76647
76648C...Find two closest jets.
76649 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
76650 DO 400 ITRY1=N+1,N+NJET-1
76651 DO 390 ITRY2=ITRY1+1,N+NJET
76652 IF(MSTU(46).LE.2) THEN
76653 R2=R2T(ITRY1,ITRY2)
76654 ELSEIF(MSTU(46).LE.4) THEN
76655 R2=R2M(ITRY1,ITRY2)
76656 ELSE
76657 R2=R2D(ITRY1,ITRY2)
76658 ENDIF
76659 IF(R2.GE.R2MIN) GOTO 390
76660 IMIN1=ITRY1
76661 IMIN2=ITRY2
76662 R2MIN=R2
76663 390 CONTINUE
76664 400 CONTINUE
76665
76666C...If allowed, join two closest jets and start over.
76667 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
76668 IREC=MIN(IMIN1,IMIN2)
76669 IDEL=MAX(IMIN1,IMIN2)
76670 DO 410 J=1,4
76671 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
76672 410 CONTINUE
76673 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
76674 DO 430 I=IDEL+1,N+NJET
76675 DO 420 J=1,5
76676 P(I-1,J)=P(I,J)
76677 420 CONTINUE
76678 430 CONTINUE
76679 IF(MSTU(46).GE.2) THEN
76680 DO 440 I=N+NP+1,N+2*NP
76681 IORI=N+K(I,4)
76682 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
76683 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
76684 440 CONTINUE
76685 ENDIF
76686 NJET=NJET-1
76687 GOTO 300
76688
76689C...Divide up broad jet if empty cluster in list of final ones.
76690 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
76691 DO 450 I=N+1,N+NJET
76692 K(I,5)=0
76693 450 CONTINUE
76694 DO 460 I=N+NP+1,N+2*NP
76695 K(N+K(I,4),5)=K(N+K(I,4),5)+1
76696 460 CONTINUE
76697 IEMP=0
76698 DO 470 I=N+1,N+NJET
76699 IF(K(I,5).EQ.0) IEMP=I
76700 470 CONTINUE
76701 IF(IEMP.NE.0) THEN
76702 NLOOP=NLOOP+1
76703 ISPL=0
76704 R2MAX=0D0
76705 DO 480 I=N+NP+1,N+2*NP
76706 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
76707 IJET=N+K(I,4)
76708 R2=R2T(I,IJET)
76709 IF(R2.LE.R2MAX) GOTO 480
76710 ISPL=I
76711 R2MAX=R2
76712 480 CONTINUE
76713 IF(ISPL.NE.0) THEN
76714 IJET=N+K(ISPL,4)
76715 DO 490 J=1,4
76716 P(IEMP,J)=P(ISPL,J)
76717 P(IJET,J)=P(IJET,J)-P(ISPL,J)
76718 490 CONTINUE
76719 P(IEMP,5)=P(ISPL,5)
76720 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
76721 IF(NLOOP.LE.2) GOTO 300
76722 ENDIF
76723 ENDIF
76724 ENDIF
76725
76726C...If generalized thrust has not yet converged, continue iteration.
76727 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
76728 &THEN
76729 TSAV=PSJT/PSS
76730 GOTO 310
76731 ENDIF
76732
76733C...Reorder jets according to energy.
76734 DO 510 I=N+1,N+NJET
76735 DO 500 J=1,5
76736 V(I,J)=P(I,J)
76737 500 CONTINUE
76738 510 CONTINUE
76739 DO 540 INEW=N+1,N+NJET
76740 PEMAX=0D0
76741 DO 520 ITRY=N+1,N+NJET
76742 IF(V(ITRY,4).LE.PEMAX) GOTO 520
76743 IMAX=ITRY
76744 PEMAX=V(ITRY,4)
76745 520 CONTINUE
76746 K(INEW,1)=31
76747 K(INEW,2)=97
76748 K(INEW,3)=INEW-N
76749 K(INEW,4)=0
76750 DO 530 J=1,5
76751 P(INEW,J)=V(IMAX,J)
76752 530 CONTINUE
76753 V(IMAX,4)=-1D0
76754 K(IMAX,5)=INEW
76755 540 CONTINUE
76756
76757C...Clean up particle-jet assignments and jet information.
76758 DO 550 I=N+NP+1,N+2*NP
76759 IORI=K(N+K(I,4),5)
76760 K(I,4)=IORI-N
76761 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
76762 K(IORI,4)=K(IORI,4)+1
76763 550 CONTINUE
76764 IEMP=0
76765 PSJT=0D0
76766 DO 570 I=N+1,N+NJET
76767 K(I,5)=0
76768 PSJT=PSJT+P(I,5)
76769 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
76770 DO 560 J=1,5
76771 V(I,J)=0D0
76772 560 CONTINUE
76773 IF(K(I,4).EQ.0) IEMP=I
76774 570 CONTINUE
76775
76776C...Select storing option. Output variables. Check for failure.
76777 MSTU(61)=N+1
76778 MSTU(62)=NP
76779 MSTU(63)=NPRE
76780 PARU(61)=PS(5)
76781 PARU(62)=PSJT/PSS
76782 PARU(63)=SQRT(R2MIN)
76783 IF(NJET.LE.1) PARU(63)=0D0
76784 IF(IEMP.NE.0) THEN
76785 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
76786 NJET=-1
76787 RETURN
76788 ENDIF
76789 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
76790 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
76791 NSAV=NJET
76792
76793 RETURN
76794 END
76795
76796C*********************************************************************
76797
76798C...PYCELL
76799C...Provides a simple way of jet finding in eta-phi-ET coordinates,
76800C...as used for calorimeters at hadron colliders.
76801
76802 SUBROUTINE PYCELL(NJET)
76803
76804C...Double precision and integer declarations.
76805 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76806 IMPLICIT INTEGER(I-N)
76807 INTEGER PYK,PYCHGE,PYCOMP
76808C...Parameter statement to help give large particle numbers.
76809 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
76810 &KEXCIT=4000000,KDIMEN=5000000)
76811C...Commonblocks.
76812 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76813 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76814 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76815 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76816
76817C...Loop over all particles. Find cell that was hit by given particle.
76818 PTLRAT=1D0/SINH(PARU(51))**2
76819 NP=0
76820 NC=N
76821 DO 110 I=1,N
76822 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
76823 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
76824 IF(MSTU(41).GE.2) THEN
76825 KC=PYCOMP(K(I,2))
76826 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76827 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76828 & K(I,2).EQ.KSUSY1+39) GOTO 110
76829 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
76830 & GOTO 110
76831 ENDIF
76832 NP=NP+1
76833 PT=SQRT(P(I,1)**2+P(I,2)**2)
76834 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
76835 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
76836 & (ETA/PARU(51)+1D0))))
76837 PHI=PYANGL(P(I,1),P(I,2))
76838 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
76839 & (PHI/PARU(1)+1D0))))
76840 IETPH=MSTU(52)*IETA+IPHI
76841
76842C...Add to cell already hit, or book new cell.
76843 DO 100 IC=N+1,NC
76844 IF(IETPH.EQ.K(IC,3)) THEN
76845 K(IC,4)=K(IC,4)+1
76846 P(IC,5)=P(IC,5)+PT
76847 GOTO 110
76848 ENDIF
76849 100 CONTINUE
76850 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
76851 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
76852 NJET=-2
76853 RETURN
76854 ENDIF
76855 NC=NC+1
76856 K(NC,3)=IETPH
76857 K(NC,4)=1
76858 K(NC,5)=2
76859 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
76860 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
76861 P(NC,5)=PT
76862 110 CONTINUE
76863
76864C...Smear true bin content by calorimeter resolution.
76865 IF(MSTU(53).GE.1) THEN
76866 DO 130 IC=N+1,NC
76867 PEI=P(IC,5)
76868 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
76869 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
76870 & COS(PARU(2)*PYR(0))
76871 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
76872 P(IC,5)=PEF
76873 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
76874 130 CONTINUE
76875 ENDIF
76876
76877C...Remove cells below threshold.
76878 IF(PARU(58).GT.0D0) THEN
76879 NCC=NC
76880 NC=N
76881 DO 140 IC=N+1,NCC
76882 IF(P(IC,5).GT.PARU(58)) THEN
76883 NC=NC+1
76884 K(NC,3)=K(IC,3)
76885 K(NC,4)=K(IC,4)
76886 K(NC,5)=K(IC,5)
76887 P(NC,1)=P(IC,1)
76888 P(NC,2)=P(IC,2)
76889 P(NC,5)=P(IC,5)
76890 ENDIF
76891 140 CONTINUE
76892 ENDIF
76893
76894C...Find initiator cell: the one with highest pT of not yet used ones.
76895 NJ=NC
76896 150 ETMAX=0D0
76897 DO 160 IC=N+1,NC
76898 IF(K(IC,5).NE.2) GOTO 160
76899 IF(P(IC,5).LE.ETMAX) GOTO 160
76900 ICMAX=IC
76901 ETA=P(IC,1)
76902 PHI=P(IC,2)
76903 ETMAX=P(IC,5)
76904 160 CONTINUE
76905 IF(ETMAX.LT.PARU(52)) GOTO 220
76906 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
76907 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
76908 NJET=-2
76909 RETURN
76910 ENDIF
76911 K(ICMAX,5)=1
76912 NJ=NJ+1
76913 K(NJ,4)=0
76914 K(NJ,5)=1
76915 P(NJ,1)=ETA
76916 P(NJ,2)=PHI
76917 P(NJ,3)=0D0
76918 P(NJ,4)=0D0
76919 P(NJ,5)=0D0
76920
76921C...Sum up unused cells within required distance of initiator.
76922 DO 170 IC=N+1,NC
76923 IF(K(IC,5).EQ.0) GOTO 170
76924 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
76925 DPHIA=ABS(P(IC,2)-PHI)
76926 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
76927 PHIC=P(IC,2)
76928 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
76929 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
76930 K(IC,5)=-K(IC,5)
76931 K(NJ,4)=K(NJ,4)+K(IC,4)
76932 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
76933 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
76934 P(NJ,5)=P(NJ,5)+P(IC,5)
76935 170 CONTINUE
76936
76937C...Reject cluster below minimum ET, else accept.
76938 IF(P(NJ,5).LT.PARU(53)) THEN
76939 NJ=NJ-1
76940 DO 180 IC=N+1,NC
76941 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
76942 180 CONTINUE
76943 ELSEIF(MSTU(54).LE.2) THEN
76944 P(NJ,3)=P(NJ,3)/P(NJ,5)
76945 P(NJ,4)=P(NJ,4)/P(NJ,5)
76946 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
76947 & P(NJ,4))
76948 DO 190 IC=N+1,NC
76949 IF(K(IC,5).LT.0) K(IC,5)=0
76950 190 CONTINUE
76951 ELSE
76952 DO 200 J=1,4
76953 P(NJ,J)=0D0
76954 200 CONTINUE
76955 DO 210 IC=N+1,NC
76956 IF(K(IC,5).GE.0) GOTO 210
76957 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
76958 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
76959 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
76960 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
76961 K(IC,5)=0
76962 210 CONTINUE
76963 ENDIF
76964 GOTO 150
76965
76966C...Arrange clusters in falling ET sequence.
76967 220 DO 250 I=1,NJ-NC
76968 ETMAX=0D0
76969 DO 230 IJ=NC+1,NJ
76970 IF(K(IJ,5).EQ.0) GOTO 230
76971 IF(P(IJ,5).LT.ETMAX) GOTO 230
76972 IJMAX=IJ
76973 ETMAX=P(IJ,5)
76974 230 CONTINUE
76975 K(IJMAX,5)=0
76976 K(N+I,1)=31
76977 K(N+I,2)=98
76978 K(N+I,3)=I
76979 K(N+I,4)=K(IJMAX,4)
76980 K(N+I,5)=0
76981 DO 240 J=1,5
76982 P(N+I,J)=P(IJMAX,J)
76983 V(N+I,J)=0D0
76984 240 CONTINUE
76985 250 CONTINUE
76986 NJET=NJ-NC
76987
76988C...Convert to massless or massive four-vectors.
76989 IF(MSTU(54).EQ.2) THEN
76990 DO 260 I=N+1,N+NJET
76991 ETA=P(I,3)
76992 P(I,1)=P(I,5)*COS(P(I,4))
76993 P(I,2)=P(I,5)*SIN(P(I,4))
76994 P(I,3)=P(I,5)*SINH(ETA)
76995 P(I,4)=P(I,5)*COSH(ETA)
76996 P(I,5)=0D0
76997 260 CONTINUE
76998 ELSEIF(MSTU(54).GE.3) THEN
76999 DO 270 I=N+1,N+NJET
77000 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
77001 270 CONTINUE
77002 ENDIF
77003
77004C...Information about storage.
77005 MSTU(61)=N+1
77006 MSTU(62)=NP
77007 MSTU(63)=NC-N
77008 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
77009 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
77010
77011 RETURN
77012 END
77013
77014C*********************************************************************
77015
77016C...PYJMAS
77017C...Determines, approximately, the two jet masses that minimize
77018C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
77019
77020 SUBROUTINE PYJMAS(PMH,PML)
77021
77022C...Double precision and integer declarations.
77023 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77024 IMPLICIT INTEGER(I-N)
77025 INTEGER PYK,PYCHGE,PYCOMP
77026C...Parameter statement to help give large particle numbers.
77027 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
77028 &KEXCIT=4000000,KDIMEN=5000000)
77029C...Commonblocks.
77030 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77031 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77032 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77033 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77034C...Local arrays.
77035 DIMENSION SM(3,3),SAX(3),PS(3,5)
77036
77037C...Reset.
77038 NP=0
77039 DO 120 J1=1,3
77040 DO 100 J2=J1,3
77041 SM(J1,J2)=0D0
77042 100 CONTINUE
77043 DO 110 J2=1,4
77044 PS(J1,J2)=0D0
77045 110 CONTINUE
77046 120 CONTINUE
77047 PSS=0D0
77048 PIMASS=PMAS(PYCOMP(211),1)
77049
77050C...Take copy of particles that are to be considered in mass analysis.
77051 DO 170 I=1,N
77052 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
77053 IF(MSTU(41).GE.2) THEN
77054 KC=PYCOMP(K(I,2))
77055 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77056 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77057 & K(I,2).EQ.KSUSY1+39) GOTO 170
77058 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
77059 & GOTO 170
77060 ENDIF
77061 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
77062 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
77063 PMH=-2D0
77064 PML=-2D0
77065 RETURN
77066 ENDIF
77067 NP=NP+1
77068 DO 130 J=1,5
77069 P(N+NP,J)=P(I,J)
77070 130 CONTINUE
77071 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
77072 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
77073 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
77074
77075C...Fill information in sphericity tensor and total momentum vector.
77076 DO 150 J1=1,3
77077 DO 140 J2=J1,3
77078 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
77079 140 CONTINUE
77080 150 CONTINUE
77081 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
77082 DO 160 J=1,4
77083 PS(3,J)=PS(3,J)+P(N+NP,J)
77084 160 CONTINUE
77085 170 CONTINUE
77086
77087C...Very low multiplicities (0 or 1) not considered.
77088 IF(NP.LE.1) THEN
77089 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
77090 PMH=-1D0
77091 PML=-1D0
77092 RETURN
77093 ENDIF
77094 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
77095 &PS(3,3)**2))
77096
77097C...Find largest eigenvalue to matrix (third degree equation).
77098 DO 190 J1=1,3
77099 DO 180 J2=J1,3
77100 SM(J1,J2)=SM(J1,J2)/PSS
77101 180 CONTINUE
77102 190 CONTINUE
77103 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
77104 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
77105 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
77106 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
77107 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
77108 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
77109 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
77110
77111C...Find largest eigenvector by solving equation system.
77112 DO 210 J1=1,3
77113 SM(J1,J1)=SM(J1,J1)-SMA
77114 DO 200 J2=J1+1,3
77115 SM(J2,J1)=SM(J1,J2)
77116 200 CONTINUE
77117 210 CONTINUE
77118 SMAX=0D0
77119 DO 230 J1=1,3
77120 DO 220 J2=1,3
77121 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
77122 JA=J1
77123 JB=J2
77124 SMAX=ABS(SM(J1,J2))
77125 220 CONTINUE
77126 230 CONTINUE
77127 SMAX=0D0
77128 DO 250 J3=JA+1,JA+2
77129 J1=J3-3*((J3-1)/3)
77130 RL=SM(J1,JB)/SM(JA,JB)
77131 DO 240 J2=1,3
77132 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
77133 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
77134 JC=J1
77135 SMAX=ABS(SM(J1,J2))
77136 240 CONTINUE
77137 250 CONTINUE
77138 JB1=JB+1-3*(JB/3)
77139 JB2=JB+2-3*((JB+1)/3)
77140 SAX(JB1)=-SM(JC,JB2)
77141 SAX(JB2)=SM(JC,JB1)
77142 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
77143
77144C...Divide particles into two initial clusters by hemisphere.
77145 DO 270 I=N+1,N+NP
77146 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
77147 IS=1
77148 IF(PSAX.LT.0D0) IS=2
77149 K(I,3)=IS
77150 DO 260 J=1,4
77151 PS(IS,J)=PS(IS,J)+P(I,J)
77152 260 CONTINUE
77153 270 CONTINUE
77154 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
77155 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
77156
77157C...Reassign one particle at a time; find maximum decrease of m^2 sum.
77158 280 PMD=0D0
77159 IM=0
77160 DO 290 J=1,4
77161 PS(3,J)=PS(1,J)-PS(2,J)
77162 290 CONTINUE
77163 DO 300 I=N+1,N+NP
77164 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)
77165 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
77166 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
77167 IF(PMDI.LT.PMD) THEN
77168 PMD=PMDI
77169 IM=I
77170 ENDIF
77171 300 CONTINUE
77172
77173C...Loop back if significant reduction in sum of m^2.
77174 IF(PMD.LT.-PARU(48)*PMS) THEN
77175 PMS=PMS+PMD
77176 IS=K(IM,3)
77177 DO 310 J=1,4
77178 PS(IS,J)=PS(IS,J)-P(IM,J)
77179 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
77180 310 CONTINUE
77181 K(IM,3)=3-IS
77182 GOTO 280
77183 ENDIF
77184
77185C...Final masses and output.
77186 MSTU(61)=N+1
77187 MSTU(62)=NP
77188 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
77189 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
77190 PMH=MAX(PS(1,5),PS(2,5))
77191 PML=MIN(PS(1,5),PS(2,5))
77192
77193 RETURN
77194 END
77195
77196C*********************************************************************
77197
77198C...PYFOWO
77199C...Calculates the first few Fox-Wolfram moments.
77200
77201 SUBROUTINE PYFOWO(H10,H20,H30,H40)
77202
77203C...Double precision and integer declarations.
77204 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77205 IMPLICIT INTEGER(I-N)
77206 INTEGER PYK,PYCHGE,PYCOMP
77207C...Parameter statement to help give large particle numbers.
77208 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
77209 &KEXCIT=4000000,KDIMEN=5000000)
77210C...Commonblocks.
77211 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77212 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77213 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77214 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77215
77216C...Copy momenta for particles and calculate H0.
77217 NP=0
77218 H0=0D0
77219 HD=0D0
77220 DO 110 I=1,N
77221 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
77222 IF(MSTU(41).GE.2) THEN
77223 KC=PYCOMP(K(I,2))
77224 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77225 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77226 & K(I,2).EQ.KSUSY1+39) GOTO 110
77227 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
77228 & GOTO 110
77229 ENDIF
77230 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
77231 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
77232 H10=-1D0
77233 H20=-1D0
77234 H30=-1D0
77235 H40=-1D0
77236 RETURN
77237 ENDIF
77238 NP=NP+1
77239 DO 100 J=1,3
77240 P(N+NP,J)=P(I,J)
77241 100 CONTINUE
77242 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
77243 H0=H0+P(N+NP,4)
77244 HD=HD+P(N+NP,4)**2
77245 110 CONTINUE
77246 H0=H0**2
77247
77248C...Very low multiplicities (0 or 1) not considered.
77249 IF(NP.LE.1) THEN
77250 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
77251 H10=-1D0
77252 H20=-1D0
77253 H30=-1D0
77254 H40=-1D0
77255 RETURN
77256 ENDIF
77257
77258C...Calculate H1 - H4.
77259 H10=0D0
77260 H20=0D0
77261 H30=0D0
77262 H40=0D0
77263 DO 130 I1=N+1,N+NP
77264 DO 120 I2=I1+1,N+NP
77265 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
77266 & (P(I1,4)*P(I2,4))
77267 H10=H10+P(I1,4)*P(I2,4)*CTHE
77268 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
77269 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
77270 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
77271 & 0.375D0)
77272 120 CONTINUE
77273 130 CONTINUE
77274
77275C...Calculate H1/H0 - H4/H0. Output.
77276 MSTU(61)=N+1
77277 MSTU(62)=NP
77278 H10=(HD+2D0*H10)/H0
77279 H20=(HD+2D0*H20)/H0
77280 H30=(HD+2D0*H30)/H0
77281 H40=(HD+2D0*H40)/H0
77282
77283 RETURN
77284 END
77285
77286C*********************************************************************
77287
77288C...PYTABU
77289C...Evaluates various properties of an event, with statistics
77290C...accumulated during the course of the run and
77291C...printed at the end.
77292
77293 SUBROUTINE PYTABU(MTABU)
77294
77295C...Double precision and integer declarations.
77296 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77297 IMPLICIT INTEGER(I-N)
77298 INTEGER PYK,PYCHGE,PYCOMP
77299C...Parameter statement to help give large particle numbers.
77300 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
77301 &KEXCIT=4000000,KDIMEN=5000000)
77302C...Commonblocks.
77303 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77304 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77305 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77306 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
77307 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
77308C...Local arrays, character variables, saved variables and data.
77309 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
77310 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
77311 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
77312 &KFDM(8),KFDC(200,0:8),NPDC(200)
77313 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
77314 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
77315 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
77316 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
77317 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
77318 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
77319 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
77320 &NEVDC/0/,NKFDC/0/,NREDC/0/
77321
77322C...Reset statistics on initial parton state.
77323 IF(MTABU.EQ.10) THEN
77324 NEVIS=0
77325 NKFIS=0
77326
77327C...Identify and order flavour content of initial state.
77328 ELSEIF(MTABU.EQ.11) THEN
77329 NEVIS=NEVIS+1
77330 KFM1=2*IABS(MSTU(161))
77331 IF(MSTU(161).GT.0) KFM1=KFM1-1
77332 KFM2=2*IABS(MSTU(162))
77333 IF(MSTU(162).GT.0) KFM2=KFM2-1
77334 KFMN=MIN(KFM1,KFM2)
77335 KFMX=MAX(KFM1,KFM2)
77336 DO 100 I=1,NKFIS
77337 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
77338 IKFIS=-I
77339 GOTO 110
77340 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
77341 & KFMX.LT.KFIS(I,2))) THEN
77342 IKFIS=I
77343 GOTO 110
77344 ENDIF
77345 100 CONTINUE
77346 IKFIS=NKFIS+1
77347 110 IF(IKFIS.LT.0) THEN
77348 IKFIS=-IKFIS
77349 ELSE
77350 IF(NKFIS.GE.100) RETURN
77351 DO 130 I=NKFIS,IKFIS,-1
77352 KFIS(I+1,1)=KFIS(I,1)
77353 KFIS(I+1,2)=KFIS(I,2)
77354 DO 120 J=0,10
77355 NPIS(I+1,J)=NPIS(I,J)
77356 120 CONTINUE
77357 130 CONTINUE
77358 NKFIS=NKFIS+1
77359 KFIS(IKFIS,1)=KFMN
77360 KFIS(IKFIS,2)=KFMX
77361 DO 140 J=0,10
77362 NPIS(IKFIS,J)=0
77363 140 CONTINUE
77364 ENDIF
77365 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
77366
77367C...Count number of partons in initial state.
77368 NP=0
77369 DO 160 I=1,N
77370 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
77371 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
77372 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
77373 & THEN
77374 ELSE
77375 IM=I
77376 150 IM=K(IM,3)
77377 IF(IM.LE.0.OR.IM.GT.N) THEN
77378 NP=NP+1
77379 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
77380 NP=NP+1
77381 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
77382 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
77383 & .NE.0) THEN
77384 ELSE
77385 GOTO 150
77386 ENDIF
77387 ENDIF
77388 160 CONTINUE
77389 NPCO=MAX(NP,1)
77390 IF(NP.GE.6) NPCO=6
77391 IF(NP.GE.8) NPCO=7
77392 IF(NP.GE.11) NPCO=8
77393 IF(NP.GE.16) NPCO=9
77394 IF(NP.GE.26) NPCO=10
77395 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
77396 MSTU(62)=NP
77397
77398C...Write statistics on initial parton state.
77399 ELSEIF(MTABU.EQ.12) THEN
77400 FAC=1D0/MAX(1,NEVIS)
77401 WRITE(MSTU(11),5000) NEVIS
77402 DO 170 I=1,NKFIS
77403 KFMN=KFIS(I,1)
77404 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
77405 KFM1=(KFMN+1)/2
77406 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
77407 CALL PYNAME(KFM1,CHAU)
77408 CHIS(1)=CHAU(1:12)
77409 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
77410 KFMX=KFIS(I,2)
77411 IF(KFIS(I,1).EQ.0) KFMX=0
77412 KFM2=(KFMX+1)/2
77413 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
77414 CALL PYNAME(KFM2,CHAU)
77415 CHIS(2)=CHAU(1:12)
77416 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
77417 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
77418 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
77419 170 CONTINUE
77420
77421C...Copy statistics on initial parton state into /PYJETS/.
77422 ELSEIF(MTABU.EQ.13) THEN
77423 FAC=1D0/MAX(1,NEVIS)
77424 DO 190 I=1,NKFIS
77425 KFMN=KFIS(I,1)
77426 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
77427 KFM1=(KFMN+1)/2
77428 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
77429 KFMX=KFIS(I,2)
77430 IF(KFIS(I,1).EQ.0) KFMX=0
77431 KFM2=(KFMX+1)/2
77432 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
77433 K(I,1)=32
77434 K(I,2)=99
77435 K(I,3)=KFM1
77436 K(I,4)=KFM2
77437 K(I,5)=NPIS(I,0)
77438 DO 180 J=1,5
77439 P(I,J)=FAC*NPIS(I,J)
77440 V(I,J)=FAC*NPIS(I,J+5)
77441 180 CONTINUE
77442 190 CONTINUE
77443 N=NKFIS
77444 DO 200 J=1,5
77445 K(N+1,J)=0
77446 P(N+1,J)=0D0
77447 V(N+1,J)=0D0
77448 200 CONTINUE
77449 K(N+1,1)=32
77450 K(N+1,2)=99
77451 K(N+1,5)=NEVIS
77452 MSTU(3)=1
77453
77454C...Reset statistics on number of particles/partons.
77455 ELSEIF(MTABU.EQ.20) THEN
77456 NEVFS=0
77457 NPRFS=0
77458 NFIFS=0
77459 NCHFS=0
77460 NKFFS=0
77461
77462C...Identify whether particle/parton is primary or not.
77463 ELSEIF(MTABU.EQ.21) THEN
77464 NEVFS=NEVFS+1
77465 MSTU(62)=0
77466 DO 260 I=1,N
77467 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
77468 MSTU(62)=MSTU(62)+1
77469 KC=PYCOMP(K(I,2))
77470 MPRI=0
77471 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
77472 MPRI=1
77473 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
77474 MPRI=1
77475 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
77476 MPRI=1
77477 ELSEIF(KC.EQ.0) THEN
77478 ELSEIF(K(K(I,3),1).EQ.13) THEN
77479 IM=K(K(I,3),3)
77480 IF(IM.LE.0.OR.IM.GT.N) THEN
77481 MPRI=1
77482 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
77483 MPRI=1
77484 ENDIF
77485 ELSEIF(KCHG(KC,2).EQ.0) THEN
77486 KCM=PYCOMP(K(K(I,3),2))
77487 IF(KCM.NE.0) THEN
77488 IF(KCHG(KCM,2).NE.0) MPRI=1
77489 ENDIF
77490 ENDIF
77491 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
77492 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
77493 ENDIF
77494 IF(K(I,1).LE.10) THEN
77495 NFIFS=NFIFS+1
77496 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
77497 ENDIF
77498
77499C...Fill statistics on number of particles/partons in event.
77500 KFA=IABS(K(I,2))
77501 KFS=3-ISIGN(1,K(I,2))-MPRI
77502 DO 210 IP=1,NKFFS
77503 IF(KFA.EQ.KFFS(IP)) THEN
77504 IKFFS=-IP
77505 GOTO 220
77506 ELSEIF(KFA.LT.KFFS(IP)) THEN
77507 IKFFS=IP
77508 GOTO 220
77509 ENDIF
77510 210 CONTINUE
77511 IKFFS=NKFFS+1
77512 220 IF(IKFFS.LT.0) THEN
77513 IKFFS=-IKFFS
77514 ELSE
77515 IF(NKFFS.GE.400) RETURN
77516 DO 240 IP=NKFFS,IKFFS,-1
77517 KFFS(IP+1)=KFFS(IP)
77518 DO 230 J=1,4
77519 NPFS(IP+1,J)=NPFS(IP,J)
77520 230 CONTINUE
77521 240 CONTINUE
77522 NKFFS=NKFFS+1
77523 KFFS(IKFFS)=KFA
77524 DO 250 J=1,4
77525 NPFS(IKFFS,J)=0
77526 250 CONTINUE
77527 ENDIF
77528 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
77529 260 CONTINUE
77530
77531C...Write statistics on particle/parton composition of events.
77532 ELSEIF(MTABU.EQ.22) THEN
77533 FAC=1D0/MAX(1,NEVFS)
77534 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
77535 DO 270 I=1,NKFFS
77536 CALL PYNAME(KFFS(I),CHAU)
77537 KC=PYCOMP(KFFS(I))
77538 MDCYF=0
77539 IF(KC.NE.0) MDCYF=MDCY(KC,1)
77540 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
77541 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
77542 270 CONTINUE
77543
77544C...Copy particle/parton composition information into /PYJETS/.
77545 ELSEIF(MTABU.EQ.23) THEN
77546 FAC=1D0/MAX(1,NEVFS)
77547 DO 290 I=1,NKFFS
77548 K(I,1)=32
77549 K(I,2)=99
77550 K(I,3)=KFFS(I)
77551 K(I,4)=0
77552 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
77553 DO 280 J=1,4
77554 P(I,J)=FAC*NPFS(I,J)
77555 V(I,J)=0D0
77556 280 CONTINUE
77557 P(I,5)=FAC*K(I,5)
77558 V(I,5)=0D0
77559 290 CONTINUE
77560 N=NKFFS
77561 DO 300 J=1,5
77562 K(N+1,J)=0
77563 P(N+1,J)=0D0
77564 V(N+1,J)=0D0
77565 300 CONTINUE
77566 K(N+1,1)=32
77567 K(N+1,2)=99
77568 K(N+1,5)=NEVFS
77569 P(N+1,1)=FAC*NPRFS
77570 P(N+1,2)=FAC*NFIFS
77571 P(N+1,3)=FAC*NCHFS
77572 MSTU(3)=1
77573
77574C...Reset factorial moments statistics.
77575 ELSEIF(MTABU.EQ.30) THEN
77576 NEVFM=0
77577 NMUFM=0
77578 DO 330 IM=1,3
77579 DO 320 IB=1,10
77580 DO 310 IP=1,4
77581 FM1FM(IM,IB,IP)=0D0
77582 FM2FM(IM,IB,IP)=0D0
77583 310 CONTINUE
77584 320 CONTINUE
77585 330 CONTINUE
77586
77587C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
77588 ELSEIF(MTABU.EQ.31) THEN
77589 NEVFM=NEVFM+1
77590 NLOW=N+MSTU(3)
77591 NUPP=NLOW
77592 DO 410 I=1,N
77593 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
77594 IF(MSTU(41).GE.2) THEN
77595 KC=PYCOMP(K(I,2))
77596 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77597 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77598 & K(I,2).EQ.KSUSY1+39) GOTO 410
77599 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
77600 & PYCHGE(K(I,2)).EQ.0) GOTO 410
77601 ENDIF
77602 PMR=0D0
77603 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
77604 IF(MSTU(42).GE.2) PMR=P(I,5)
77605 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
77606 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
77607 & 1D20)),P(I,3))
77608 IF(ABS(YETA).GT.PARU(57)) GOTO 410
77609 PHI=PYANGL(P(I,1),P(I,2))
77610 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
77611 IYETA=MAX(0,MIN(511,IYETA))
77612 IPHI=512D0*(PHI+PARU(1))/PARU(2)
77613 IPHI=MAX(0,MIN(511,IPHI))
77614 IYEP=0
77615 DO 340 IB=0,9
77616 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
77617 340 CONTINUE
77618
77619C...Order particles in (pseudo)rapidity and/or azimuth.
77620 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
77621 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
77622 RETURN
77623 ENDIF
77624 NUPP=NUPP+1
77625 IF(NUPP.EQ.NLOW+1) THEN
77626 K(NUPP,1)=IYETA
77627 K(NUPP,2)=IPHI
77628 K(NUPP,3)=IYEP
77629 ELSE
77630 DO 350 I1=NUPP-1,NLOW+1,-1
77631 IF(IYETA.GE.K(I1,1)) GOTO 360
77632 K(I1+1,1)=K(I1,1)
77633 350 CONTINUE
77634 360 K(I1+1,1)=IYETA
77635 DO 370 I1=NUPP-1,NLOW+1,-1
77636 IF(IPHI.GE.K(I1,2)) GOTO 380
77637 K(I1+1,2)=K(I1,2)
77638 370 CONTINUE
77639 380 K(I1+1,2)=IPHI
77640 DO 390 I1=NUPP-1,NLOW+1,-1
77641 IF(IYEP.GE.K(I1,3)) GOTO 400
77642 K(I1+1,3)=K(I1,3)
77643 390 CONTINUE
77644 400 K(I1+1,3)=IYEP
77645 ENDIF
77646 410 CONTINUE
77647 K(NUPP+1,1)=2**10
77648 K(NUPP+1,2)=2**10
77649 K(NUPP+1,3)=4**10
77650
77651C...Calculate sum of factorial moments in event.
77652 DO 480 IM=1,3
77653 DO 430 IB=1,10
77654 DO 420 IP=1,4
77655 FEVFM(IB,IP)=0D0
77656 420 CONTINUE
77657 430 CONTINUE
77658 DO 450 IB=1,10
77659 IF(IM.LE.2) IBIN=2**(10-IB)
77660 IF(IM.EQ.3) IBIN=4**(10-IB)
77661 IAGR=K(NLOW+1,IM)/IBIN
77662 NAGR=1
77663 DO 440 I=NLOW+2,NUPP+1
77664 ICUT=K(I,IM)/IBIN
77665 IF(ICUT.EQ.IAGR) THEN
77666 NAGR=NAGR+1
77667 ELSE
77668 IF(NAGR.EQ.1) THEN
77669 ELSEIF(NAGR.EQ.2) THEN
77670 FEVFM(IB,1)=FEVFM(IB,1)+2D0
77671 ELSEIF(NAGR.EQ.3) THEN
77672 FEVFM(IB,1)=FEVFM(IB,1)+6D0
77673 FEVFM(IB,2)=FEVFM(IB,2)+6D0
77674 ELSEIF(NAGR.EQ.4) THEN
77675 FEVFM(IB,1)=FEVFM(IB,1)+12D0
77676 FEVFM(IB,2)=FEVFM(IB,2)+24D0
77677 FEVFM(IB,3)=FEVFM(IB,3)+24D0
77678 ELSE
77679 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
77680 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
77681 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
77682 & (NAGR-3D0)
77683 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
77684 & (NAGR-3D0)*(NAGR-4D0)
77685 ENDIF
77686 IAGR=ICUT
77687 NAGR=1
77688 ENDIF
77689 440 CONTINUE
77690 450 CONTINUE
77691
77692C...Add results to total statistics.
77693 DO 470 IB=10,1,-1
77694 DO 460 IP=1,4
77695 IF(FEVFM(1,IP).LT.0.5D0) THEN
77696 FEVFM(IB,IP)=0D0
77697 ELSEIF(IM.LE.2) THEN
77698 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
77699 ELSE
77700 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
77701 ENDIF
77702 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
77703 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
77704 460 CONTINUE
77705 470 CONTINUE
77706 480 CONTINUE
77707 NMUFM=NMUFM+(NUPP-NLOW)
77708 MSTU(62)=NUPP-NLOW
77709
77710C...Write accumulated statistics on factorial moments.
77711 ELSEIF(MTABU.EQ.32) THEN
77712 FAC=1D0/MAX(1,NEVFM)
77713 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
77714 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
77715 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
77716 DO 510 IM=1,3
77717 WRITE(MSTU(11),5500)
77718 DO 500 IB=1,10
77719 BYETA=2D0*PARU(57)
77720 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
77721 BPHI=PARU(2)
77722 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
77723 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
77724 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
77725 DO 490 IP=1,4
77726 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
77727 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
77728 & FMOMA(IP)**2)))
77729 490 CONTINUE
77730 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
77731 & IP=1,4)
77732 500 CONTINUE
77733 510 CONTINUE
77734
77735C...Copy statistics on factorial moments into /PYJETS/.
77736 ELSEIF(MTABU.EQ.33) THEN
77737 FAC=1D0/MAX(1,NEVFM)
77738 DO 540 IM=1,3
77739 DO 530 IB=1,10
77740 I=10*(IM-1)+IB
77741 K(I,1)=32
77742 K(I,2)=99
77743 K(I,3)=1
77744 IF(IM.NE.2) K(I,3)=2**(IB-1)
77745 K(I,4)=1
77746 IF(IM.NE.1) K(I,4)=2**(IB-1)
77747 K(I,5)=0
77748 P(I,1)=2D0*PARU(57)/K(I,3)
77749 V(I,1)=PARU(2)/K(I,4)
77750 DO 520 IP=1,4
77751 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
77752 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
77753 & P(I,IP+1)**2)))
77754 520 CONTINUE
77755 530 CONTINUE
77756 540 CONTINUE
77757 N=30
77758 DO 550 J=1,5
77759 K(N+1,J)=0
77760 P(N+1,J)=0D0
77761 V(N+1,J)=0D0
77762 550 CONTINUE
77763 K(N+1,1)=32
77764 K(N+1,2)=99
77765 K(N+1,5)=NEVFM
77766 MSTU(3)=1
77767
77768C...Reset statistics on Energy-Energy Correlation.
77769 ELSEIF(MTABU.EQ.40) THEN
77770 NEVEE=0
77771 DO 560 J=1,25
77772 FE1EC(J)=0D0
77773 FE2EC(J)=0D0
77774 FE1EC(51-J)=0D0
77775 FE2EC(51-J)=0D0
77776 FE1EA(J)=0D0
77777 FE2EA(J)=0D0
77778 560 CONTINUE
77779
77780C...Find particles to include, with proper assumed mass.
77781 ELSEIF(MTABU.EQ.41) THEN
77782 NEVEE=NEVEE+1
77783 NLOW=N+MSTU(3)
77784 NUPP=NLOW
77785 ECM=0D0
77786 DO 570 I=1,N
77787 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
77788 IF(MSTU(41).GE.2) THEN
77789 KC=PYCOMP(K(I,2))
77790 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77791 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77792 & K(I,2).EQ.KSUSY1+39) GOTO 570
77793 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
77794 & PYCHGE(K(I,2)).EQ.0) GOTO 570
77795 ENDIF
77796 PMR=0D0
77797 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
77798 IF(MSTU(42).GE.2) PMR=P(I,5)
77799 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
77800 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
77801 RETURN
77802 ENDIF
77803 NUPP=NUPP+1
77804 P(NUPP,1)=P(I,1)
77805 P(NUPP,2)=P(I,2)
77806 P(NUPP,3)=P(I,3)
77807 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
77808 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
77809 ECM=ECM+P(NUPP,4)
77810 570 CONTINUE
77811 IF(NUPP.EQ.NLOW) RETURN
77812
77813C...Analyze Energy-Energy Correlation in event.
77814 FAC=(2D0/ECM**2)*50D0/PARU(1)
77815 DO 580 J=1,50
77816 FEVEE(J)=0D0
77817 580 CONTINUE
77818 DO 600 I1=NLOW+2,NUPP
77819 DO 590 I2=NLOW+1,I1-1
77820 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
77821 & (P(I1,5)*P(I2,5))
77822 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
77823 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
77824 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
77825 590 CONTINUE
77826 600 CONTINUE
77827 DO 610 J=1,25
77828 FE1EC(J)=FE1EC(J)+FEVEE(J)
77829 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
77830 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
77831 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
77832 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
77833 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
77834 610 CONTINUE
77835 MSTU(62)=NUPP-NLOW
77836
77837C...Write statistics on Energy-Energy Correlation.
77838 ELSEIF(MTABU.EQ.42) THEN
77839 FAC=1D0/MAX(1,NEVEE)
77840 WRITE(MSTU(11),5700) NEVEE
77841 DO 620 J=1,25
77842 FEEC1=FAC*FE1EC(J)
77843 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
77844 FEEC2=FAC*FE1EC(51-J)
77845 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
77846 FEECA=FAC*FE1EA(J)
77847 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
77848 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
77849 & FEEC2,FEES2,FEECA,FEESA
77850 620 CONTINUE
77851
77852C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
77853 ELSEIF(MTABU.EQ.43) THEN
77854 FAC=1D0/MAX(1,NEVEE)
77855 DO 630 I=1,25
77856 K(I,1)=32
77857 K(I,2)=99
77858 K(I,3)=0
77859 K(I,4)=0
77860 K(I,5)=0
77861 P(I,1)=FAC*FE1EC(I)
77862 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
77863 P(I,2)=FAC*FE1EC(51-I)
77864 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
77865 P(I,3)=FAC*FE1EA(I)
77866 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
77867 P(I,4)=PARU(1)*(I-1)/50D0
77868 P(I,5)=PARU(1)*I/50D0
77869 V(I,4)=3.6D0*(I-1)
77870 V(I,5)=3.6D0*I
77871 630 CONTINUE
77872 N=25
77873 DO 640 J=1,5
77874 K(N+1,J)=0
77875 P(N+1,J)=0D0
77876 V(N+1,J)=0D0
77877 640 CONTINUE
77878 K(N+1,1)=32
77879 K(N+1,2)=99
77880 K(N+1,5)=NEVEE
77881 MSTU(3)=1
77882
77883C...Reset statistics on decay channels.
77884 ELSEIF(MTABU.EQ.50) THEN
77885 NEVDC=0
77886 NKFDC=0
77887 NREDC=0
77888
77889C...Identify and order flavour content of final state.
77890 ELSEIF(MTABU.EQ.51) THEN
77891 NEVDC=NEVDC+1
77892 NDS=0
77893 DO 670 I=1,N
77894 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
77895 NDS=NDS+1
77896 IF(NDS.GT.8) THEN
77897 NREDC=NREDC+1
77898 RETURN
77899 ENDIF
77900 KFM=2*IABS(K(I,2))
77901 IF(K(I,2).LT.0) KFM=KFM-1
77902 DO 650 IDS=NDS-1,1,-1
77903 IIN=IDS+1
77904 IF(KFM.LT.KFDM(IDS)) GOTO 660
77905 KFDM(IDS+1)=KFDM(IDS)
77906 650 CONTINUE
77907 IIN=1
77908 660 KFDM(IIN)=KFM
77909 670 CONTINUE
77910
77911C...Find whether old or new final state.
77912 DO 690 IDC=1,NKFDC
77913 IF(NDS.LT.KFDC(IDC,0)) THEN
77914 IKFDC=IDC
77915 GOTO 700
77916 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
77917 DO 680 I=1,NDS
77918 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
77919 IKFDC=IDC
77920 GOTO 700
77921 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
77922 GOTO 690
77923 ENDIF
77924 680 CONTINUE
77925 IKFDC=-IDC
77926 GOTO 700
77927 ENDIF
77928 690 CONTINUE
77929 IKFDC=NKFDC+1
77930 700 IF(IKFDC.LT.0) THEN
77931 IKFDC=-IKFDC
77932 ELSEIF(NKFDC.GE.200) THEN
77933 NREDC=NREDC+1
77934 RETURN
77935 ELSE
77936 DO 720 IDC=NKFDC,IKFDC,-1
77937 NPDC(IDC+1)=NPDC(IDC)
77938 DO 710 I=0,8
77939 KFDC(IDC+1,I)=KFDC(IDC,I)
77940 710 CONTINUE
77941 720 CONTINUE
77942 NKFDC=NKFDC+1
77943 KFDC(IKFDC,0)=NDS
77944 DO 730 I=1,NDS
77945 KFDC(IKFDC,I)=KFDM(I)
77946 730 CONTINUE
77947 NPDC(IKFDC)=0
77948 ENDIF
77949 NPDC(IKFDC)=NPDC(IKFDC)+1
77950
77951C...Write statistics on decay channels.
77952 ELSEIF(MTABU.EQ.52) THEN
77953 FAC=1D0/MAX(1,NEVDC)
77954 WRITE(MSTU(11),5900) NEVDC
77955 DO 750 IDC=1,NKFDC
77956 DO 740 I=1,KFDC(IDC,0)
77957 KFM=KFDC(IDC,I)
77958 KF=(KFM+1)/2
77959 IF(2*KF.NE.KFM) KF=-KF
77960 CALL PYNAME(KF,CHAU)
77961 CHDC(I)=CHAU(1:12)
77962 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
77963 740 CONTINUE
77964 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
77965 750 CONTINUE
77966 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
77967
77968C...Copy statistics on decay channels into /PYJETS/.
77969 ELSEIF(MTABU.EQ.53) THEN
77970 FAC=1D0/MAX(1,NEVDC)
77971 DO 780 IDC=1,NKFDC
77972 K(IDC,1)=32
77973 K(IDC,2)=99
77974 K(IDC,3)=0
77975 K(IDC,4)=0
77976 K(IDC,5)=KFDC(IDC,0)
77977 DO 760 J=1,5
77978 P(IDC,J)=0D0
77979 V(IDC,J)=0D0
77980 760 CONTINUE
77981 DO 770 I=1,KFDC(IDC,0)
77982 KFM=KFDC(IDC,I)
77983 KF=(KFM+1)/2
77984 IF(2*KF.NE.KFM) KF=-KF
77985 IF(I.LE.5) P(IDC,I)=KF
77986 IF(I.GE.6) V(IDC,I-5)=KF
77987 770 CONTINUE
77988 V(IDC,5)=FAC*NPDC(IDC)
77989 780 CONTINUE
77990 N=NKFDC
77991 DO 790 J=1,5
77992 K(N+1,J)=0
77993 P(N+1,J)=0D0
77994 V(N+1,J)=0D0
77995 790 CONTINUE
77996 K(N+1,1)=32
77997 K(N+1,2)=99
77998 K(N+1,5)=NEVDC
77999 V(N+1,5)=FAC*NREDC
78000 MSTU(3)=1
78001 ENDIF
78002
78003C...Format statements for output on unit MSTU(11) (default 6).
78004 5000 FORMAT(///20X,'Event statistics - initial state'/
78005 &20X,'based on an analysis of ',I6,' events'//
78006 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
78007 &'according to fragmenting system multiplicity'/
78008 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
78009 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
78010 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
78011 5200 FORMAT(///20X,'Event statistics - final state'/
78012 &20X,'based on an analysis of ',I7,' events'//
78013 &5X,'Mean primary multiplicity =',F10.4/
78014 &5X,'Mean final multiplicity =',F10.4/
78015 &5X,'Mean charged multiplicity =',F10.4//
78016 &5X,'Number of particles produced per event (directly and via ',
78017 &'decays/branchings)'/
78018 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
78019 &8X,'Total'/35X,'prim seco prim seco'/)
78020 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
78021 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
78022 &20X,'based on an analysis of ',I6,' events'//
78023 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
78024 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
78025 5500 FORMAT(10X)
78026 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
78027 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
78028 &20X,'based on an analysis of ',I6,' events'//
78029 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
78030 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
78031 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
78032 5900 FORMAT(///20X,'Decay channel analysis - final state'/
78033 &20X,'based on an analysis of ',I6,' events'//
78034 &2X,'Probability',10X,'Complete final state'/)
78035 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
78036 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
78037 &'or table overflow)')
78038
78039 RETURN
78040 END
78041
78042C*********************************************************************
78043
78044C...PYEEVT
78045C...Handles the generation of an e+e- annihilation jet event.
78046
78047 SUBROUTINE PYEEVT(KFL,ECM)
78048
78049C...Double precision and integer declarations.
78050 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78051 IMPLICIT INTEGER(I-N)
78052 INTEGER PYK,PYCHGE,PYCOMP
78053C...Commonblocks.
78054 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
78055 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78056 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
78057 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
78058
78059C...Check input parameters.
78060 IF(MSTU(12).NE.12345) CALL PYLIST(0)
78061 IF(KFL.LT.0.OR.KFL.GT.8) THEN
78062 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
78063 IF(MSTU(21).GE.1) RETURN
78064 ENDIF
78065 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
78066 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
78067 IF(ECM.LT.ECMMIN) THEN
78068 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
78069 IF(MSTU(21).GE.1) RETURN
78070 ENDIF
78071
78072C...Check consistency of MSTJ options set.
78073 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
78074 CALL PYERRM(6,
78075 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
78076 MSTJ(110)=1
78077 ENDIF
78078 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
78079 CALL PYERRM(6,
78080 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
78081 MSTJ(111)=0
78082 ENDIF
78083
78084C...Initialize alpha_strong and total cross-section.
78085 MSTU(111)=MSTJ(108)
78086 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
78087 &MSTU(111)=1
78088 PARU(112)=PARJ(121)
78089 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
78090 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
78091 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
78092 &XTOT)
78093 IF(MSTJ(116).GE.3) MSTJ(116)=1
78094 PARJ(171)=0D0
78095
78096C...Add initial e+e- to event record (documentation only).
78097 NTRY=0
78098 100 NTRY=NTRY+1
78099 IF(NTRY.GT.100) THEN
78100 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
78101 RETURN
78102 ENDIF
78103 MSTU(24)=0
78104 NC=0
78105 IF(MSTJ(115).GE.2) THEN
78106 NC=NC+2
78107 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
78108 K(NC-1,1)=21
78109 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
78110 K(NC,1)=21
78111 ENDIF
78112
78113C...Radiative photon (in initial state).
78114 MK=0
78115 ECMC=ECM
78116 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
78117 &THEK,PHIK,ALPK)
78118 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
78119 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
78120 NC=NC+1
78121 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
78122 K(NC,3)=MIN(MSTJ(115)/2,1)
78123 ENDIF
78124
78125C...Virtual exchange boson (gamma or Z0).
78126 IF(MSTJ(115).GE.3) THEN
78127 NC=NC+1
78128 KF=22
78129 IF(MSTJ(102).EQ.2) KF=23
78130 MSTU10=MSTU(10)
78131 MSTU(10)=1
78132 P(NC,5)=ECMC
78133 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
78134 K(NC,1)=21
78135 K(NC,3)=1
78136 MSTU(10)=MSTU10
78137 ENDIF
78138
78139C...Choice of flavour and jet configuration.
78140 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
78141 IF(KFLC.EQ.0) GOTO 100
78142 CALL PYXJET(ECMC,NJET,CUT)
78143 KFLN=21
78144 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
78145 &X12,X14)
78146 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
78147 IF(NJET.EQ.2) MSTJ(120)=1
78148
78149C...Fill jet configuration and origin.
78150 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
78151 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
78152 &ECMC)
78153 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
78154 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
78155 &-KFLC,ECMC,X1,X2,X4,X12,X14)
78156 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
78157 &-KFLC,ECMC,X1,X2,X4,X12,X14)
78158 IF(MSTU(24).NE.0) GOTO 100
78159 DO 110 IP=NC+1,N
78160 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
78161 110 CONTINUE
78162
78163C...Angular orientation according to matrix element.
78164 IF(MSTJ(106).EQ.1) THEN
78165 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
78166 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
78167 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
78168 ENDIF
78169
78170C...Rotation and boost from radiative photon.
78171 IF(MK.EQ.1) THEN
78172 DBEK=-PAK/(ECM-PAK)
78173 NMIN=NC+1-MSTJ(115)/3
78174 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
78175 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
78176 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
78177 ENDIF
78178
78179C...Generate parton shower. Rearrange along strings and check.
78180 IF(MSTJ(101).EQ.5) THEN
78181 CALL PYSHOW(N-1,N,ECMC)
78182 MSTJ14=MSTJ(14)
78183 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
78184 IF(MSTJ(105).GE.0) MSTU(28)=0
78185 CALL PYPREP(0)
78186 MSTJ(14)=MSTJ14
78187 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
78188 ENDIF
78189
78190C...Fragmentation/decay generation. Information for PYTABU.
78191 IF(MSTJ(105).EQ.1) CALL PYEXEC
78192 MSTU(161)=KFLC
78193 MSTU(162)=-KFLC
78194
78195 RETURN
78196 END
78197
78198C*********************************************************************
78199
78200C...PYXTEE
78201C...Calculates total cross-section, including initial state
78202C...radiation effects.
78203
78204 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
78205
78206C...Double precision and integer declarations.
78207 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78208 IMPLICIT INTEGER(I-N)
78209 INTEGER PYK,PYCHGE,PYCOMP
78210C...Commonblocks.
78211 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78212 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
78213 SAVE /PYDAT1/,/PYDAT2/
78214
78215C...Status, (optimized) Q^2 scale, alpha_strong.
78216 PARJ(151)=ECM
78217 MSTJ(119)=10*MSTJ(102)+KFL
78218 IF(MSTJ(111).EQ.0) THEN
78219 Q2R=ECM**2
78220 ELSEIF(MSTU(111).EQ.0) THEN
78221 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
78222 & ((33D0-2D0*MSTU(112))*PARU(111)))))
78223 Q2R=PARJ(168)*ECM**2
78224 ELSE
78225 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
78226 & (2D0*PARU(112)/ECM)**2))
78227 Q2R=PARJ(168)*ECM**2
78228 ENDIF
78229 ALSPI=PYALPS(Q2R)/PARU(1)
78230
78231C...QCD corrections factor in R.
78232 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
78233 RQCD=1D0
78234 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
78235 RQCD=1D0+ALSPI
78236 ELSEIF(MSTJ(109).EQ.0) THEN
78237 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
78238 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
78239 & LOG(PARJ(168))*ALSPI**2)
78240 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
78241 RQCD=1D0+(3D0/4D0)*ALSPI
78242 ELSE
78243 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
78244 ENDIF
78245
78246C...Calculate Z0 width if default value not acceptable.
78247 IF(MSTJ(102).GE.3) THEN
78248 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
78249 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
78250 DO 100 KFLC=5,6
78251 VQ=1D0
78252 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
78253 & (2D0*PYMASS(KFLC)/ ECM)**2))
78254 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
78255 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
78256 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
78257 100 CONTINUE
78258 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
78259 & (1D0-PARU(102)))
78260 ENDIF
78261
78262C...Calculate propagator and related constants for QFD case.
78263 POLL=1D0-PARJ(131)*PARJ(132)
78264 IF(MSTJ(102).GE.2) THEN
78265 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
78266 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
78267 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
78268 VE=4D0*PARU(102)-1D0
78269 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
78270 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
78271 HF1I=SFI*SF1I
78272 HF1W=SFW*SF1W
78273 ENDIF
78274
78275C...Loop over different flavours: charge, velocity.
78276 RTOT=0D0
78277 RQQ=0D0
78278 RQV=0D0
78279 RVA=0D0
78280 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
78281 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
78282 MSTJ(93)=1
78283 PMQ=PYMASS(KFLC)
78284 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
78285 QF=KCHG(KFLC,1)/3D0
78286 VQ=1D0
78287 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
78288
78289C...Calculate R and sum of charges for QED or QFD case.
78290 RQQ=RQQ+3D0*QF**2*POLL
78291 IF(MSTJ(102).LE.1) THEN
78292 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
78293 ELSE
78294 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
78295 RQV=RQV-6D0*QF*VF*SF1I
78296 RVA=RVA+3D0*(VF**2+1D0)*SF1W
78297 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
78298 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
78299 ENDIF
78300 110 CONTINUE
78301 RSUM=RQQ
78302 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
78303
78304C...Calculate cross-section, including QCD corrections.
78305 PARJ(141)=RQQ
78306 PARJ(142)=RTOT
78307 PARJ(143)=RTOT*RQCD
78308 PARJ(144)=PARJ(143)
78309 PARJ(145)=PARJ(141)*86.8D0/ECM**2
78310 PARJ(146)=PARJ(142)*86.8D0/ECM**2
78311 PARJ(147)=PARJ(143)*86.8D0/ECM**2
78312 PARJ(148)=PARJ(147)
78313 PARJ(157)=RSUM*RQCD
78314 PARJ(158)=0D0
78315 PARJ(159)=0D0
78316 XTOT=PARJ(147)
78317 IF(MSTJ(107).LE.0) RETURN
78318
78319C...Virtual cross-section.
78320 XKL=PARJ(135)
78321 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
78322 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
78323 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
78324 &1.526D0*LOG(ECM**2/0.932D0)
78325
78326C...Soft and hard radiative cross-section in QED case.
78327 IF(MSTJ(102).LE.1) THEN
78328 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
78329 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
78330 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
78331
78332C...Soft and hard radiative cross-section in QFD case.
78333 ELSE
78334 SZM=1D0-(PARJ(123)/ECM)**2
78335 SZW=PARJ(123)*PARJ(124)/ECM**2
78336 PARJ(161)=-RQQ/RSUM
78337 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
78338 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
78339 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
78340 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
78341 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
78342 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
78343 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
78344 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
78345 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
78346 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
78347 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
78348 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
78349 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
78350 ENDIF
78351
78352C...Total cross-section and fraction of hard photon events.
78353 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
78354 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
78355 PARJ(144)=PARJ(157)
78356 PARJ(148)=PARJ(144)*86.8D0/ECM**2
78357 XTOT=PARJ(148)
78358
78359 RETURN
78360 END
78361
78362C*********************************************************************
78363
78364C...PYRADK
78365C...Generates initial state photon radiation.
78366
78367 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
78368
78369C...Double precision and integer declarations.
78370 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78371 IMPLICIT INTEGER(I-N)
78372 INTEGER PYK,PYCHGE,PYCOMP
78373C...Commonblocks.
78374 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78375 SAVE /PYDAT1/
78376
78377C...Function: cumulative hard photon spectrum in QFD case.
78378 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
78379 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
78380
78381C...Determine whether radiative photon or not.
78382 MK=0
78383 PAK=0D0
78384 IF(PARJ(160).LT.PYR(0)) RETURN
78385 MK=1
78386
78387C...Photon energy range. Find photon momentum in QED case.
78388 XKL=PARJ(135)
78389 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
78390 IF(MSTJ(102).LE.1) THEN
78391 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
78392 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
78393
78394C...Ditto in QFD case, by numerical inversion of integrated spectrum.
78395 ELSE
78396 SZM=1D0-(PARJ(123)/ECM)**2
78397 SZW=PARJ(123)*PARJ(124)/ECM**2
78398 FXKL=FXK(XKL)
78399 FXKU=FXK(XKU)
78400 FXKD=1D-4*(FXKU-FXKL)
78401 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
78402 NXK=0
78403 110 NXK=NXK+1
78404 XK=0.5D0*(XKL+XKU)
78405 FXKV=FXK(XK)
78406 IF(FXKV.GT.FXKR) THEN
78407 XKU=XK
78408 FXKU=FXKV
78409 ELSE
78410 XKL=XK
78411 FXKL=FXKV
78412 ENDIF
78413 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
78414 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
78415 ENDIF
78416 PAK=0.5D0*ECM*XK
78417
78418C...Photon polar and azimuthal angle.
78419 PME=2D0*(PYMASS(11)/ECM)**2
78420 120 CTHM=PME*(2D0/PME)**PYR(0)
78421 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
78422 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
78423 CTHE=1D0-CTHM
78424 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
78425 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
78426 THEK=PYANGL(CTHE,STHE)
78427 PHIK=PARU(2)*PYR(0)
78428
78429C...Rotation angle for hadronic system.
78430 SGN=1D0
78431 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
78432 &PYR(0)) SGN=-1D0
78433 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
78434 &(2D0-XK*(1D0-SGN*CTHE)))
78435
78436 RETURN
78437 END
78438
78439C*********************************************************************
78440
78441C...PYXKFL
78442C...Selects flavour for produced qqbar pair.
78443
78444 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
78445
78446C...Double precision and integer declarations.
78447 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78448 IMPLICIT INTEGER(I-N)
78449 INTEGER PYK,PYCHGE,PYCOMP
78450C...Commonblocks.
78451 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78452 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
78453 SAVE /PYDAT1/,/PYDAT2/
78454
78455C...Calculate maximum weight in QED or QFD case.
78456 IF(MSTJ(102).LE.1) THEN
78457 RFMAX=4D0/9D0
78458 ELSE
78459 POLL=1D0-PARJ(131)*PARJ(132)
78460 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
78461 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
78462 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
78463 VE=4D0*PARU(102)-1D0
78464 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
78465 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
78466 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
78467 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
78468 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
78469 & 1D0)*HF1W)
78470 ENDIF
78471
78472C...Choose flavour. Gives charge and velocity.
78473 NTRY=0
78474 100 NTRY=NTRY+1
78475 IF(NTRY.GT.100) THEN
78476 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
78477 KFLC=0
78478 RETURN
78479 ENDIF
78480 KFLC=KFL
78481 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
78482 MSTJ(93)=1
78483 PMQ=PYMASS(KFLC)
78484 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
78485 QF=KCHG(KFLC,1)/3D0
78486 VQ=1D0
78487 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
78488
78489C...Calculate weight in QED or QFD case.
78490 IF(MSTJ(102).LE.1) THEN
78491 RF=QF**2
78492 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
78493 ELSE
78494 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
78495 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
78496 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
78497 & VQ**3*HF1W
78498 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
78499 ENDIF
78500
78501C...Weighting or new event (radiative photon). Cross-section update.
78502 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
78503 PARJ(158)=PARJ(158)+1D0
78504 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
78505 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
78506 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
78507 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
78508 PARJ(148)=PARJ(144)*86.8D0/ECM**2
78509
78510 RETURN
78511 END
78512
78513C*********************************************************************
78514
78515C...PYXJET
78516C...Selects number of jets in matrix element approach.
78517
78518 SUBROUTINE PYXJET(ECM,NJET,CUT)
78519
78520C...Double precision and integer declarations.
78521 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78522 IMPLICIT INTEGER(I-N)
78523 INTEGER PYK,PYCHGE,PYCOMP
78524C...Commonblocks.
78525 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78526 SAVE /PYDAT1/
78527C...Local array and data.
78528 DIMENSION ZHUT(5)
78529 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
78530
78531C...Trivial result for two-jets only, including parton shower.
78532 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
78533 CUT=0D0
78534
78535C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
78536 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
78537 CF=4D0/3D0
78538 IF(MSTJ(109).EQ.2) CF=1D0
78539 IF(MSTJ(111).EQ.0) THEN
78540 Q2=ECM**2
78541 Q2R=ECM**2
78542 ELSEIF(MSTU(111).EQ.0) THEN
78543 PARJ(169)=MIN(1D0,PARJ(129))
78544 Q2=PARJ(169)*ECM**2
78545 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
78546 & ((33D0-2D0*MSTU(112))*PARU(111)))))
78547 Q2R=PARJ(168)*ECM**2
78548 ELSE
78549 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
78550 Q2=PARJ(169)*ECM**2
78551 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
78552 & (2D0*PARU(112)/ECM)**2))
78553 Q2R=PARJ(168)*ECM**2
78554 ENDIF
78555
78556C...alpha_strong for R and R itself.
78557 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
78558 IF(IABS(MSTJ(101)).EQ.1) THEN
78559 RQCD=1D0+ALSPI
78560 ELSEIF(MSTJ(109).EQ.0) THEN
78561 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
78562 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
78563 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
78564 ELSE
78565 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
78566 ENDIF
78567
78568C...alpha_strong for jet rate. Initial value for y cut.
78569 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
78570 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
78571 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
78572 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
78573 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
78574
78575C...Parametrization of first order three-jet cross-section.
78576 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
78577 PARJ(152)=0D0
78578 ELSE
78579 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
78580 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
78581 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
78582 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
78583 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
78584 & PARJ(152)=0D0
78585 ENDIF
78586
78587C...Parametrization of second order three-jet cross-section.
78588 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
78589 & CUT.GE.0.25D0) THEN
78590 PARJ(153)=0D0
78591 ELSEIF(MSTJ(110).LE.1) THEN
78592 CT=LOG(1D0/CUT-2D0)
78593 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
78594 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
78595
78596C...Interpolation in second/first order ratio for Zhu parametrization.
78597 ELSEIF(MSTJ(110).EQ.2) THEN
78598 IZA=0
78599 DO 110 IY=1,5
78600 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
78601 110 CONTINUE
78602 IF(IZA.NE.0) THEN
78603 ZHURAT=ZHUT(IZA)
78604 ELSE
78605 IZ=100D0*CUT
78606 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
78607 ENDIF
78608 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
78609 ENDIF
78610
78611C...Shift in second order three-jet cross-section with optimized Q^2.
78612 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
78613 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
78614 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
78615
78616C...Parametrization of second order four-jet cross-section.
78617 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
78618 PARJ(154)=0D0
78619 ELSE
78620 CT=LOG(1D0/CUT-5D0)
78621 IF(CUT.LE.0.018D0) THEN
78622 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
78623 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
78624 & 0.4059D0*CT**2)
78625 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
78626 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
78627 ELSE
78628 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
78629 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
78630 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
78631 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
78632 & 0.002093D0*CT**3)
78633 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
78634 ENDIF
78635 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
78636 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
78637 ENDIF
78638
78639C...If negative three-jet rate, change y' optimization parameter.
78640 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
78641 & PARJ(169).LT.0.99D0) THEN
78642 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
78643 Q2=PARJ(169)*ECM**2
78644 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
78645 GOTO 100
78646 ENDIF
78647
78648C...If too high cross-section, use harder cuts, or fail.
78649 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
78650 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
78651 & PARJ(169).LT.0.99D0) THEN
78652 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
78653 Q2=PARJ(169)*ECM**2
78654 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
78655 GOTO 100
78656 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
78657 CALL PYERRM(26,
78658 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
78659 ENDIF
78660 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
78661 & PARJ(154))**(-1D0/3D0)
78662 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
78663 GOTO 100
78664 ENDIF
78665
78666C...Scalar gluon (first order only).
78667 ELSE
78668 ALSPI=PYALPS(ECM**2)/PARU(1)
78669 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
78670 PARJ(152)=0D0
78671 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
78672 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
78673 PARJ(153)=0D0
78674 PARJ(154)=0D0
78675 ENDIF
78676
78677C...Select number of jets.
78678 PARJ(150)=CUT
78679 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
78680 NJET=2
78681 ELSEIF(MSTJ(101).LE.0) THEN
78682 NJET=MIN(4,2-MSTJ(101))
78683 ELSE
78684 RNJ=PYR(0)
78685 NJET=2
78686 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
78687 IF(PARJ(154).GT.RNJ) NJET=4
78688 ENDIF
78689
78690 RETURN
78691 END
78692
78693C*********************************************************************
78694
78695C...PYX3JT
78696C...Selects the kinematical variables of three-jet events.
78697
78698 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
78699
78700C...Double precision and integer declarations.
78701 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78702 IMPLICIT INTEGER(I-N)
78703 INTEGER PYK,PYCHGE,PYCOMP
78704C...Commonblocks.
78705 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78706 SAVE /PYDAT1/
78707C...Local array.
78708 DIMENSION ZHUP(5,12)
78709
78710C...Coefficients of Zhu second order parametrization.
78711 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
78712 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
78713 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
78714 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
78715 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
78716 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
78717 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
78718 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
78719 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
78720 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
78721 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
78722
78723C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
78724 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
78725 &X**7/49D0
78726
78727C...Event type. Mass effect factors and other common constants.
78728 MSTJ(120)=2
78729 MSTJ(121)=0
78730 PMQ=PYMASS(KFL)
78731 QME=(2D0*PMQ/ECM)**2
78732 IF(MSTJ(109).NE.1) THEN
78733 CUTL=LOG(CUT)
78734 CUTD=LOG(1D0/CUT-2D0)
78735 IF(MSTJ(109).EQ.0) THEN
78736 CF=4D0/3D0
78737 CN=3D0
78738 TR=2D0
78739 WTMX=MIN(20D0,37D0-6D0*CUTD)
78740 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
78741 ELSE
78742 CF=1D0
78743 CN=0D0
78744 TR=12D0
78745 WTMX=0D0
78746 ENDIF
78747
78748C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
78749 ALS2PI=PARU(118)/PARU(2)
78750 WTOPT=0D0
78751 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
78752 & LOG(PARJ(169))*ALS2PI
78753 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
78754
78755C...Choose three-jet events in allowed region.
78756 100 NJET=3
78757 110 Y13L=CUTL+CUTD*PYR(0)
78758 Y23L=CUTL+CUTD*PYR(0)
78759 Y13=EXP(Y13L)
78760 Y23=EXP(Y23L)
78761 Y12=1D0-Y13-Y23
78762 IF(Y12.LE.CUT) GOTO 110
78763 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
78764
78765C...Second order corrections.
78766 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
78767 Y12L=LOG(Y12)
78768 Y13M=LOG(1D0-Y13)
78769 Y23M=LOG(1D0-Y23)
78770 Y12M=LOG(1D0-Y12)
78771 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
78772 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
78773 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
78774 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
78775 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
78776 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
78777 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
78778 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
78779 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
78780 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
78781 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
78782 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
78783 & TR*(2D0*CUTL/3D0-10D0/9D0)+
78784 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
78785 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
78786 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
78787 & Y13*Y23)/(Y12+Y13)**2)/WT1+
78788 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
78789 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
78790 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
78791 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
78792 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
78793 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
78794 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
78795 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
78796 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
78797 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
78798
78799 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
78800C...Second order corrections; Zhu parametrization of ERT.
78801 ZX=(Y23-Y13)**2
78802 ZY=1D0-Y12
78803 IZA=0
78804 DO 120 IY=1,5
78805 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
78806 120 CONTINUE
78807 IF(IZA.NE.0) THEN
78808 IZ=IZA
78809 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
78810 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
78811 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
78812 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
78813 ELSE
78814 IZ=100D0*CUT
78815 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
78816 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
78817 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
78818 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
78819 IZ=IZ+1
78820 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
78821 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
78822 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
78823 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
78824 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
78825 ENDIF
78826 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
78827 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
78828 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
78829 ENDIF
78830
78831C...Impose mass cuts (gives two jets). For fixed jet number new try.
78832 X1=1D0-Y23
78833 X2=1D0-Y13
78834 X3=1D0-Y12
78835 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
78836 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
78837 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
78838 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
78839 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
78840
78841C...Scalar gluon model (first order only, no mass effects).
78842 ELSE
78843 130 NJET=3
78844 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
78845 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
78846 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
78847 X1=1D0-0.5D0*(X3+YD)
78848 X2=1D0-0.5D0*(X3-YD)
78849 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
78850 IF(MSTJ(102).GE.2) THEN
78851 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
78852 & X3**2*PYR(0)) NJET=2
78853 ENDIF
78854 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
78855 ENDIF
78856
78857 RETURN
78858 END
78859
78860C*********************************************************************
78861
78862C...PYX4JT
78863C...Selects the kinematical variables of four-jet events.
78864
78865 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
78866
78867C...Double precision and integer declarations.
78868 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78869 IMPLICIT INTEGER(I-N)
78870 INTEGER PYK,PYCHGE,PYCOMP
78871C...Commonblocks.
78872 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78873 SAVE /PYDAT1/
78874C...Local arrays.
78875 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
78876
78877C...Common constants. Colour factors for QCD and Abelian gluon theory.
78878 PMQ=PYMASS(KFL)
78879 QME=(2D0*PMQ/ECM)**2
78880 CT=LOG(1D0/CUT-5D0)
78881 IF(MSTJ(109).EQ.0) THEN
78882 CF=4D0/3D0
78883 CN=3D0
78884 TR=2.5D0
78885 ELSE
78886 CF=1D0
78887 CN=0D0
78888 TR=15D0
78889 ENDIF
78890
78891C...Choice of process (qqbargg or qqbarqqbar).
78892 100 NJET=4
78893 IT=1
78894 IF(PARJ(155).GT.PYR(0)) IT=2
78895 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
78896 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
78897 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
78898 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
78899 ID=1
78900
78901C...Sample the five kinematical variables (for qqgg preweighted in y34).
78902 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
78903 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
78904 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
78905 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
78906 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
78907 VT=PYR(0)
78908 CP=COS(PARU(1)*PYR(0))
78909 Y14=(Y134-Y34)*VT
78910 Y13=Y134-Y14-Y34
78911 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
78912 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
78913 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
78914 Y23=Y234-Y34-Y24
78915 Y12=1D0-Y134-Y23-Y24
78916 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
78917 Y123=Y12+Y13+Y23
78918 Y124=Y12+Y14+Y24
78919
78920C...Calculate matrix elements for qqgg or qqqq process.
78921 IC=0
78922 WTTOT=0D0
78923 120 IC=IC+1
78924 IF(IT.EQ.1) THEN
78925 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
78926 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
78927 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
78928 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
78929 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
78930 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
78931 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
78932 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
78933 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
78934 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
78935 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
78936 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
78937 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
78938 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
78939 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
78940 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
78941 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
78942 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
78943 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
78944 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
78945 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
78946 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
78947 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
78948 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
78949 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
78950 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
78951 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
78952 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
78953 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
78954 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
78955 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
78956 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
78957 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
78958 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
78959 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
78960 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
78961 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
78962 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
78963 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
78964 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
78965 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
78966 & CN*WTC(IC))/8D0
78967 ELSE
78968 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
78969 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
78970 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
78971 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
78972 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
78973 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
78974 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
78975 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
78976 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
78977 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
78978 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
78979 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
78980 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
78981 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
78982 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
78983 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
78984 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
78985 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
78986 ENDIF
78987
78988C...Permutations of momenta in matrix element. Weighting.
78989 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
78990 YSAV=Y13
78991 Y13=Y14
78992 Y14=YSAV
78993 YSAV=Y23
78994 Y23=Y24
78995 Y24=YSAV
78996 YSAV=Y123
78997 Y123=Y124
78998 Y124=YSAV
78999 ENDIF
79000 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
79001 YSAV=Y13
79002 Y13=Y23
79003 Y23=YSAV
79004 YSAV=Y14
79005 Y14=Y24
79006 Y24=YSAV
79007 YSAV=Y134
79008 Y134=Y234
79009 Y234=YSAV
79010 ENDIF
79011 IF(IC.LE.3) GOTO 120
79012 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
79013 IC=5
79014
79015C...qqgg events: string configuration and event type.
79016 IF(IT.EQ.1) THEN
79017 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
79018 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
79019 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
79020 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
79021 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
79022 IF(ID.EQ.2) GOTO 130
79023 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
79024 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
79025 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
79026 IF(ID.EQ.2) GOTO 130
79027 ENDIF
79028 MSTJ(120)=3
79029 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
79030 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
79031 KFLN=21
79032
79033C...Mass cuts. Kinematical variables out.
79034 IF(Y12.LE.CUT+QME) NJET=2
79035 IF(NJET.EQ.2) GOTO 150
79036 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
79037 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
79038 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
79039 X2=1D0-Y124
79040 X12=(1D0-Q12)*Y13+Q12*Y23
79041 X14=Y12-0.5D0*QME
79042 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
79043
79044C...qqbarqqbar events: string configuration, choose new flavour.
79045 ELSE
79046 IF(ID.EQ.1) THEN
79047 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
79048 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
79049 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
79050 IF(WTR.LT.WTD(4)) ID=4
79051 IF(ID.GE.2) GOTO 130
79052 ENDIF
79053 MSTJ(120)=5
79054 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
79055 140 KFLN=1+INT(5D0*PYR(0))
79056 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
79057 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
79058 IF(KFLN.GT.MSTJ(104)) NJET=2
79059 PMQN=PYMASS(KFLN)
79060 QMEN=(2D0*PMQN/ECM)**2
79061
79062C...Mass cuts. Kinematical variables out.
79063 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
79064 IF(NJET.EQ.2) GOTO 150
79065 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
79066 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
79067 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
79068 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
79069 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
79070 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
79071 & Q13*Y23)
79072 X14=Y24-0.5D0*QME
79073 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
79074 & Q13*Y14)
79075 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
79076 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
79077 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
79078 ENDIF
79079 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
79080
79081 RETURN
79082 END
79083
79084C*********************************************************************
79085
79086C...PYXDIF
79087C...Gives the angular orientation of events.
79088
79089 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
79090
79091C...Double precision and integer declarations.
79092 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79093 IMPLICIT INTEGER(I-N)
79094 INTEGER PYK,PYCHGE,PYCOMP
79095C...Commonblocks.
79096 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
79097 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79098 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
79099 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
79100
79101C...Charge. Factors depending on polarization for QED case.
79102 QF=KCHG(KFL,1)/3D0
79103 POLL=1D0-PARJ(131)*PARJ(132)
79104 POLD=PARJ(132)-PARJ(131)
79105 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
79106 HF1=POLL
79107 HF2=0D0
79108 HF3=PARJ(133)**2
79109 HF4=0D0
79110
79111C...Factors depending on flavour, energy and polarization for QFD case.
79112 ELSE
79113 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
79114 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
79115 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
79116 AE=-1D0
79117 VE=4D0*PARU(102)-1D0
79118 AF=SIGN(1D0,QF)
79119 VF=AF-4D0*QF*PARU(102)
79120 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
79121 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
79122 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
79123 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
79124 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
79125 & SFW*SFF**2*(VE**2-AE**2))
79126 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
79127 & SFF*AE
79128 ENDIF
79129
79130C...Mass factor. Differential cross-sections for two-jet events.
79131 SQ2=SQRT(2D0)
79132 QME=0D0
79133 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
79134 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
79135 IF(NJET.EQ.2) THEN
79136 SIGU=4D0*SQRT(1D0-QME)
79137 SIGL=2D0*QME*SQRT(1D0-QME)
79138 SIGT=0D0
79139 SIGI=0D0
79140 SIGA=0D0
79141 SIGP=4D0
79142
79143C...Kinematical variables. Reduce four-jet event to three-jet one.
79144 ELSE
79145 IF(NJET.EQ.3) THEN
79146 X1=2D0*P(NC+1,4)/ECM
79147 X2=2D0*P(NC+3,4)/ECM
79148 ELSE
79149 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
79150 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
79151 X1=2D0*P(NC+1,4)/ECMR
79152 X2=2D0*P(NC+4,4)/ECMR
79153 ENDIF
79154
79155C...Differential cross-sections for three-jet (or reduced four-jet).
79156 XQ=(1D0-X1)/(1D0-X2)
79157 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
79158 ST12=SQRT(1D0-CT12**2)
79159 IF(MSTJ(109).NE.1) THEN
79160 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
79161 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
79162 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
79163 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
79164 & X2)*XQ
79165 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
79166 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
79167 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
79168 SIGA=X2**2*ST12/SQ2
79169 SIGP=2D0*(X1**2-X2**2*CT12)
79170
79171C...Differential cross-sect for scalar gluons (no mass effects).
79172 ELSE
79173 X3=2D0-X1-X2
79174 XT=X2*ST12
79175 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
79176 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
79177 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
79178 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
79179 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
79180 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
79181 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
79182 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
79183 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
79184 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
79185 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
79186 ENDIF
79187 ENDIF
79188
79189C...Upper bounds for differential cross-section.
79190 HF1A=ABS(HF1)
79191 HF2A=ABS(HF2)
79192 HF3A=ABS(HF3)
79193 HF4A=ABS(HF4)
79194 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
79195 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
79196 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
79197 &2D0*HF2A*ABS(SIGP)
79198
79199C...Generate angular orientation according to differential cross-sect.
79200 100 CHI=PARU(2)*PYR(0)
79201 CTHE=2D0*PYR(0)-1D0
79202 PHI=PARU(2)*PYR(0)
79203 CCHI=COS(CHI)
79204 SCHI=SIN(CHI)
79205 C2CHI=COS(2D0*CHI)
79206 S2CHI=SIN(2D0*CHI)
79207 THE=ACOS(CTHE)
79208 STHE=SIN(THE)
79209 C2PHI=COS(2D0*(PHI-PARJ(134)))
79210 S2PHI=SIN(2D0*(PHI-PARJ(134)))
79211 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
79212 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
79213 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
79214 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
79215 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
79216 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
79217 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
79218 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
79219
79220 RETURN
79221 END
79222
79223C*********************************************************************
79224
79225C...PYONIA
79226C...Generates Upsilon and toponium decays into three gluons
79227C...or two gluons and a photon.
79228
79229 SUBROUTINE PYONIA(KFL,ECM)
79230
79231C...Double precision and integer declarations.
79232 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79233 IMPLICIT INTEGER(I-N)
79234 INTEGER PYK,PYCHGE,PYCOMP
79235C...Commonblocks.
79236 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
79237 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79238 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
79239 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
79240
79241C...Printout. Check input parameters.
79242 IF(MSTU(12).NE.12345) CALL PYLIST(0)
79243 IF(KFL.LT.0.OR.KFL.GT.8) THEN
79244 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
79245 IF(MSTU(21).GE.1) RETURN
79246 ENDIF
79247 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
79248 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
79249 IF(MSTU(21).GE.1) RETURN
79250 ENDIF
79251
79252C...Initial e+e- and onium state (optional).
79253 NC=0
79254 IF(MSTJ(115).GE.2) THEN
79255 NC=NC+2
79256 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
79257 K(NC-1,1)=21
79258 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
79259 K(NC,1)=21
79260 ENDIF
79261 KFLC=IABS(KFL)
79262 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
79263 NC=NC+1
79264 KF=110*KFLC+3
79265 MSTU10=MSTU(10)
79266 MSTU(10)=1
79267 P(NC,5)=ECM
79268 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
79269 K(NC,1)=21
79270 K(NC,3)=1
79271 MSTU(10)=MSTU10
79272 ENDIF
79273
79274C...Choose x1 and x2 according to matrix element.
79275 NTRY=0
79276 100 X1=PYR(0)
79277 X2=PYR(0)
79278 X3=2D0-X1-X2
79279 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
79280 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
79281 NTRY=NTRY+1
79282 NJET=3
79283 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
79284 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
79285
79286C...Photon-gluon-gluon events. Small system modifications. Jet origin.
79287 MSTU(111)=MSTJ(108)
79288 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
79289 &MSTU(111)=1
79290 PARU(112)=PARJ(121)
79291 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
79292 QF=0D0
79293 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
79294 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
79295 MK=0
79296 ECMC=ECM
79297 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
79298 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
79299 & NJET=2
79300 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
79301 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
79302 ELSE
79303 MK=1
79304 ECMC=SQRT(1D0-X1)*ECM
79305 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
79306 K(NC+1,1)=1
79307 K(NC+1,2)=22
79308 K(NC+1,4)=0
79309 K(NC+1,5)=0
79310 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
79311 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
79312 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
79313 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
79314 NJET=2
79315 IF(ECMC.LT.4D0*PARJ(127)) THEN
79316 MSTU10=MSTU(10)
79317 MSTU(10)=1
79318 P(NC+2,5)=ECMC
79319 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
79320 MSTU(10)=MSTU10
79321 NJET=0
79322 ENDIF
79323 ENDIF
79324 DO 110 IP=NC+1,N
79325 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
79326 110 CONTINUE
79327
79328C...Differential cross-sections. Upper limit for cross-section.
79329 IF(MSTJ(106).EQ.1) THEN
79330 SQ2=SQRT(2D0)
79331 HF1=1D0-PARJ(131)*PARJ(132)
79332 HF3=PARJ(133)**2
79333 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
79334 ST13=SQRT(1D0-CT13**2)
79335 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
79336 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
79337 SIGT=0.5D0*SIGL
79338 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
79339 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
79340 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
79341
79342C...Angular orientation of event.
79343 120 CHI=PARU(2)*PYR(0)
79344 CTHE=2D0*PYR(0)-1D0
79345 PHI=PARU(2)*PYR(0)
79346 CCHI=COS(CHI)
79347 SCHI=SIN(CHI)
79348 C2CHI=COS(2D0*CHI)
79349 S2CHI=SIN(2D0*CHI)
79350 THE=ACOS(CTHE)
79351 STHE=SIN(THE)
79352 C2PHI=COS(2D0*(PHI-PARJ(134)))
79353 S2PHI=SIN(2D0*(PHI-PARJ(134)))
79354 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
79355 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
79356 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
79357 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
79358 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
79359 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
79360 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
79361 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
79362 ENDIF
79363
79364C...Generate parton shower. Rearrange along strings and check.
79365 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
79366 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
79367 MSTJ14=MSTJ(14)
79368 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
79369 IF(MSTJ(105).GE.0) MSTU(28)=0
79370 CALL PYPREP(0)
79371 MSTJ(14)=MSTJ14
79372 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
79373 ENDIF
79374
79375C...Generate fragmentation. Information for PYTABU:
79376 IF(MSTJ(105).EQ.1) CALL PYEXEC
79377 MSTU(161)=110*KFLC+3
79378 MSTU(162)=0
79379
79380 RETURN
79381 END
79382
79383C*********************************************************************
79384
79385C...PYBOOK
79386C...Books a histogram.
79387
79388 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
79389
79390C...Double precision declaration.
79391 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79392 IMPLICIT INTEGER(I-N)
79393C...Commonblock.
79394 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79395 SAVE /PYBINS/
79396C...Local character variables.
79397 CHARACTER TITLE*(*), TITFX*60
79398
79399C...Check that input is sensible. Find initial address in memory.
79400 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
79401 &'(PYBOOK:) not allowed histogram number')
79402 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
79403 &'(PYBOOK:) not allowed number of bins')
79404 IF(XL.GE.XU) CALL PYERRM(28,
79405 &'(PYBOOK:) x limits in wrong order')
79406 INDX(ID)=IHIST(4)
79407 IHIST(4)=IHIST(4)+28+NX
79408 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
79409 &'(PYBOOK:) out of histogram space')
79410 IS=INDX(ID)
79411
79412C...Store histogram size and reset contents.
79413 BIN(IS+1)=NX
79414 BIN(IS+2)=XL
79415 BIN(IS+3)=XU
79416 BIN(IS+4)=(XU-XL)/NX
79417 CALL PYNULL(ID)
79418
79419C...Store title by conversion to integer to double precision.
79420 TITFX=TITLE//' '
79421 DO 100 IT=1,20
79422 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
79423 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
79424 100 CONTINUE
79425
79426 RETURN
79427 END
79428
79429C*********************************************************************
79430
79431C...PYFILL
79432C...Fills entry in histogram.
79433
79434 SUBROUTINE PYFILL(ID,X,W)
79435
79436C...Double precision declaration.
79437 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79438 IMPLICIT INTEGER(I-N)
79439C...Commonblock.
79440 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79441 SAVE /PYBINS/
79442
79443C...Find initial address in memory. Increase number of entries.
79444 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
79445 &'(PYFILL:) not allowed histogram number')
79446 IS=INDX(ID)
79447 IF(IS.EQ.0) CALL PYERRM(28,
79448 &'(PYFILL:) filling unbooked histogram')
79449 BIN(IS+5)=BIN(IS+5)+1D0
79450
79451C...Find bin in x, including under/overflow, and fill.
79452 IF(X.LT.BIN(IS+2)) THEN
79453 BIN(IS+6)=BIN(IS+6)+W
79454 ELSEIF(X.GE.BIN(IS+3)) THEN
79455 BIN(IS+8)=BIN(IS+8)+W
79456 ELSE
79457 BIN(IS+7)=BIN(IS+7)+W
79458 IX=(X-BIN(IS+2))/BIN(IS+4)
79459 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
79460 BIN(IS+9+IX)=BIN(IS+9+IX)+W
79461 ENDIF
79462
79463 RETURN
79464 END
79465
79466C*********************************************************************
79467
79468C...PYFACT
79469C...Multiplies histogram contents by factor.
79470
79471 SUBROUTINE PYFACT(ID,F)
79472
79473C...Double precision declaration.
79474 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79475 IMPLICIT INTEGER(I-N)
79476C...Commonblock.
79477 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79478 SAVE /PYBINS/
79479
79480C...Find initial address in memory. Multiply all contents bins.
79481 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
79482 &'(PYFACT:) not allowed histogram number')
79483 IS=INDX(ID)
79484 IF(IS.EQ.0) CALL PYERRM(28,
79485 &'(PYFACT:) scaling unbooked histogram')
79486 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
79487 BIN(IX)=F*BIN(IX)
79488 100 CONTINUE
79489
79490 RETURN
79491 END
79492
79493C*********************************************************************
79494
79495C...PYOPER
79496C...Performs operations between histograms.
79497
79498 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
79499
79500C...Double precision declaration.
79501 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79502 IMPLICIT INTEGER(I-N)
79503C...Commonblock.
79504 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79505 SAVE /PYBINS/
79506C...Character variable.
79507 CHARACTER OPER*(*)
79508
79509C...Find initial addresses in memory, and histogram size.
79510 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
79511 &'(PYFACT:) not allowed histogram number')
79512 IS1=INDX(ID1)
79513 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
79514 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
79515 NX=NINT(BIN(IS3+1))
79516 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
79517
79518C...Update info on number of histogram entries.
79519 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
79520 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
79521 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
79522 BIN(IS3+5)=BIN(IS1+5)
79523 ENDIF
79524
79525C...Operations on pair of histograms: addition, subtraction,
79526C...multiplication, division.
79527 IF(OPER.EQ.'+') THEN
79528 DO 100 IX=6,8+NX
79529 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
79530 100 CONTINUE
79531 ELSEIF(OPER.EQ.'-') THEN
79532 DO 110 IX=6,8+NX
79533 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
79534 110 CONTINUE
79535 ELSEIF(OPER.EQ.'*') THEN
79536 DO 120 IX=6,8+NX
79537 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
79538 120 CONTINUE
79539 ELSEIF(OPER.EQ.'/') THEN
79540 DO 130 IX=6,8+NX
79541 FA2=F2*BIN(IS2+IX)
79542 IF(ABS(FA2).LE.1D-20) THEN
79543 BIN(IS3+IX)=0D0
79544 ELSE
79545 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
79546 ENDIF
79547 130 CONTINUE
79548
79549C...Operations on single histogram: multiplication+addition,
79550C...square root+addition, logarithm+addition.
79551 ELSEIF(OPER.EQ.'A') THEN
79552 DO 140 IX=6,8+NX
79553 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
79554 140 CONTINUE
79555 ELSEIF(OPER.EQ.'S') THEN
79556 DO 150 IX=6,8+NX
79557 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
79558 150 CONTINUE
79559 ELSEIF(OPER.EQ.'L') THEN
79560 ZMIN=1D20
79561 DO 160 IX=9,8+NX
79562 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
79563 & ZMIN=0.8D0*BIN(IS1+IX)
79564 160 CONTINUE
79565 DO 170 IX=6,8+NX
79566 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
79567 170 CONTINUE
79568
79569C...Operation on two or three histograms: average and
79570C...standard deviation.
79571 ELSEIF(OPER.EQ.'M') THEN
79572 DO 180 IX=6,8+NX
79573 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
79574 BIN(IS2+IX)=0D0
79575 ELSE
79576 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
79577 ENDIF
79578 IF(ID3.NE.0) THEN
79579 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
79580 BIN(IS3+IX)=0D0
79581 ELSE
79582 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
79583 & BIN(IS2+IX)**2))
79584 ENDIF
79585 ENDIF
79586 BIN(IS1+IX)=F1*BIN(IS1+IX)
79587 180 CONTINUE
79588 ENDIF
79589
79590 RETURN
79591 END
79592
79593C*********************************************************************
79594
79595C...PYHIST
79596C...Prints and resets all histograms.
79597
79598 SUBROUTINE PYHIST
79599
79600C...Double precision declaration.
79601 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79602 IMPLICIT INTEGER(I-N)
79603C...Commonblock.
79604 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79605 SAVE /PYBINS/
79606
79607C...Loop over histograms, print and reset used ones.
79608 DO 100 ID=1,IHIST(1)
79609 IS=INDX(ID)
79610 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
79611 CALL PYPLOT(ID)
79612 CALL PYNULL(ID)
79613 ENDIF
79614 100 CONTINUE
79615
79616 RETURN
79617 END
79618
79619C*********************************************************************
79620
79621C...PYPLOT
79622C...Prints a histogram (but does not reset it).
79623
79624 SUBROUTINE PYPLOT(ID)
79625
79626C...Double precision declaration.
79627 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79628 IMPLICIT INTEGER(I-N)
79629C...Commonblocks.
79630 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79631 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79632 SAVE /PYDAT1/,/PYBINS/
79633C...Local arrays and character variables.
79634 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
79635 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
79636
79637C...Steps in histogram scale. Character sequence.
79638 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
79639 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
79640
79641C...Find initial address in memory; skip if empty histogram.
79642 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
79643 IS=INDX(ID)
79644 IF(IS.EQ.0) RETURN
79645 IF(NINT(BIN(IS+5)).LE.0) THEN
79646 WRITE(MSTU(11),5000) ID
79647 RETURN
79648 ENDIF
79649
79650C...Number of histogram lines and x bins.
79651 LIN=IHIST(3)-18
79652 NX=NINT(BIN(IS+1))
79653
79654C...Extract title by conversion from double precision via integer.
79655 DO 100 IT=1,20
79656 IEQ=NINT(BIN(IS+8+NX+IT))
79657 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
79658 & //CHAR(MOD(IEQ,256))
79659 100 CONTINUE
79660
79661C...Find time; print title.
79662 CALL PYTIME(IDATI)
79663 IF(IDATI(1).GT.0) THEN
79664 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
79665 ELSE
79666 WRITE(MSTU(11),5200) ID, TITLE
79667 ENDIF
79668
79669C...Find minimum and maximum bin content.
79670 YMIN=BIN(IS+9)
79671 YMAX=BIN(IS+9)
79672 DO 110 IX=IS+10,IS+8+NX
79673 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
79674 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
79675 110 CONTINUE
79676
79677C...Determine scale and step size for y axis.
79678 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
79679 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
79680 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
79681 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
79682 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
79683 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
79684 DELY=DYAC(1)
79685 DO 120 IDEL=1,9
79686 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
79687 120 CONTINUE
79688 DY=DELY*10D0**IPOT
79689
79690C...Convert bin contents to integer form; fractional fill in top row.
79691 DO 130 IX=1,NX
79692 CTA=ABS(BIN(IS+8+IX))/DY
79693 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
79694 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
79695 130 CONTINUE
79696 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
79697 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
79698
79699C...Print histogram row by row.
79700 DO 150 IR=IRMA,IRMI,-1
79701 IF(IR.EQ.0) GOTO 150
79702 OUT=' '
79703 DO 140 IX=1,NX
79704 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
79705 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
79706 140 CONTINUE
79707 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
79708 150 CONTINUE
79709
79710C...Print sign and value of bin contents.
79711 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
79712 OUT=' '
79713 DO 160 IX=1,NX
79714 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
79715 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
79716 160 CONTINUE
79717 WRITE(MSTU(11),5400) OUT
79718 DO 180 IR=4,1,-1
79719 DO 170 IX=1,NX
79720 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
79721 170 CONTINUE
79722 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
79723 180 CONTINUE
79724
79725C...Print sign and value of lower bin edge.
79726 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
79727 & 10.0001D0)-10
79728 OUT=' '
79729 DO 190 IX=1,NX
79730 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
79731 & OUT(IX:IX)=CHA(11)
79732 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
79733 190 CONTINUE
79734 WRITE(MSTU(11),5600) OUT
79735 DO 210 IR=3,1,-1
79736 DO 200 IX=1,NX
79737 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
79738 200 CONTINUE
79739 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
79740 210 CONTINUE
79741 ENDIF
79742
79743C...Calculate and print statistics.
79744 CSUM=0D0
79745 CXSUM=0D0
79746 CXXSUM=0D0
79747 DO 220 IX=1,NX
79748 CTA=ABS(BIN(IS+8+IX))
79749 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
79750 CSUM=CSUM+CTA
79751 CXSUM=CXSUM+CTA*X
79752 CXXSUM=CXXSUM+CTA*X**2
79753 220 CONTINUE
79754 XMEAN=CXSUM/MAX(CSUM,1D-20)
79755 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
79756 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
79757 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
79758
79759C...Formats for output.
79760 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
79761 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
79762 &I2,':',I2/)
79763 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
79764 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
79765 5400 FORMAT(/8X,'Contents',3X,A100)
79766 5500 FORMAT(9X,'*10**',I2,3X,A100)
79767 5600 FORMAT(/8X,'Low edge',3X,A100)
79768 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
79769 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
79770 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
79771
79772 RETURN
79773 END
79774
79775C*********************************************************************
79776
79777C...PYNULL
79778C...Resets bin contents of a histogram.
79779
79780 SUBROUTINE PYNULL(ID)
79781
79782C...Double precision declaration.
79783 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79784 IMPLICIT INTEGER(I-N)
79785C...Commonblock.
79786 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79787 SAVE /PYBINS/
79788
79789 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
79790 IS=INDX(ID)
79791 IF(IS.EQ.0) RETURN
79792 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
79793 BIN(IX)=0D0
79794 100 CONTINUE
79795
79796 RETURN
79797 END
79798
79799C*********************************************************************
79800
79801C...PYDUMP
79802C...Dumps histogram contents on file for reading by other program.
79803C...Can also read back own dump.
79804
79805 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
79806
79807C...Double precision declaration.
79808 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79809 IMPLICIT INTEGER(I-N)
79810C...Commonblock.
79811 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79812 SAVE /PYBINS/
79813C...Local arrays and character variables.
79814 DIMENSION IHI(*),ISS(100),VAL(5)
79815 CHARACTER TITLE*60,FORMAT*13
79816
79817C...Dump all histograms that have been booked,
79818C...including titles and ranges, one after the other.
79819 IF(MDUMP.EQ.1) THEN
79820
79821C...Loop over histograms and find which are wanted and booked.
79822 IF(NHI.LE.0) THEN
79823 NW=IHIST(1)
79824 ELSE
79825 NW=NHI
79826 ENDIF
79827 DO 130 IW=1,NW
79828 IF(NHI.EQ.0) THEN
79829 ID=IW
79830 ELSE
79831 ID=IHI(IW)
79832 ENDIF
79833 IS=INDX(ID)
79834 IF(IS.NE.0) THEN
79835
79836C...Write title, histogram size, filling statistics.
79837 NX=NINT(BIN(IS+1))
79838 DO 100 IT=1,20
79839 IEQ=NINT(BIN(IS+8+NX+IT))
79840 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
79841 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
79842 100 CONTINUE
79843 WRITE(LFN,5100) ID,TITLE
79844 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
79845 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
79846 & BIN(IS+8)
79847
79848
79849C...Write histogram contents, in groups of five.
79850 DO 120 IXG=1,(NX+4)/5
79851 DO 110 IXV=1,5
79852 IX=5*IXG+IXV-5
79853 IF(IX.LE.NX) THEN
79854 VAL(IXV)=BIN(IS+8+IX)
79855 ELSE
79856 VAL(IXV)=0D0
79857 ENDIF
79858 110 CONTINUE
79859 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
79860 120 CONTINUE
79861
79862C...Go to next histogram; finish.
79863 ELSEIF(NHI.GT.0) THEN
79864 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
79865 ENDIF
79866 130 CONTINUE
79867
79868C...Read back in histograms dumped MDUMP=1.
79869 ELSEIF(MDUMP.EQ.2) THEN
79870
79871C...Read histogram number, title and range, and book.
79872 140 READ(LFN,5100,END=170) ID,TITLE
79873 READ(LFN,5200) NX,XL,XU
79874 CALL PYBOOK(ID,TITLE,NX,XL,XU)
79875 IS=INDX(ID)
79876
79877C...Read filling statistics.
79878 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
79879 BIN(IS+5)=DBLE(NENTRY)
79880
79881C...Read histogram contents, in groups of five.
79882 DO 160 IXG=1,(NX+4)/5
79883 READ(LFN,5400) (VAL(IXV),IXV=1,5)
79884 DO 150 IXV=1,5
79885 IX=5*IXG+IXV-5
79886 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
79887 150 CONTINUE
79888 160 CONTINUE
79889
79890C...Go to next histogram; finish.
79891 GOTO 140
79892 170 CONTINUE
79893
79894C...Write histogram contents in column format,
79895C...convenient e.g. for GNUPLOT input.
79896 ELSEIF(MDUMP.EQ.3) THEN
79897
79898C...Find addresses to wanted histograms.
79899 NSS=0
79900 IF(NHI.LE.0) THEN
79901 NW=IHIST(1)
79902 ELSE
79903 NW=NHI
79904 ENDIF
79905 DO 180 IW=1,NW
79906 IF(NHI.EQ.0) THEN
79907 ID=IW
79908 ELSE
79909 ID=IHI(IW)
79910 ENDIF
79911 IS=INDX(ID)
79912 IF(IS.NE.0.AND.NSS.LT.100) THEN
79913 NSS=NSS+1
79914 ISS(NSS)=IS
79915 ELSEIF(NSS.GE.100) THEN
79916 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
79917 ELSEIF(NHI.GT.0) THEN
79918 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
79919 ENDIF
79920 180 CONTINUE
79921
79922C...Check that they have common number of x bins. Fix format.
79923 NX=NINT(BIN(ISS(1)+1))
79924 DO 190 IW=2,NSS
79925 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
79926 CALL PYERRM(8,'(PYDUMP:) different number of bins')
79927 RETURN
79928 ENDIF
79929 190 CONTINUE
79930 FORMAT='(1P,000E12.4)'
79931 WRITE(FORMAT(5:7),'(I3)') NSS+1
79932
79933C...Write histogram contents; first column x values.
79934 DO 200 IX=1,NX
79935 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
79936 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
79937 200 CONTINUE
79938
79939 ENDIF
79940
79941C...Formats for output.
79942 5100 FORMAT(I5,5X,A60)
79943 5200 FORMAT(I5,1P,2D12.4)
79944 5300 FORMAT(I12,1P,3D12.4)
79945 5400 FORMAT(1P,5D12.4)
79946
79947 RETURN
79948 END
79949
79950C*********************************************************************
79951
79952C...PYSTOP
79953C...Allows users to handle STOP statemens
79954
79955 SUBROUTINE PYSTOP(MCOD)
79956
79957C...Double precision and integer declarations.
79958 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79959 IMPLICIT INTEGER(I-N)
79960 INTEGER PYK,PYCHGE,PYCOMP
79961C...Commonblocks.
79962 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79963 SAVE /PYDAT1/
79964
79965
79966C...Write message, then stop
79967 WRITE(MSTU(11),5000) MCOD
79968 STOP
79969
79970
79971C...Formats for output.
79972 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
79973 END
79974
79975C*********************************************************************
79976
79977C...PYKCUT
79978C...Dummy routine, which the user can replace in order to make cuts on
79979C...the kinematics on the parton level before the matrix elements are
79980C...evaluated and the event is generated. The cross-section estimates
79981C...will automatically take these cuts into account, so the given
79982C...values are for the allowed phase space region only. MCUT=0 means
79983C...that the event has passed the cuts, MCUT=1 that it has failed.
79984
79985 SUBROUTINE PYKCUT(MCUT)
79986
79987C...Double precision and integer declarations.
79988 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79989 IMPLICIT INTEGER(I-N)
79990 INTEGER PYK,PYCHGE,PYCOMP
79991C...Commonblocks.
79992 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79993 COMMON/PYINT1/MINT(400),VINT(400)
79994 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
79995 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
79996
79997C...Set default value (accepting event) for MCUT.
79998 MCUT=0
79999
80000C...Read out subprocess number.
80001 ISUB=MINT(1)
80002 ISTSB=ISET(ISUB)
80003
80004C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
80005 TAU=VINT(21)
80006 YST=VINT(22)
80007 CTH=0D0
80008 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
80009 TAUP=0D0
80010 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
80011
80012C...Calculate x_1, x_2, x_F.
80013 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
80014 X1=SQRT(TAU)*EXP(YST)
80015 X2=SQRT(TAU)*EXP(-YST)
80016 ELSE
80017 X1=SQRT(TAUP)*EXP(YST)
80018 X2=SQRT(TAUP)*EXP(-YST)
80019 ENDIF
80020 XF=X1-X2
80021
80022C...Calculate shat, that, uhat, p_T^2.
80023 SHAT=TAU*VINT(2)
80024 SQM3=VINT(63)
80025 SQM4=VINT(64)
80026 RM3=SQM3/SHAT
80027 RM4=SQM4/SHAT
80028 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
80029 RPTS=4D0*VINT(71)**2/SHAT
80030 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
80031 RM34=2D0*RM3*RM4
80032 RSQM=1D0+RM34
80033 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
80034 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
80035 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
80036 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
80037
80038C...Decisions by user to be put here.
80039
80040C...Stop program if this routine is ever called.
80041C...You should not copy these lines to your own routine.
80042 WRITE(MSTU(11),5000)
80043 CALL PYSTOP(6)
80044
80045C...Format for error printout.
80046 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
80047 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
80048 &1X,'Execution stopped!')
80049
80050 RETURN
80051 END
80052
80053C*********************************************************************
80054
80055C...PYEVWT
80056C...Dummy routine, which the user can replace in order to multiply the
80057C...standard PYTHIA differential cross-section by a process- and
80058C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
80059C...to generation of weighted events, with weight 1/WTXS, while for
80060C...MSTP(142)=2 it corresponds to a modification of the underlying
80061C...physics.
80062
1cdfb96f 80063c SUBROUTINE PYEVWT(WTXS)
92e27c01 80064
80065C...Double precision and integer declarations.
1cdfb96f 80066c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80067c IMPLICIT INTEGER(I-N)
80068c INTEGER PYK,PYCHGE,PYCOMP
92e27c01 80069C...Commonblocks.
1cdfb96f 80070c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80071c COMMON/PYINT1/MINT(400),VINT(400)
80072c COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
80073c SAVE /PYDAT1/,/PYINT1/,/PYINT2/
92e27c01 80074
80075C...Set default weight for WTXS.
1cdfb96f 80076c WTXS=1D0
92e27c01 80077
80078C...Read out subprocess number.
1cdfb96f 80079c ISUB=MINT(1)
80080c ISTSB=ISET(ISUB)
80081c
92e27c01 80082C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
1cdfb96f 80083c TAU=VINT(21)
80084c YST=VINT(22)
80085c CTH=0D0
80086c IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
80087c TAUP=0D0
80088c IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
80089c
92e27c01 80090C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
1cdfb96f 80091c X1=VINT(41)
80092c X2=VINT(42)
80093c XF=X1-X2
80094c SHAT=VINT(44)
80095c THAT=VINT(45)
80096c UHAT=VINT(46)
80097c PT2=VINT(48)
80098c
92e27c01 80099C...Modifications by user to be put here.
80100
80101C...Stop program if this routine is ever called.
80102C...You should not copy these lines to your own routine.
1cdfb96f 80103c WRITE(MSTU(11),5000)
80104c CALL PYSTOP(4)
92e27c01 80105
80106C...Format for error printout.
1cdfb96f 80107c5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
80108c &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
80109c &1X,'Execution stopped!')
92e27c01 80110
1cdfb96f 80111c RETURN
80112c END
92e27c01 80113
80114C*********************************************************************
80115
80116C...UPINIT
80117C...Dummy routine, to be replaced by a user implementing external
80118C...processes. Is supposed to fill the HEPRUP commonblock with info
80119C...on incoming beams and allowed processes.
80120
80121C...New example: handles a standard Les Houches Events File.
80122
64da86aa 80123 SUBROUTINE UPINITD
92e27c01 80124
80125C...Double precision and integer declarations.
80126 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80127 IMPLICIT INTEGER(I-N)
80128
80129C...PYTHIA commonblock: only used to provide read unit MSTP(161).
80130 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80131 SAVE /PYPARS/
80132
80133C...User process initialization commonblock.
80134 INTEGER MAXPUP
80135 PARAMETER (MAXPUP=100)
80136 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
80137 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
80138 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
80139 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
80140 &LPRUP(MAXPUP)
80141 SAVE /HEPRUP/
80142
80143C...Lines to read in assumed never longer than 200 characters.
80144 PARAMETER (MAXLEN=200)
80145 CHARACTER*(MAXLEN) STRING
80146
80147C...Format for reading lines.
80148 CHARACTER*6 STRFMT
80149 STRFMT='(A000)'
80150 WRITE(STRFMT(3:5),'(I3)') MAXLEN
80151
80152C...Loop until finds line beginning with "<init>" or "<init ".
80153 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
80154 IBEG=0
80155 110 IBEG=IBEG+1
80156C...Allow indentation.
80157 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
80158 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
80159 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
80160
80161C...Read first line of initialization info.
80162 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
80163 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
80164
80165C...Read NPRUP subsequent lines with information on each process.
80166 DO 120 IPR=1,NPRUP
80167 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
80168 & XMAXUP(IPR),LPRUP(IPR)
80169 120 CONTINUE
80170 RETURN
80171
80172C...Error exit: give up if initalization does not work.
80173 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
80174 WRITE(*,*) ' Event generation will be stopped.'
80175 CALL PYSTOP(12)
80176
80177 RETURN
80178 END
80179
80180C...Old example: handles a simple Pythia 6.4 initialization file.
80181
80182c SUBROUTINE UPINIT
80183
80184C...Double precision and integer declarations.
80185c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80186c IMPLICIT INTEGER(I-N)
80187
80188C...Commonblocks.
80189c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80190c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80191c SAVE /PYDAT1/,/PYPARS/
80192
80193C...User process initialization commonblock.
80194c INTEGER MAXPUP
80195c PARAMETER (MAXPUP=100)
80196c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
80197c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
80198c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
80199c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
80200c &LPRUP(MAXPUP)
80201c SAVE /HEPRUP/
80202
80203C...Read info from file.
80204c IF(MSTP(161).GT.0) THEN
80205c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
80206c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
80207c DO 100 IPR=1,NPRUP
80208c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
80209c & XMAXUP(IPR),LPRUP(IPR)
80210c 100 CONTINUE
80211c RETURN
80212C...Error or prematurely reached end of file.
80213c 110 WRITE(MSTU(11),5000)
80214c STOP
80215
80216C...Else not implemented.
80217c ELSE
80218c WRITE(MSTU(11),5100)
80219c STOP
80220c ENDIF
80221
80222C...Format for error printout.
80223c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
80224c &1X,'Execution stopped!')
80225c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
80226c &1X,'Dummy routine in PYTHIA file called instead.'/
80227c &1X,'Execution stopped!')
80228
80229c RETURN
80230c END
80231
80232C*********************************************************************
80233
80234C...UPEVNT
80235C...Dummy routine, to be replaced by a user implementing external
80236C...processes. Depending on cross section model chosen, it either has
80237C...to generate a process of the type IDPRUP requested, or pick a type
80238C...itself and generate this event. The event is to be stored in the
80239C...HEPEUP commonblock, including (often) an event weight.
80240
80241C...New example: handles a standard Les Houches Events File.
80242
64da86aa 80243 SUBROUTINE UPEVNTD
92e27c01 80244
80245C...Double precision and integer declarations.
80246 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80247 IMPLICIT INTEGER(I-N)
80248
80249C...PYTHIA commonblock: only used to provide read unit MSTP(162).
80250 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80251 SAVE /PYPARS/
80252
80253C...User process event common block.
80254 INTEGER MAXNUP
80255 PARAMETER (MAXNUP=500)
80256 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
80257 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
80258 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
80259 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
80260 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
80261 SAVE /HEPEUP/
80262
80263C...Lines to read in assumed never longer than 200 characters.
80264 PARAMETER (MAXLEN=200)
80265 CHARACTER*(MAXLEN) STRING
80266
80267C...Format for reading lines.
80268 CHARACTER*6 STRFMT
80269 STRFMT='(A000)'
80270 WRITE(STRFMT(3:5),'(I3)') MAXLEN
80271
80272C...Loop until finds line beginning with "<event>" or "<event ".
80273 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
80274 IBEG=0
80275 110 IBEG=IBEG+1
80276C...Allow indentation.
80277 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
80278 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
80279 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
80280
80281C...Read first line of event info.
80282 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
80283 &AQEDUP,AQCDUP
80284
80285C...Read NUP subsequent lines with information on each particle.
80286 DO 120 I=1,NUP
80287 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
80288 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
80289 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
80290 120 CONTINUE
80291 RETURN
80292
80293C...Error exit, typically when no more events.
80294 130 WRITE(*,*) ' Failed to read LHEF event information.'
80295 WRITE(*,*) ' Will assume end of file has been reached.'
80296 NUP=0
80297 MSTI(51)=1
80298
80299 RETURN
80300 END
80301
80302C...Old example: handles a simple Pythia 6.4 event file.
80303
80304c SUBROUTINE UPEVNT
80305
80306C...Double precision and integer declarations.
80307c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80308c IMPLICIT INTEGER(I-N)
80309
80310C...Commonblocks.
80311c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80312c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80313c SAVE /PYDAT1/,/PYPARS/
80314
80315C...User process event common block.
80316c INTEGER MAXNUP
80317c PARAMETER (MAXNUP=500)
80318c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
80319c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
80320c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
80321c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
80322c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
80323c SAVE /HEPEUP/
80324
80325C...Read info from file.
80326c IF(MSTP(162).GT.0) THEN
80327c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
80328c & AQEDUP,AQCDUP
80329c DO 100 I=1,NUP
80330c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
80331c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
80332c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
80333c 100 CONTINUE
80334c RETURN
80335C...Special when reached end of file or other error.
80336c 110 NUP=0
80337
80338C...Else not implemented.
80339c ELSE
80340c WRITE(MSTU(11),5000)
80341c STOP
80342c ENDIF
80343
80344C...Format for error printout.
80345c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
80346c &1X,'Dummy routine in PYTHIA file called instead.'/
80347c &1X,'Execution stopped!')
80348
80349c RETURN
80350c END
80351
80352C*********************************************************************
80353
80354C...UPVETO
80355C...Dummy routine, to be replaced by user, to veto event generation
80356C...on the parton level, after parton showers but before multiple
80357C...interactions, beam remnants and hadronization is added.
80358C...If resonances like W, Z, top, Higgs and SUSY particles are handed
80359C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
80360C...be undecayed at this stage; if decayed their decay products will
80361C...have been allowed to shower.
80362
80363C...All partons at the end of the shower phase are stored in the
80364C...HEPEVT commonblock. The interesting information is
80365C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
80366C...IDHEP(I) = the particle ID code according to PDG conventions,
80367C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
80368C...All ISTHEP entries are 1, while the rest is zeroed.
80369
80370C...The user decision is to be conveyed by the IVETO value.
80371C...IVETO = 0 : retain current event and generate in full;
80372C... = 1 : abort generation of current event and move to next.
80373
64da86aa 80374 SUBROUTINE UPVETOD(IVETO)
92e27c01 80375
80376C...HEPEVT commonblock.
80377 PARAMETER (NMXHEP=4000)
80378 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
80379 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
80380 DOUBLE PRECISION PHEP,VHEP
80381 SAVE /HEPEVT/
80382
80383C...Next few lines allow you to see what info PYVETO extracted from
80384C...the full event record for the first two events.
80385C...Delete if you don't want it.
80386 DATA NLIST/0/
80387 SAVE NLIST
80388 IF(NLIST.LE.2) THEN
80389 WRITE(*,*) ' Full event record at time of UPVETO call:'
80390 CALL PYLIST(1)
80391 WRITE(*,*) ' Part of event record made available to UPVETO:'
80392 CALL PYLIST(5)
80393 NLIST=NLIST+1
80394 ENDIF
80395
80396C...Make decision here.
80397 IVETO = 0
80398
80399 RETURN
80400 END
80401
8ff9ce7d 80402
80403C... ALICE interface to PDFLIB with possibility to select nuclear structure
80404C... functions.
92e27c01 80405C...
8ff9ce7d 80406C... The MSTP array in the PYPARS common block is used to enable and
80407C... select the nuclear structure functions.
80408C... MSTP(52) : (D=1) choice of proton and nuclear structure-function library
80409C... =1: internal PYTHIA acording to MSTP(51)
80410C... =2: PDFLIB proton s.f., with MSTP(51) = 1000xNGROUP+NSET
80411C... MSTP( 51) = 1000xNPGROUP+NPSET
80412C... MSTP(151) = 1000xNAGROUP+NASET
80413C... MSTP(192) : Mass number of nucleus side 1
80414C... MSTP(193) : Mass number of nucleus side 2
92e27c01 80415C...
80416C...
8ff9ce7d 80417C... MINT(124) : side (1 or 2)
92e27c01 80418
80419
80420 SUBROUTINE PDFSET_ALICE(PARM, VALUE)
80421C...
80422 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80423 IMPLICIT INTEGER(I-N)
8ff9ce7d 80424C...Interface to PDFLIB.
92e27c01 80425 COMMON/LW50512/QCDL4,QCDL5
80426 SAVE /LW50512/
80427 DOUBLE PRECISION QCDL4,QCDL5
80428 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
80429 SAVE /LW50513/
80430 DOUBLE PRECISION XMIN,XMAX,Q2MIN,Q2MAX
80431C...
80432 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80433 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80434 DOUBLE PRECISION VALUE(20)
80435 CHARACTER*20 PARM(20)
8ff9ce7d 80436 write(6,*) MSTP(52)
80437 write(6,*) PARM
80438 write(6,*) VALUE
92e27c01 80439
80440 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
80441 PARM(5)='NATYPE'
80442 VALUE(5)=4
80443 PARM(6)='NAGROUP'
80444 VALUE(6)=MSTP(191)/1000
80445 PARM(7)='NASET'
80446 VALUE(7)=MOD(MSTP(191),1000)
80447 CALL PDFSET(PARM,VALUE,
80448 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
80449 > QCDL4,QCDL5,
80450 > XMIN,XMAX,Q2MIN,Q2MAX)
80451 IF (MSTP(194) .EQ. 0) THEN
80452 CALL SETLHAPARM("EKS98")
66f02a7f 80453 ELSE IF (MSTP(194) .EQ. 9) THEN
80454 CALL SETLHAPARM("EPS09LO")
80455 ELSE IF (MSTP(194) .EQ. 19) THEN
80456 CALL SETLHAPARM("EPS09NLO")
80457 ELSE IF (MSTP(194) .EQ. 8) THEN
92e27c01 80458 CALL SETLHAPARM("EPS08")
66f02a7f 80459 ELSE
80460 CALL SETLHAPARM("EPS09LO")
92e27c01 80461 ENDIF
80462 ELSE
8ff9ce7d 80463 write(6,*) "-> pdfset"
92e27c01 80464 CALL PDFSET(PARM,VALUE,
80465 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
80466 > QCDL4,QCDL5,
80467 > XMIN,XMAX,Q2MIN,Q2MAX)
80468 ENDIF
8ff9ce7d 80469 write(6,*) "done"
92e27c01 80470 END
80471
80472
80473
80474 SUBROUTINE STRUCTM_ALICE
80475 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
80476C...
80477 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80478 IMPLICIT INTEGER(I-N)
80479 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80480 COMMON/PYINT1/MINT(400),VINT(400)
8ff9ce7d 80481C write(6,*) "structm_alice->"
69a543f2 80482 A = MSTP(191+MINT(124))
80483 IF (A .GT. 1) THEN
8ff9ce7d 80484C write(6,*) mint(124), "-> structa ", A
92e27c01 80485 CALL STRUCTA(XX,QQ,A,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
80486 ELSE
8ff9ce7d 80487C write(6,*) mint(124), "-> structm "
92e27c01 80488 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
80489 ENDIF
80490 END
8ff9ce7d 80491
92e27c01 80492
80493C*********************************************************************
80494
80495C...SUGRA
80496C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
80497
80498 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
80499 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80500 IMPLICIT INTEGER(I-N)
80501 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
80502 INTEGER IMODL
80503C...Commonblocks.
80504 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80505 SAVE /PYDAT1/
80506
80507C...Stop program if this routine is ever called.
80508 WRITE(MSTU(11),5000)
80509 CALL PYSTOP(110)
80510
80511C...Format for error printout.
80512 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
80513 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
80514 &1X,'Execution stopped!')
80515
80516 RETURN
80517 END
80518
80519C*********************************************************************
80520
80521C...VISAJE
80522C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
80523
80524 FUNCTION VISAJE()
80525 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80526 IMPLICIT INTEGER(I-N)
80527 CHARACTER*40 VISAJE
80528
80529C...Commonblocks.
80530 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80531 SAVE /PYDAT1/
80532
80533C...Assign default value.
80534 VISAJE='Undefined'
80535
80536C...Stop program if this routine is ever called.
80537 WRITE(MSTU(11),5000)
80538 CALL PYSTOP(110)
80539
80540C...Format for error printout.
80541 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
80542 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
80543 &1X,'Execution stopped!')
80544
80545 RETURN
80546 END
80547
80548C*********************************************************************
80549
80550C...SSMSSM
80551C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
80552
80553 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
80554 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
80555 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
80556 &IDUM1,IDUM2)
80557 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80558 IMPLICIT INTEGER(I-N)
80559 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
80560 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
80561 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
80562C...Commonblocks.
80563 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80564 SAVE /PYDAT1/
80565
80566C...Stop program if this routine is ever called.
80567 WRITE(MSTU(11),5000)
80568 CALL PYSTOP(110)
80569
80570C...Format for error printout.
80571 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
80572 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
80573 &1X,'Execution stopped!')
80574 RETURN
80575 END
80576
80577C*********************************************************************
80578
80579C...FHSETFLAGS
80580C...Dummy function, to be removed when FEYNHIGGS is to be linked.
80581
80582 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
80583 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80584 IMPLICIT INTEGER(I-N)
80585Cmssmpart = 4 # full MSSM [recommended]
80586Cfieldren = 0 # MSbar field ren. [strongly recommended]
80587Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
80588Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
80589Cp2approx = 0 # no approximation [recommended]
80590Clooplevel= 2 # include 2-loop corrections
80591Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
80592Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
80593
80594C...Commonblocks.
80595 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80596 SAVE /PYDAT1/
80597
80598C...Stop program if this routine is ever called.
80599 WRITE(MSTU(11),5000)
80600 CALL PYSTOP(103)
80601
80602C...Format for error printout.
80603 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
80604 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
80605 &1X,'Execution stopped!')
80606 RETURN
80607 END
80608
80609C*********************************************************************
80610
80611C...FHSETPARA
80612C...Dummy function, to be removed when FEYNHIGGS is to be linked.
80613
80614 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
80615 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
80616 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
80617 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
80618 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80619 IMPLICIT INTEGER(I-N)
80620
80621 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
80622 DOUBLE COMPLEX DMU,
80623 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
80624 & DM1, DM2, DM3
80625
80626C...Commonblocks.
80627 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80628 SAVE /PYDAT1/
80629
80630C...Stop program if this routine is ever called.
80631 WRITE(MSTU(11),5000)
80632 CALL PYSTOP(103)
80633
80634C...Format for error printout.
80635 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
80636 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
80637 &1X,'Execution stopped!')
80638 RETURN
80639 END
80640
80641C*********************************************************************
80642
80643C...FHHIGGSCORR
80644C...Dummy function, to be removed when FEYNHIGGS is to be linked.
80645
80646 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
80647 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80648 IMPLICIT INTEGER(I-N)
80649
80650C...FeynHiggs variables
80651 DOUBLE PRECISION RMHIGG(4)
80652 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
80653 DOUBLE COMPLEX DMU,
80654 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
80655 & DM1, DM2, DM3
80656
80657C...Commonblocks.
80658 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80659 SAVE /PYDAT1/
80660
80661C...Stop program if this routine is ever called.
80662 WRITE(MSTU(11),5000)
80663 CALL PYSTOP(103)
80664
80665C...Format for error printout.
80666 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
80667 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
80668 &1X,'Execution stopped!')
80669 RETURN
80670 END
80671
80672C*********************************************************************
80673
80674C...PYTAUD
80675C...Dummy routine, to be replaced by user, to handle the decay of a
80676C...polarized tau lepton.
80677C...Input:
80678C...ITAU is the position where the decaying tau is stored in /PYJETS/.
80679C...IORIG is the position where the mother of the tau is stored;
80680C... is 0 when the mother is not stored.
80681C...KFORIG is the flavour of the mother of the tau;
80682C... is 0 when the mother is not known.
80683C...Note that IORIG=0 does not necessarily imply KFORIG=0;
80684C... e.g. in B hadron semileptonic decays the W propagator
80685C... is not explicitly stored but the W code is still unambiguous.
80686C...Output:
80687C...NDECAY is the number of decay products in the current tau decay.
80688C...These decay products should be added to the /PYJETS/ common block,
80689C...in positions N+1 through N+NDECAY. For each product I you must
80690C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
80691C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
80692
80693 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
80694
80695C...Double precision and integer declarations.
80696 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80697 IMPLICIT INTEGER(I-N)
80698 INTEGER PYK,PYCHGE,PYCOMP
80699C...Commonblocks.
80700 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
80701 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80702 SAVE /PYJETS/,/PYDAT1/
80703
80704C...Stop program if this routine is ever called.
80705C...You should not copy these lines to your own routine.
80706 NDECAY=ITAU+IORIG+KFORIG
80707 WRITE(MSTU(11),5000)
80708 CALL PYSTOP(10)
80709
80710C...Format for error printout.
80711 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
80712 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
80713 &1X,'Execution stopped!')
80714
80715 RETURN
80716 END
80717
80718C*********************************************************************
80719
80720C...PYTIME
80721C...Finds current date and time.
80722C...Since this task is not standardized in Fortran 77, the routine
80723C...is dummy, to be replaced by the user. Examples are given for
80724C...the Fortran 90 routine and DEC Fortran 77, and what to do if
80725C...you do not have access to suitable routines.
80726
80727 SUBROUTINE PYTIME(IDATI)
80728
80729C...Double precision and integer declarations.
80730 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80731 IMPLICIT INTEGER(I-N)
80732 INTEGER PYK,PYCHGE,PYCOMP
80733 CHARACTER*8 ATIME
80734C...Local array.
80735 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
80736
80737C...Example 0: if you do not have suitable routines.
80738 DO 100 J=1,6
80739 IDATI(J)=0
80740 100 CONTINUE
80741
80742C...Example 1: Fortran 90 routine.
80743C CALL DATE_AND_TIME(VALUES=IVAL)
80744C IDATI(1)=IVAL(1)
80745C IDATI(2)=IVAL(2)
80746C IDATI(3)=IVAL(3)
80747C IDATI(4)=IVAL(5)
80748C IDATI(5)=IVAL(6)
80749C IDATI(6)=IVAL(7)
80750
80751C...Example 2: DEC Fortran 77. AIX.
80752C CALL IDATE(IMON,IDAY,IYEAR)
80753C IDATI(1)=IYEAR
80754C IDATI(2)=IMON
80755C IDATI(3)=IDAY
80756C CALL ITIME(IHOUR,IMIN,ISEC)
80757C IDATI(4)=IHOUR
80758C IDATI(5)=IMIN
80759C IDATI(6)=ISEC
80760
80761C...Example 3: DEC Fortran, IRIX, IRIX64.
80762C CALL IDATE(IMON,IDAY,IYEAR)
80763C IDATI(1)=IYEAR
80764C IDATI(2)=IMON
80765C IDATI(3)=IDAY
80766C CALL TIME(ATIME)
80767C IHOUR=0
80768C IMIN=0
80769C ISEC=0
80770C READ(ATIME(1:2),'(I2)') IHOUR
80771C READ(ATIME(4:5),'(I2)') IMIN
80772C READ(ATIME(7:8),'(I2)') ISEC
80773C IDATI(4)=IHOUR
80774C IDATI(5)=IMIN
80775C IDATI(6)=ISEC
80776
80777C...Example 4: GNU LINUX libU77, SunOS.
80778C CALL IDATE(IDTEMP)
80779C IDATI(1)=IDTEMP(3)
80780C IDATI(2)=IDTEMP(2)
80781C IDATI(3)=IDTEMP(1)
80782C CALL ITIME(IDTEMP)
80783C IDATI(4)=IDTEMP(1)
80784C IDATI(5)=IDTEMP(2)
80785C IDATI(6)=IDTEMP(3)
80786
80787C...Common code to ensure right century.
80788 IDATI(1)=2000+MOD(IDATI(1),100)
80789
80790 RETURN
80791 END