]> 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
Changes needed to avoid fpe.
[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.
2880 COMMON/W50511/NPTYPE,NGROUP,NSET,MODE,NFL,LO,TMAS
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
3586C...Initial values for some counters.
3587 MSTU(1)=0
3588 MSTU(2)=0
3589 N=0
3590 MINT(5)=MINT(5)+1
3591 MINT(7)=0
3592 MINT(8)=0
3593 MINT(30)=0
3594 MINT(83)=0
3595 MINT(84)=MSTP(126)
3596 MSTU(24)=0
3597 MSTU70=0
3598 MSTJ14=MSTJ(14)
3599C...Normally, use K(I,4:5) colour info rather than /PYCT/.
3600 NCT=0
3601 MINT(33)=0
3602C...Zero counters for pT-ordered showers (failsafe)
3603 NPART=0
3604 NPARTD=0
3605
3606C...Let called routines know call is from PYEVNW (not PYEVNT).
3607 MINT(35)=3
3608
3609C...If variable energies: redo incoming kinematics and cross-section.
3610 MSTI(61)=0
3611 IF(MSTP(171).EQ.1) THEN
3612 CALL PYINKI(1)
3613 IF(MSTI(61).EQ.1) THEN
3614 MINT(5)=MINT(5)-1
3615 RETURN
3616 ENDIF
3617 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
3618 CALL PYXTOT
3619 ENDIF
3620
3621C...Loop over number of pileup events; check space left.
3622 IF(MSTP(131).LE.0) THEN
3623 NPILE=1
3624 ELSE
3625 CALL PYPILE(2)
3626 NPILE=MINT(81)
3627 ENDIF
3628 DO 300 IPILE=1,NPILE
3629 IF(MINT(84)+100.GE.MSTU(4)) THEN
3630 CALL PYERRM(11,
3631 & '(PYEVNW:) no more space in PYJETS for pileup events')
3632 IF(MSTU(21).GE.1) GOTO 310
3633 ENDIF
3634 MINT(82)=IPILE
3635
3636C...Generate variables of hard scattering.
3637 MINT(51)=0
3638 MSTI(52)=0
3639 LOOPHS =0
3640 100 CONTINUE
3641 LOOPHS = LOOPHS + 1
3642 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
3643 IF(LOOPHS.GE.10) THEN
3644 CALL PYERRM(19,'(PYEVNW:) failed to evolve shower or '
3645 & //'multiple interactions. Returning.')
3646 MINT(51)=1
3647 RETURN
3648 ENDIF
3649 MINT(31)=0
3650 MINT(39)=0
3651 MINT(36)=0
3652 MINT(51)=0
3653 MINT(57)=0
3654 CALL PYRAND
3655 IF(MSTI(61).EQ.1) THEN
3656 MINT(5)=MINT(5)-1
3657 RETURN
3658 ENDIF
3659 IF(MINT(51).EQ.2) RETURN
3660 ISUB=MINT(1)
3661 IF(MSTP(111).EQ.-1) GOTO 290
3662
3663C...Loopback point if PYPREP fails, especially for junction topologies.
3664 NPREP=0
3665 MNT31S=MINT(31)
3666 110 NPREP=NPREP+1
3667 MINT(31)=MNT31S
3668
3669 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
3670C...Hard scattering (including low-pT):
3671C...reconstruct kinematics and colour flow of hard scattering.
3672 MINT31=MINT(31)
3673 120 MINT(31)=MINT31
3674 MINT(51)=0
3675 CALL PYSCAT
3676 IF(MINT(51).EQ.1) GOTO 100
3677 NPARTD=N
3678 NFIN=N
3679
3680C...Intertwined initial state showers and multiple interactions.
3681C...Force no IS showers if no pdfs defined: MSTP(61) -> 0 for PYEVOL.
3682C...Force no MI if cross section not known: MSTP(81) -> 0 for PYEVOL.
3683 MSTP61=MSTP(61)
3684 IF (MINT(47).LT.2) MSTP(61)=0
3685 MSTP81=MSTP(81)
3686 IF (MINT(50).EQ.0) MSTP(81)=0
3687 IF ((MSTP(61).GE.1.OR.MOD(MSTP(81),10).GE.0).AND.
3688 & MINT(111).NE.12) THEN
3689C...Absolute max pT2 scale for evolution: phase space limit.
3690 PT2MXS=0.25D0*VINT(2)
3691C...Check if more constrained by ISR and MI max scales:
3692 PT2MXS=MIN(PT2MXS,MAX(MAX(1D0,PARP(67))*VINT(56),VINT(62)))
3693C...Loopback point in case of failure in evolution.
3694 LOOP=0
3695 130 LOOP=LOOP+1
3696 MINT(51)=0
3697 IF(LOOP.GT.100) THEN
3698 CALL PYERRM(9,'(PYEVNW:) failed to evolve shower or '
3699 & //'multiple interactions. Trying new point.')
3700 MINT(51)=1
3701 RETURN
3702 ENDIF
3703
3704C...Pre-initialization of interleaved MI/ISR/JI evolution, only done
3705C...once per event. (E.g. compute constants and save variables to be
3706C...restored later in case of failure.)
3707 IF (LOOP.EQ.1) CALL PYEVOL(-1,DUMMY1,DUMMY2)
3708
3709C...Initialize interleaved MI/ISR/JI evolution.
3710C...PT2MAX: absolute upper limit for evolution - Initialization may
3711C... return a PT2MAX which is lower than this.
3712C...PT2MIN: absolute lower limit for evolution - Initialization may
3713C... return a PT2MIN which is larger than this (e.g. Lambda_QCD).
3714 PT2MAX=PT2MXS
3715 PT2MIN=0D0
3716 CALL PYEVOL(0,PT2MAX,PT2MIN)
3717C...If failed to initialize evolution, generate a new hard process
3718 IF (MINT(51).EQ.1) GOTO 100
3719
3720C...Perform interleaved MI/ISR/JI evolution from PT2MAX to PT2MIN.
3721C...In principle factorized, so can be stopped and restarted.
3722C...Example: stop/start at pT=10 GeV. (Commented out for now.)
3723C PT2MED=MAX(10D0**2,PT2MIN)
3724C CALL PYEVOL(1,PT2MAX,PT2MED)
3725C IF (MINT(51).EQ.1) GOTO 160
3726C PT2MAX=PT2MED
3727 CALL PYEVOL(1,PT2MAX,PT2MIN)
3728C...If fatal error (e.g., massive hard-process initiator, but no available
3729C...phase space for creation), generate a new hard process
3730 IF (MINT(51).EQ.2) GOTO 100
3731C...If smaller error, just try running evolution again
3732 IF (MINT(51).EQ.1) GOTO 130
3733
3734C...Finalize interleaved MI/ISR/JI evolution.
3735 CALL PYEVOL(2,PT2MAX,PT2MIN)
3736 IF (MINT(51).EQ.1) GOTO 130
3737
3738 ENDIF
3739 MSTP(61)=MSTP61
3740 MSTP(81)=MSTP81
3741 IF(MINT(51).EQ.1) GOTO 100
3742C...(MINT(52) is actually obsolete in this routine. Set anyway
3743C...to ensure PYDOCU stable.)
3744 MINT(52)=N
3745 MINT(53)=N
3746
3747C...Beam remnants - new scheme.
3748 140 IF(MINT(50).EQ.1) THEN
3749 IF (ISUB.EQ.95) MINT(31)=1
3750
3751C...Beam remnant flavour and colour assignments - new scheme.
3752 CALL PYMIHK
3753 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3754 & GOTO 120
3755 IF(MINT(51).EQ.1) GOTO 100
3756
3757C...Primordial kT and beam remnant momentum sharing - new scheme.
3758 CALL PYMIRM
3759 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5)
3760 & GOTO 120
3761 IF(MINT(51).EQ.1) GOTO 100
3762 IF (ISUB.EQ.95) MINT(31)=0
3763 ELSEIF(MINT(111).NE.12) THEN
3764C...Hadron remnants and primordial kT - old model.
3765C...Happens e.g. for direct photon on one side.
3766 IPU1=IMI(1,1,1)
3767 IPU2=IMI(2,1,1)
3768 CALL PYREMN(IPU1,IPU2)
3769 IF(MINT(51).EQ.1.AND.MINT(57).GE.1.AND.MINT(57).LE.5) GOTO
3770 & 110
3771 IF(MINT(51).EQ.1) GOTO 100
3772C...PYREMN does not set colour tags for BRs, so needs to be done now.
3773 DO 160 I=MINT(53)+1,N
3774 DO 150 KCS=4,5
3775 IDA=MOD(K(I,KCS),MSTU(5))
3776 IF (IDA.NE.0) THEN
3777 MCT(I,KCS-3)=MCT(IDA,6-KCS)
3778 ELSE
3779 MCT(I,KCS-3)=0
3780 ENDIF
3781 150 CONTINUE
3782 160 CONTINUE
3783C...Instruct PYPREP to use colour tags
3784 MINT(33)=1
3785
3786 DO 360 MQGST=1,2
3787 DO 350 I=MINT(84)+1,N
3788
3789C...Look for coloured string endpoint, or (later) leftover gluon.
3790 IF (K(I,1).NE.3) GOTO 350
3791 KC=PYCOMP(K(I,2))
3792 IF(KC.EQ.0) GOTO 350
3793 KQ=KCHG(KC,2)
3794 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
3795
3796C... Pick up loose string end with no previous tag.
3797 KCS=4
3798 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
3799 IF(MCT(I,KCS-3).NE.0) GOTO 350
3800
3801 CALL PYCTTR(I,KCS,I)
3802 IF(MINT(51).NE.0) RETURN
3803
3804 350 CONTINUE
3805 360 CONTINUE
3806C...Now delete any colour processing information if set (since partons
3807C...otherwise not FS showered!)
3808 DO 170 I=MINT(84)+1,N
3809 IF (I.LE.N) THEN
3810 K(I,4)=MOD(K(I,4),MSTU(5)**2)
3811 K(I,5)=MOD(K(I,5),MSTU(5)**2)
3812 ENDIF
3813 170 CONTINUE
3814 ENDIF
3815
3816C...Showering of final state partons (optional).
3817 ALAMSV=PARJ(81)
3818 PARJ(81)=PARP(72)
3819 IF(MSTP(71).GE.1.AND.ISET(ISUB).GE.1.AND.ISET(ISUB).LE.10)
3820 & THEN
3821 QMAX=VINT(55)
3822 IF(ISET(ISUB).EQ.2) QMAX=SQRT(PARP(71))*VINT(55)
3823 CALL PYPTFS(1,QMAX,0D0,PTGEN)
3824C...External processes: handle successive showers.
3825 ELSEIF(ISET(ISUB).EQ.11) THEN
3826 CALL PYADSH(NFIN)
3827 ENDIF
3828 PARJ(81)=ALAMSV
3829
3830C...Allow possibility for user to abort event generation.
3831 IVETO=0
3832 IF(IPILE.EQ.1.AND.MSTP(143).EQ.1) CALL PYVETO(IVETO) ! sm
3833 IF(IVETO.EQ.1) THEN
3834C...........No reason to count this as an error
3835 LOOPHS = LOOPHS-1
3836 GOTO 100
3837 ENDIF
3838
3839
3840C...Decay of final state resonances.
3841 MINT(32)=0
3842 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10) THEN
3843 CALL PYRESD(0)
3844 IF(MINT(51).NE.0) GOTO 100
3845 ENDIF
3846
3847 IF(MINT(51).EQ.1) GOTO 100
3848
3849 ELSEIF(ISUB.NE.99) THEN
3850C...Diffractive and elastic scattering.
3851 CALL PYDIFF
3852
3853 ELSE
3854C...DIS scattering (photon flux external).
3855 CALL PYDISG
3856 IF(MINT(51).EQ.1) GOTO 100
3857 ENDIF
3858
3859C...Check that no odd resonance left undecayed.
3860 MINT(54)=N
3861 IF(MSTP(111).GE.1) THEN
3862 NFIX=N
3863 DO 180 I=MINT(84)+1,NFIX
3864 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
3865 & K(I,2).NE.22) THEN
3866 KCA=PYCOMP(K(I,2))
3867 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
3868 CALL PYRESD(I)
3869 IF(MINT(51).EQ.1) GOTO 100
3870 ENDIF
3871 ENDIF
3872 180 CONTINUE
3873 ENDIF
3874
3875C...Boost hadronic subsystem to overall rest frame.
3876C..(Only relevant when photon inside lepton beam.)
3877 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
3878
3879C...Recalculate energies from momenta and masses (if desired).
3880 IF(MSTP(113).GE.1) THEN
3881 DO 190 I=MINT(83)+1,N
3882 IF(K(I,1).GT.0.AND.K(I,1).LE.10) P(I,4)=SQRT(P(I,1)**2+
3883 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3884 190 CONTINUE
3885 NRECAL=N
3886 ENDIF
3887
3888C...Colour reconnection before string formation
3889 CALL PYFSCR(MINT(84)+1)
3890
3891C...Rearrange partons along strings, check invariant mass cuts.
3892 MSTU(28)=0
3893 IF(MSTP(111).LE.0) MSTJ(14)=-1
3894 CALL PYPREP(MINT(84)+1)
3895 MSTJ(14)=MSTJ14
3896 IF(MINT(51).EQ.1.AND.MSTU(24).EQ.1) THEN
3897 MSTU(24)=0
3898 GOTO 100
3899 ENDIF
3900 IF(MINT(51).EQ.1) GOTO 110
3901 IF(MSTP(112).EQ.1.AND.MSTU(28).EQ.3) GOTO 100
3902 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) THEN
3903 DO 220 I=MINT(84)+1,N
3904 IF(K(I,2).EQ.94) THEN
3905 DO 210 I1=I+1,MIN(N,I+10)
3906 IF(K(I1,3).EQ.I) THEN
3907 K(I1,3)=MOD(K(I1,4)/MSTU(5),MSTU(5))
3908 IF(K(I1,3).EQ.0) THEN
3909 DO 200 II=MINT(84)+1,I-1
3910 IF(K(II,2).EQ.K(I1,2)) THEN
3911 IF(MOD(K(II,4),MSTU(5)).EQ.I1.OR.
3912 & MOD(K(II,5),MSTU(5)).EQ.I1) K(I1,3)=II
3913 ENDIF
3914 200 CONTINUE
3915 IF(K(I+1,3).EQ.0) K(I+1,3)=K(I,3)
3916 ENDIF
3917 ENDIF
3918 210 CONTINUE
3919C...Also collapse particles decaying to themselves (if same KS)
3920C...Sep 22 2009: Commented out by PS following suggestion by TS to fix
3921C...problem with history point-backs in new shower, where a particle is
3922C...copied with a new momentum when it is the recoiler.
3923C ELSEIF (K(I,1).GT.0.AND.K(I,4).EQ.K(I,5).AND.K(I,4).GT.0
3924C & .AND.K(I,4).LT.N) THEN
3925C IDA=K(I,4)
3926C IF (K(IDA,1).EQ.K(I,1).AND.K(IDA,2).EQ.K(I,2)) THEN
3927C K(I,1)=0
3928C ENDIF
3929 ENDIF
3930 220 CONTINUE
3931 CALL PYEDIT(12)
3932 CALL PYEDIT(14)
3933 IF(MSTP(125).EQ.0) CALL PYEDIT(15)
3934 IF(MSTP(125).EQ.0) MINT(4)=0
3935 DO 240 I=MINT(83)+1,N
3936 IF(K(I,1).EQ.11.AND.K(I,4).EQ.0.AND.K(I,5).EQ.0) THEN
3937 DO 230 I1=I+1,N
3938 IF(K(I1,3).EQ.I.AND.K(I,4).EQ.0) K(I,4)=I1
3939 IF(K(I1,3).EQ.I) K(I,5)=I1
3940 230 CONTINUE
3941 ENDIF
3942 240 CONTINUE
3943 ENDIF
3944
3945C...Introduce separators between sections in PYLIST event listing.
3946 IF(IPILE.EQ.1.AND.MSTP(125).LE.0) THEN
3947 MSTU70=1
3948 MSTU(71)=N
3949 ELSEIF(IPILE.EQ.1) THEN
3950 MSTU70=3
3951 MSTU(71)=2
3952 MSTU(72)=MINT(4)
3953 MSTU(73)=N
3954 ENDIF
3955
3956C...Go back to lab frame (needed for vertices, also in fragmentation).
3957 CALL PYFRAM(1)
3958
3959C...Set nonvanishing production vertex (optional).
3960 IF(MSTP(151).EQ.1) THEN
3961 DO 250 J=1,4
3962 VTX(J)=PARP(150+J)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0))))*
3963 & SIN(PARU(2)*PYR(0))
3964 250 CONTINUE
3965 DO 270 I=MINT(83)+1,N
3966 DO 260 J=1,4
3967 V(I,J)=V(I,J)+VTX(J)
3968 260 CONTINUE
3969 270 CONTINUE
3970 ENDIF
3971
3972C...Perform hadronization (if desired).
3973 IF(MSTP(111).GE.1) THEN
3974 CALL PYEXEC
3975 IF(MSTU(24).NE.0) GOTO 100
3976 ENDIF
3977 IF(MSTP(113).GE.1) THEN
3978 DO 280 I=NRECAL,N
3979 IF(P(I,5).GT.0D0) P(I,4)=SQRT(P(I,1)**2+
3980 & P(I,2)**2+P(I,3)**2+P(I,5)**2)
3981 280 CONTINUE
3982 ENDIF
3983 IF(MSTP(125).EQ.0.OR.MSTP(125).EQ.1) CALL PYEDIT(14)
3984
3985C...Store event information and calculate Monte Carlo estimates of
3986C...subprocess cross-sections.
3987 290 IF(IPILE.EQ.1) CALL PYDOCU
3988
3989C...Set counters for current pileup event and loop to next one.
3990 MSTI(41)=IPILE
3991 IF(IPILE.GE.2.AND.IPILE.LE.10) MSTI(40+IPILE)=ISUB
3992 IF(MSTU70.LT.10) THEN
3993 MSTU70=MSTU70+1
3994 MSTU(70+MSTU70)=N
3995 ENDIF
3996 MINT(83)=N
3997 MINT(84)=N+MSTP(126)
3998 IF(IPILE.LT.NPILE) CALL PYFRAM(2)
3999 300 CONTINUE
4000
4001C...Generic information on pileup events. Reconstruct missing history.
4002 IF(MSTP(131).EQ.1.AND.MSTP(133).GE.1) THEN
4003 PARI(91)=VINT(132)
4004 PARI(92)=VINT(133)
4005 PARI(93)=VINT(134)
4006 IF(MSTP(133).GE.2) PARI(93)=PARI(93)*XSEC(0,3)/VINT(131)
4007 ENDIF
4008 CALL PYEDIT(16)
4009
4010C...Transform to the desired coordinate frame.
4011 310 CALL PYFRAM(MSTP(124))
4012 MSTU(70)=MSTU70
4013 PARU(21)=VINT(1)
4014
4015C...Error messages
4016 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4017 &1X,'Execution stopped.')
4018
4019 RETURN
4020 END
4021
4022
4023C***********************************************************************
4024
4025C...PYSTAT
4026C...Prints out information about cross-sections, decay widths, branching
4027C...ratios, kinematical limits, status codes and parameter values.
4028
4029 SUBROUTINE PYSTAT(MSTAT)
4030
4031C...Double precision and integer declarations.
4032 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4033 IMPLICIT INTEGER(I-N)
4034 INTEGER PYK,PYCHGE,PYCOMP
4035C...Parameter statement to help give large particle numbers.
4036 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
4037 &KEXCIT=4000000,KDIMEN=5000000)
4038 PARAMETER (EPS=1D-3)
4039C...Commonblocks.
4040 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4041 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4042 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4043 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
4044 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4045 COMMON/PYINT1/MINT(400),VINT(400)
4046 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4047 COMMON/PYINT4/MWID(500),WIDS(500,5)
4048 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
4049 COMMON/PYINT6/PROC(0:500)
4050 CHARACTER PROC*28, CHTMP*16
4051 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
4052 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
4053 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
4054 &/PYINT2/,/PYINT4/,/PYINT5/,/PYINT6/,/PYMSSM/,/PYMSRV/
4055C...Local arrays, character variables and data.
4056 DIMENSION WDTP(0:400),WDTE(0:400,0:5),NMODES(0:20),PBRAT(10)
4057 CHARACTER PROGA(6)*28,CHAU*16,CHKF*16,CHD1*16,CHD2*16,CHD3*16,
4058 &CHIN(2)*12,STATE(-1:5)*4,CHKIN(21)*18,DISGA(2)*28,
4059 &PROGG9(13)*28,PROGG4(4)*28,PROGG2(2)*28,PROGP4(4)*28
4060 CHARACTER*24 CHD0, CHDC(10)
4061 CHARACTER*6 DNAME(3)
4062 DATA PROGA/
4063 &'VMD/hadron * VMD ','VMD/hadron * direct ',
4064 &'VMD/hadron * anomalous ','direct * direct ',
4065 &'direct * anomalous ','anomalous * anomalous '/
4066 DATA DISGA/'e * VMD','e * anomalous'/
4067 DATA PROGG9/
4068 &'direct * direct ','direct * VMD ',
4069 &'direct * anomalous ','VMD * direct ',
4070 &'VMD * VMD ','VMD * anomalous ',
4071 &'anomalous * direct ','anomalous * VMD ',
4072 &'anomalous * anomalous ','DIS * VMD ',
4073 &'DIS * anomalous ','VMD * DIS ',
4074 &'anomalous * DIS '/
4075 DATA PROGG4/
4076 &'direct * direct ','direct * resolved ',
4077 &'resolved * direct ','resolved * resolved '/
4078 DATA PROGG2/
4079 &'direct * hadron ','resolved * hadron '/
4080 DATA PROGP4/
4081 &'VMD * hadron ','direct * hadron ',
4082 &'anomalous * hadron ','DIS * hadron '/
4083 DATA STATE/'----','off ','on ','on/+','on/-','on/1','on/2'/,
4084 &CHKIN/' m_hard (GeV/c^2) ',' p_T_hard (GeV/c) ',
4085 &'m_finite (GeV/c^2)',' y*_subsystem ',' y*_large ',
4086 &' y*_small ',' eta*_large ',' eta*_small ',
4087 &'cos(theta*)_large ','cos(theta*)_small ',' x_1 ',
4088 &' x_2 ',' x_F ',' cos(theta_hard) ',
4089 &'m''_hard (GeV/c^2) ',' tau ',' y* ',
4090 &'cos(theta_hard^-) ','cos(theta_hard^+) ',' x_T^2 ',
4091 &' tau'' '/
4092 DATA DNAME /'q ','lepton','nu '/
4093
4094C...Cross-sections.
4095 IF(MSTAT.LE.1) THEN
4096 IF(MINT(121).GT.1) CALL PYSAVE(5,0)
4097 WRITE(MSTU(11),5000)
4098 WRITE(MSTU(11),5100)
4099 WRITE(MSTU(11),5200) 0,PROC(0),NGEN(0,3),NGEN(0,1),XSEC(0,3)
4100 DO 100 I=1,500
4101 IF(MSUB(I).NE.1) GOTO 100
4102 WRITE(MSTU(11),5200) I,PROC(I),NGEN(I,3),NGEN(I,1),XSEC(I,3)
4103 100 CONTINUE
4104 IF(MINT(121).GT.1) THEN
4105 WRITE(MSTU(11),5300)
4106 DO 110 IGA=1,MINT(121)
4107 CALL PYSAVE(3,IGA)
4108 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
4109 WRITE(MSTU(11),5200) IGA,DISGA(IGA),NGEN(0,3),NGEN(0,1),
4110 & XSEC(0,3)
4111 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
4112 WRITE(MSTU(11),5200) IGA,PROGG9(IGA),NGEN(0,3),NGEN(0,1),
4113 & XSEC(0,3)
4114 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.30) THEN
4115 WRITE(MSTU(11),5200) IGA,PROGP4(IGA),NGEN(0,3),NGEN(0,1),
4116 & XSEC(0,3)
4117 ELSEIF(MINT(121).EQ.4) THEN
4118 WRITE(MSTU(11),5200) IGA,PROGG4(IGA),NGEN(0,3),NGEN(0,1),
4119 & XSEC(0,3)
4120 ELSEIF(MINT(121).EQ.2) THEN
4121 WRITE(MSTU(11),5200) IGA,PROGG2(IGA),NGEN(0,3),NGEN(0,1),
4122 & XSEC(0,3)
4123 ELSE
4124 WRITE(MSTU(11),5200) IGA,PROGA(IGA),NGEN(0,3),NGEN(0,1),
4125 & XSEC(0,3)
4126 ENDIF
4127 110 CONTINUE
4128 CALL PYSAVE(5,0)
4129 ENDIF
4130 WRITE(MSTU(11),5400) MSTU(23),MSTU(30),MSTU(27),
4131 & 1D0-DBLE(NGEN(0,3))/MAX(1D0,DBLE(NGEN(0,2)))
4132
4133C...Decay widths and branching ratios.
4134 ELSEIF(MSTAT.EQ.2) THEN
4135 WRITE(MSTU(11),5500)
4136 WRITE(MSTU(11),5600)
4137 DO 140 KC=1,500
4138 KF=KCHG(KC,4)
4139 CALL PYNAME(KF,CHKF)
4140 IOFF=0
4141 IF(KC.LE.22) THEN
4142 IF(KC.GT.2*MSTP(1).AND.KC.LE.10) GOTO 140
4143 IF(KC.GT.10+2*MSTP(1).AND.KC.LE.20) GOTO 140
4144 IF(KC.LE.5.OR.(KC.GE.11.AND.KC.LE.16)) IOFF=1
4145 IF(KC.EQ.18.AND.PMAS(18,1).LT.1D0) IOFF=1
4146 IF(KC.EQ.21.OR.KC.EQ.22) IOFF=1
4147 ELSE
4148 IF(MWID(KC).LE.0) GOTO 140
4149 IF(IMSS(1).LE.0.AND.(KF/KSUSY1.EQ.1.OR.
4150 & KF/KSUSY1.EQ.2)) GOTO 140
4151 ENDIF
4152C...Off-shell branchings.
4153 IF(IOFF.EQ.1) THEN
4154 NGP=0
4155 IF(KC.LE.20) NGP=(MOD(KC,10)+1)/2
4156 IF(NGP.LE.MSTP(1)) WRITE(MSTU(11),5700) KF,CHKF(1:10),
4157 & PMAS(KC,1),0D0,0D0,STATE(MDCY(KC,1)),0D0
4158 DO 120 J=1,MDCY(KC,3)
4159 IDC=J+MDCY(KC,2)-1
4160 NGP1=0
4161 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4162 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4163 NGP2=0
4164 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4165 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4166 CALL PYNAME(KFDP(IDC,1),CHD1)
4167 CALL PYNAME(KFDP(IDC,2),CHD2)
4168 IF(KFDP(IDC,3).EQ.0) THEN
4169 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4170 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4171 & CHD2(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4172 ELSE
4173 CALL PYNAME(KFDP(IDC,3),CHD3)
4174 IF(MDME(IDC,2).EQ.102.AND.NGP1.LE.MSTP(1).AND.
4175 & NGP2.LE.MSTP(1)) WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4176 & CHD2(1:10),CHD3(1:10),0D0,0D0,STATE(MDME(IDC,1)),0D0
4177 ENDIF
4178 120 CONTINUE
4179C...On-shell decays.
4180 ELSE
4181 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
4182 BRFIN=1D0
4183 IF(WDTE(0,0).LE.0D0) BRFIN=0D0
4184 WRITE(MSTU(11),5700) KF,CHKF(1:10),PMAS(KC,1),WDTP(0),1D0,
4185 & STATE(MDCY(KC,1)),BRFIN
4186 DO 130 J=1,MDCY(KC,3)
4187 IDC=J+MDCY(KC,2)-1
4188 NGP1=0
4189 IF(IABS(KFDP(IDC,1)).LE.20) NGP1=
4190 & (MOD(IABS(KFDP(IDC,1)),10)+1)/2
4191 NGP2=0
4192 IF(IABS(KFDP(IDC,2)).LE.20) NGP2=
4193 & (MOD(IABS(KFDP(IDC,2)),10)+1)/2
4194 BRPRI=0D0
4195 IF(WDTP(0).GT.0D0) BRPRI=WDTP(J)/WDTP(0)
4196 BRFIN=0D0
4197 IF(WDTE(0,0).GT.0D0) BRFIN=WDTE(J,0)/WDTE(0,0)
4198 CALL PYNAME(KFDP(IDC,1),CHD1)
4199 CALL PYNAME(KFDP(IDC,2),CHD2)
4200 IF(KFDP(IDC,3).EQ.0) THEN
4201 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4202 & WRITE(MSTU(11),5800) IDC,CHD1(1:10),
4203 & CHD2(1:10),WDTP(J),BRPRI,
4204 & STATE(MDME(IDC,1)),BRFIN
4205 ELSE
4206 CALL PYNAME(KFDP(IDC,3),CHD3)
4207 IF(NGP1.LE.MSTP(1).AND.NGP2.LE.MSTP(1))
4208 & WRITE(MSTU(11),5900) IDC,CHD1(1:10),
4209 & CHD2(1:10),CHD3(1:10),WDTP(J),BRPRI,
4210 & STATE(MDME(IDC,1)),BRFIN
4211 ENDIF
4212 130 CONTINUE
4213 ENDIF
4214 140 CONTINUE
4215 WRITE(MSTU(11),6000)
4216
4217C...Allowed incoming partons/particles at hard interaction.
4218 ELSEIF(MSTAT.EQ.3) THEN
4219 WRITE(MSTU(11),6100)
4220 CALL PYNAME(MINT(11),CHAU)
4221 CHIN(1)=CHAU(1:12)
4222 CALL PYNAME(MINT(12),CHAU)
4223 CHIN(2)=CHAU(1:12)
4224 WRITE(MSTU(11),6200) CHIN(1),CHIN(2)
4225 DO 150 I=-20,22
4226 IF(I.EQ.0) GOTO 150
4227 IA=IABS(I)
4228 IF(IA.GT.MSTP(58).AND.IA.LE.10) GOTO 150
4229 IF(IA.GT.10+2*MSTP(1).AND.IA.LE.20) GOTO 150
4230 CALL PYNAME(I,CHAU)
4231 WRITE(MSTU(11),6300) CHAU,STATE(KFIN(1,I)),CHAU,
4232 & STATE(KFIN(2,I))
4233 150 CONTINUE
4234 WRITE(MSTU(11),6400)
4235
4236C...User-defined limits on kinematical variables.
4237 ELSEIF(MSTAT.EQ.4) THEN
4238 WRITE(MSTU(11),6500)
4239 WRITE(MSTU(11),6600)
4240 SHRMAX=CKIN(2)
4241 IF(SHRMAX.LT.0D0) SHRMAX=VINT(1)
4242 WRITE(MSTU(11),6700) CKIN(1),CHKIN(1),SHRMAX
4243 PTHMIN=MAX(CKIN(3),CKIN(5))
4244 PTHMAX=CKIN(4)
4245 IF(PTHMAX.LT.0D0) PTHMAX=0.5D0*SHRMAX
4246 WRITE(MSTU(11),6800) CKIN(3),PTHMIN,CHKIN(2),PTHMAX
4247 WRITE(MSTU(11),6900) CHKIN(3),CKIN(6)
4248 DO 160 I=4,14
4249 WRITE(MSTU(11),6700) CKIN(2*I-1),CHKIN(I),CKIN(2*I)
4250 160 CONTINUE
4251 SPRMAX=CKIN(32)
4252 IF(SPRMAX.LT.0D0) SPRMAX=VINT(1)
4253 WRITE(MSTU(11),6700) CKIN(31),CHKIN(15),SPRMAX
4254 WRITE(MSTU(11),7000)
4255
4256C...Status codes and parameter values.
4257 ELSEIF(MSTAT.EQ.5) THEN
4258 WRITE(MSTU(11),7100)
4259 WRITE(MSTU(11),7200)
4260 DO 170 I=1,100
4261 WRITE(MSTU(11),7300) I,MSTP(I),PARP(I),100+I,MSTP(100+I),
4262 & PARP(100+I)
4263 170 CONTINUE
4264
4265C...List of all processes implemented in the program.
4266 ELSEIF(MSTAT.EQ.6) THEN
4267 WRITE(MSTU(11),7400)
4268 WRITE(MSTU(11),7500)
4269 DO 180 I=1,500
4270 IF(ISET(I).LT.0) GOTO 180
4271 WRITE(MSTU(11),7600) I,PROC(I),ISET(I),KFPR(I,1),KFPR(I,2)
4272 180 CONTINUE
4273 WRITE(MSTU(11),7700)
4274
4275 ELSEIF(MSTAT.EQ.7) THEN
4276 WRITE (MSTU(11),8000)
4277 NMODES(0)=0
4278 NMODES(10)=0
4279 NMODES(9)=0
4280 DO 290 ILR=1,2
4281 DO 280 KFSM=1,16
4282 KFSUSY=ILR*KSUSY1+KFSM
4283 NRVDC=0
4284C...SDOWN DECAYS
4285 IF (KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5) THEN
4286 NRVDC=3
4287 DO 190 I=1,NRVDC
4288 PBRAT(I)=0D0
4289 NMODES(I)=0
4290 190 CONTINUE
4291 CALL PYNAME(KFSUSY,CHTMP)
4292 CHD0=CHTMP//' '
4293 CHDC(1)=DNAME(3) // ' + ' // DNAME(1)
4294 CHDC(2)=DNAME(2) // ' + ' // DNAME(1)
4295 CHDC(3)=DNAME(1) // ' + ' // DNAME(1)
4296 KC=PYCOMP(KFSUSY)
4297 DO 200 J=1,MDCY(KC,3)
4298 IDC=J+MDCY(KC,2)-1
4299 ID1=IABS(KFDP(IDC,1))
4300 ID2=IABS(KFDP(IDC,2))
4301 IF (KFDP(IDC,3).EQ.0) THEN
4302 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4303 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4304 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4305 NMODES(1)=NMODES(1)+1
4306 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4307 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4308 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4309 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6)) THEN
4310 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4311 NMODES(2)=NMODES(2)+1
4312 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4313 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4314 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4315 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4316 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4317 NMODES(3)=NMODES(3)+1
4318 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4319 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4320 ENDIF
4321 ENDIF
4322 200 CONTINUE
4323 ENDIF
4324C...SUP DECAYS
4325 IF (KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6) THEN
4326 NRVDC=2
4327 DO 210 I=1,NRVDC
4328 NMODES(I)=0
4329 PBRAT(I)=0D0
4330 210 CONTINUE
4331 CALL PYNAME(KFSUSY,CHTMP)
4332 CHD0=CHTMP//' '
4333 CHDC(1)=DNAME(2) // ' + ' // DNAME(1)
4334 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4335 KC=PYCOMP(KFSUSY)
4336 DO 220 J=1,MDCY(KC,3)
4337 IDC=J+MDCY(KC,2)-1
4338 ID1=IABS(KFDP(IDC,1))
4339 ID2=IABS(KFDP(IDC,2))
4340 IF (KFDP(IDC,3).EQ.0) THEN
4341 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4342 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4343 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4344 NMODES(1)=NMODES(1)+1
4345 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4346 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4347 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4348 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4349 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4350 NMODES(2)=NMODES(2)+1
4351 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4352 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4353 ENDIF
4354 ENDIF
4355 220 CONTINUE
4356 ENDIF
4357C...SLEPTON DECAYS
4358 IF (KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15) THEN
4359 NRVDC=2
4360 DO 230 I=1,NRVDC
4361 PBRAT(I)=0D0
4362 NMODES(I)=0
4363 230 CONTINUE
4364 CALL PYNAME(KFSUSY,CHTMP)
4365 CHD0=CHTMP//' '
4366 CHDC(1)=DNAME(3) // ' + ' // DNAME(2)
4367 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4368 KC=PYCOMP(KFSUSY)
4369 DO 240 J=1,MDCY(KC,3)
4370 IDC=J+MDCY(KC,2)-1
4371 ID1=IABS(KFDP(IDC,1))
4372 ID2=IABS(KFDP(IDC,2))
4373 IF (KFDP(IDC,3).EQ.0) THEN
4374 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4375 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4376 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4377 NMODES(1)=NMODES(1)+1
4378 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4379 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4380 ENDIF
4381 IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND.(ID2
4382 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4383 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4384 NMODES(2)=NMODES(2)+1
4385 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4386 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4387 ENDIF
4388 ENDIF
4389 240 CONTINUE
4390 ENDIF
4391C...SNEUTRINO DECAYS
4392 IF ((KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16).AND.ILR.EQ.1)
4393 & THEN
4394 NRVDC=2
4395 DO 250 I=1,NRVDC
4396 PBRAT(I)=0D0
4397 NMODES(I)=0
4398 250 CONTINUE
4399 CALL PYNAME(KFSUSY,CHTMP)
4400 CHD0=CHTMP//' '
4401 CHDC(1)=DNAME(2) // ' + ' // DNAME(2)
4402 CHDC(2)=DNAME(1) // ' + ' // DNAME(1)
4403 KC=PYCOMP(KFSUSY)
4404 DO 260 J=1,MDCY(KC,3)
4405 IDC=J+MDCY(KC,2)-1
4406 ID1=IABS(KFDP(IDC,1))
4407 ID2=IABS(KFDP(IDC,2))
4408 IF (KFDP(IDC,3).EQ.0) THEN
4409 IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND.(ID2
4410 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15)) THEN
4411 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4412 NMODES(1)=NMODES(1)+1
4413 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4414 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4415 ENDIF
4416 IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND.(ID2
4417 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5)) THEN
4418 NMODES(2)=NMODES(2)+1
4419 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4420 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4421 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4422 ENDIF
4423 ENDIF
4424 260 CONTINUE
4425 ENDIF
4426 IF (NRVDC.NE.0) THEN
4427 DO 270 I=1,NRVDC
4428 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4429 NMODES(0)=NMODES(0)+NMODES(I)
4430 270 CONTINUE
4431 ENDIF
4432 280 CONTINUE
4433 290 CONTINUE
4434 DO 370 KFSM=21,37
4435 KFSUSY=KSUSY1+KFSM
4436 NRVDC=0
4437C...NEUTRALINO DECAYS
4438 IF (KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
4439 NRVDC=4
4440 DO 300 I=1,NRVDC
4441 PBRAT(I)=0D0
4442 NMODES(I)=0
4443 300 CONTINUE
4444 CALL PYNAME(KFSUSY,CHTMP)
4445 CHD0=CHTMP//' '
4446 CHDC(1)=DNAME(3) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4447 CHDC(2)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4448 CHDC(3)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4449 CHDC(4)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4450 KC=PYCOMP(KFSUSY)
4451 DO 310 J=1,MDCY(KC,3)
4452 IDC=J+MDCY(KC,2)-1
4453 ID1=IABS(KFDP(IDC,1))
4454 ID2=IABS(KFDP(IDC,2))
4455 ID3=IABS(KFDP(IDC,3))
4456 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4457 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.11.OR
4458 & .ID3.EQ.13.OR.ID3.EQ.15)) THEN
4459 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4460 NMODES(1)=NMODES(1)+1
4461 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4462 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4463 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4464 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4465 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4466 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4467 NMODES(2)=NMODES(2)+1
4468 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4469 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4470 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4471 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4472 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4473 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4474 NMODES(3)=NMODES(3)+1
4475 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4476 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4477 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4478 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4479 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4480 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4481 NMODES(4)=NMODES(4)+1
4482 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4483 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4484 ENDIF
4485 310 CONTINUE
4486 ENDIF
4487C...CHARGINO DECAYS
4488 IF (KFSM.EQ.24.OR.KFSM.EQ.37) THEN
4489 NRVDC=5
4490 DO 320 I=1,NRVDC
4491 PBRAT(I)=0D0
4492 NMODES(I)=0
4493 320 CONTINUE
4494 CALL PYNAME(KFSUSY,CHTMP)
4495 CHD0=CHTMP//' '
4496 CHDC(1)=DNAME(3) // ' + ' // DNAME(3) // ' + ' // DNAME(2)
4497 CHDC(2)=DNAME(2) // ' + ' // DNAME(2) // ' + ' // DNAME(2)
4498 CHDC(3)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4499 CHDC(4)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4500 CHDC(5)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4501 KC=PYCOMP(KFSUSY)
4502 DO 330 J=1,MDCY(KC,3)
4503 IDC=J+MDCY(KC,2)-1
4504 ID1=IABS(KFDP(IDC,1))
4505 ID2=IABS(KFDP(IDC,2))
4506 ID3=IABS(KFDP(IDC,3))
4507 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4508 & .EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ.12.OR
4509 & .ID3.EQ.14.OR.ID3.EQ.16)) THEN
4510 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4511 NMODES(1)=NMODES(1)+1
4512 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4513 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4514 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4515 & .(ID2.EQ.12.OR.ID2.EQ.14.OR.ID2.EQ.16).AND.(ID3.EQ
4516 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4517 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4518 NMODES(1)=NMODES(1)+1
4519 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4520 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4521 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4522 & .(ID2.EQ.11.OR.ID2.EQ.13.OR.ID2.EQ.15).AND.(ID3.EQ
4523 & .11.OR.ID3.EQ.13.OR.ID3.EQ.15)) THEN
4524 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4525 NMODES(2)=NMODES(2)+1
4526 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4527 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4528 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4529 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4530 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4531 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4532 NMODES(3)=NMODES(3)+1
4533 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4534 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4535 ELSE IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND
4536 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4537 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4538 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4539 NMODES(3)=NMODES(3)+1
4540 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4541 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4542 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4543 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4544 & .2.OR.ID3.EQ.4.OR.ID3.EQ.6)) THEN
4545 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4546 NMODES(4)=NMODES(4)+1
4547 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4548 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4549 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4550 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4551 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4552 PBRAT(4)=PBRAT(4)+BRAT(IDC)
4553 NMODES(4)=NMODES(4)+1
4554 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4555 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4556 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4557 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ
4558 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4559 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4560 NMODES(5)=NMODES(5)+1
4561 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4562 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4563 ELSE IF ((ID1.EQ.1.OR.ID1.EQ.3.OR.ID1.EQ.5).AND
4564 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ
4565 & .1.OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4566 PBRAT(5)=PBRAT(5)+BRAT(IDC)
4567 NMODES(5)=NMODES(5)+1
4568 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4569 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4570 ENDIF
4571 330 CONTINUE
4572 ENDIF
4573C...GLUINO DECAYS
4574 IF (KFSM.EQ.21) THEN
4575 NRVDC=3
4576 DO 340 I=1,NRVDC
4577 PBRAT(I)=0D0
4578 NMODES(I)=0
4579 340 CONTINUE
4580 CALL PYNAME(KFSUSY,CHTMP)
4581 CHD0=CHTMP//' '
4582 CHDC(1)=DNAME(3) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4583 CHDC(2)=DNAME(2) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4584 CHDC(3)=DNAME(1) // ' + ' // DNAME(1) // ' + ' // DNAME(1)
4585 KC=PYCOMP(KFSUSY)
4586 DO 350 J=1,MDCY(KC,3)
4587 IDC=J+MDCY(KC,2)-1
4588 ID1=IABS(KFDP(IDC,1))
4589 ID2=IABS(KFDP(IDC,2))
4590 ID3=IABS(KFDP(IDC,3))
4591 IF ((ID1.EQ.12.OR.ID1.EQ.14.OR.ID1.EQ.16).AND.(ID2
4592 & .EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1.OR
4593 & .ID3.EQ.3.OR.ID3.EQ.5)) THEN
4594 PBRAT(1)=PBRAT(1)+BRAT(IDC)
4595 NMODES(1)=NMODES(1)+1
4596 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4597 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4598 ELSE IF ((ID1.EQ.11.OR.ID1.EQ.13.OR.ID1.EQ.15).AND
4599 & .(ID2.EQ.2.OR.ID2.EQ.4.OR.ID2.EQ.6).AND.(ID3.EQ.1
4600 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4601 PBRAT(2)=PBRAT(2)+BRAT(IDC)
4602 NMODES(2)=NMODES(2)+1
4603 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4604 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4605 ELSE IF ((ID1.EQ.2.OR.ID1.EQ.4.OR.ID1.EQ.6).AND
4606 & .(ID2.EQ.1.OR.ID2.EQ.3.OR.ID2.EQ.5).AND.(ID3.EQ.1
4607 & .OR.ID3.EQ.3.OR.ID3.EQ.5)) THEN
4608 PBRAT(3)=PBRAT(3)+BRAT(IDC)
4609 NMODES(3)=NMODES(3)+1
4610 IF (BRAT(IDC).GT.0D0) NMODES(10)=NMODES(10)+1
4611 IF (BRAT(IDC).GT.EPS) NMODES(9)=NMODES(9)+1
4612 ENDIF
4613 350 CONTINUE
4614 ENDIF
4615
4616 IF (NRVDC.NE.0) THEN
4617 DO 360 I=1,NRVDC
4618 WRITE (MSTU(11),8200) CHD0, CHDC(I), PBRAT(I), NMODES(I)
4619 NMODES(0)=NMODES(0)+NMODES(I)
4620 360 CONTINUE
4621 ENDIF
4622 370 CONTINUE
4623 WRITE (MSTU(11),8100) NMODES(0), NMODES(10), NMODES(9)
4624
4625 IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
4626 WRITE (MSTU(11),8500)
4627 DO 400 IRV=1,3
4628 DO 390 JRV=1,3
4629 DO 380 KRV=1,3
4630 WRITE (MSTU(11),8700) IRV,JRV,KRV,RVLAM(IRV,JRV,KRV)
4631 & ,RVLAMP(IRV,JRV,KRV),RVLAMB(IRV,JRV,KRV)
4632 380 CONTINUE
4633 390 CONTINUE
4634 400 CONTINUE
4635 WRITE (MSTU(11),8600)
4636 ENDIF
4637 ENDIF
4638
4639C...Formats for printouts.
4640 5000 FORMAT('1',9('*'),1X,'PYSTAT: Statistics on Number of ',
4641 &'Events and Cross-sections',1X,9('*'))
4642 5100 FORMAT(/1X,78('=')/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',12X,
4643 &'Subprocess',12X,'I',6X,'Number of points',6X,'I',4X,'Sigma',3X,
4644 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',34('-'),'I',28('-'),
4645 &'I',4X,'(mb)',4X,'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,'I',1X,
4646 &'N:o',1X,'Type',25X,'I',4X,'Generated',9X,'Tried',1X,'I',12X,
4647 &'I'/1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/1X,'I',34X,'I',28X,
4648 &'I',12X,'I')
4649 5200 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I12,1X,I13,1X,'I',1X,1P,
4650 &D10.3,1X,'I')
4651 5300 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')/
4652 &1X,'I',34X,'I',28X,'I',12X,'I')
4653 5400 FORMAT(1X,'I',34X,'I',28X,'I',12X,'I'/1X,78('=')//
4654 &1X,'********* Total number of errors, excluding junctions =',
4655 &1X,I8,' *************'/
4656 &1X,'********* Total number of errors, including junctions =',
4657 &1X,I8,' *************'/
4658 &1X,'********* Total number of warnings = ',
4659 &1X,I8,' *************'/
4660 &1X,'********* Fraction of events that fail fragmentation ',
4661 &'cuts =',1X,F8.5,' *********'/)
4662 5500 FORMAT('1',27('*'),1X,'PYSTAT: Decay Widths and Branching ',
4663 &'Ratios',1X,27('*'))
4664 5600 FORMAT(/1X,98('=')/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4665 &1X,'I',5X,'Mother --> Branching/Decay Channel',8X,'I',1X,
4666 &'Width (GeV)',1X,'I',7X,'B.R.',1X,'I',1X,'Stat',1X,'I',2X,
4667 &'Eff. B.R.',1X,'I'/1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/
4668 &1X,98('='))
4669 5700 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,'I',1X,
4670 &I8,2X,A10,3X,'(m =',F10.3,')',2X,'-->',5X,'I',2X,1P,D10.3,0P,1X,
4671 &'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,1P,D10.3,0P,1X,'I')
4672 5800 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,15X,'I',2X,
4673 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4674 &1P,D10.3,0P,1X,'I')
4675 5900 FORMAT(1X,'I',1X,I8,2X,A10,1X,'+',1X,A10,1X,'+',1X,A10,2X,'I',2X,
4676 &1P,D10.3,0P,1X,'I',1X,1P,D10.3,0P,1X,'I',1X,A4,1X,'I',1X,
4677 &1P,D10.3,0P,1X,'I')
4678 6000 FORMAT(1X,'I',49X,'I',13X,'I',12X,'I',6X,'I',12X,'I'/1X,98('='))
4679 6100 FORMAT('1',7('*'),1X,'PYSTAT: Allowed Incoming Partons/',
4680 &'Particles at Hard Interaction',1X,7('*'))
4681 6200 FORMAT(/1X,78('=')/1X,'I',38X,'I',37X,'I'/1X,'I',1X,
4682 &'Beam particle:',1X,A12,10X,'I',1X,'Target particle:',1X,A12,7X,
4683 &'I'/1X,'I',38X,'I',37X,'I'/1X,'I',1X,'Content',6X,'State',19X,
4684 &'I',1X,'Content',6X,'State',18X,'I'/1X,'I',38X,'I',37X,'I'/1X,
4685 &78('=')/1X,'I',38X,'I',37X,'I')
4686 6300 FORMAT(1X,'I',1X,A9,5X,A4,19X,'I',1X,A9,5X,A4,18X,'I')
4687 6400 FORMAT(1X,'I',38X,'I',37X,'I'/1X,78('='))
4688 6500 FORMAT('1',12('*'),1X,'PYSTAT: User-Defined Limits on ',
4689 &'Kinematical Variables',1X,12('*'))
4690 6600 FORMAT(/1X,78('=')/1X,'I',76X,'I')
4691 6700 FORMAT(1X,'I',16X,1P,D10.3,0P,1X,'<',1X,A,1X,'<',1X,1P,D10.3,0P,
4692 &16X,'I')
4693 6800 FORMAT(1X,'I',3X,1P,D10.3,0P,1X,'(',1P,D10.3,0P,')',1X,'<',1X,A,
4694 &1X,'<',1X,1P,D10.3,0P,16X,'I')
4695 6900 FORMAT(1X,'I',29X,A,1X,'=',1X,1P,D10.3,0P,16X,'I')
4696 7000 FORMAT(1X,'I',76X,'I'/1X,78('='))
4697 7100 FORMAT('1',12('*'),1X,'PYSTAT: Summary of Status Codes and ',
4698 &'Parameter Values',1X,12('*'))
4699 7200 FORMAT(/3X,'I',4X,'MSTP(I)',9X,'PARP(I)',20X,'I',4X,'MSTP(I)',9X,
4700 &'PARP(I)'/)
4701 7300 FORMAT(1X,I3,5X,I6,6X,1P,D10.3,0P,18X,I3,5X,I6,6X,1P,D10.3)
4702 7400 FORMAT('1',13('*'),1X,'PYSTAT: List of implemented processes',
4703 &1X,13('*'))
4704 7500 FORMAT(/1X,65('=')/1X,'I',34X,'I',28X,'I'/1X,'I',12X,
4705 &'Subprocess',12X,'I',1X,'ISET',2X,'KFPR(I,1)',2X,'KFPR(I,2)',1X,
4706 &'I'/1X,'I',34X,'I',28X,'I'/1X,65('=')/1X,'I',34X,'I',28X,'I')
4707 7600 FORMAT(1X,'I',1X,I3,1X,A28,1X,'I',1X,I4,1X,I10,1X,I10,1X,'I')
4708 7700 FORMAT(1X,'I',34X,'I',28X,'I'/1X,65('='))
4709 8000 FORMAT(1X/ 1X/
4710 & 17X,'Sums over R-Violating branching ratios',1X/ 1X
4711 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I'/1X,'I',4X
4712 & ,'Mother --> Sum over final state flavours',4X,'I',2X
4713 & ,'BR(sum)',2X,'I',2X,'N',2X,'I'/1X,'I',50X,'I',11X,'I',5X,'I'
4714 & /1X,70('=')/1X,'I',50X,'I',11X,'I',5X,'I')
4715 8100 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I'/1X,70('=')/1X,'I',1X
4716 & ,'Total number of R-Violating modes :',3X,I5,24X,'I'/
4717 & 1X,'I',1X,'Total number with non-vanishing BR :',2X,I5,24X
4718 & ,'I'/1X,'I',1X,'Total number with BR > 0.001 :',8X,I5,24X,'I'
4719 & /1X,70('='))
4720 8200 FORMAT(1X,'I',1X,A9,1X,'-->',1X,A24,11X,
4721 & 'I',2X,1P,D8.2,0P,1X,'I',2X,I2,1X,'I')
4722 8300 FORMAT(1X,'I',50X,'I',11X,'I',5X,'I')
4723 8500 FORMAT(1X/ 1X/
4724 & 1X,'R-Violating couplings',1X/ 1X /
4725 & 1X,55('=')/
4726 & 1X,'I',1X,'IJK',1X,'I',2X,'LAMBDA(IJK)',2X,'I',2X
4727 & ,'LAMBDA''(IJK)',1X,'I',1X,"LAMBDA''(IJK)",1X,'I'/1X,'I',5X
4728 & ,'I',15X,'I',15X,'I',15X,'I')
4729 8600 FORMAT(1X,55('='))
4730 8700 FORMAT(1X,'I',1X,I1,I1,I1,1X,'I',1X,1P,D13.3,0P,1X,'I',1X,1P
4731 & ,D13.3,0P,1X,'I',1X,1P,D13.3,0P,1X,'I')
4732
4733 RETURN
4734 END
4735
4736C*********************************************************************
4737
4738C...PYUPEV
4739C...Administers the hard-process generation required for output to the
4740C...Les Houches event record.
4741
4742 SUBROUTINE PYUPEV
4743
4744C...Double precision and integer declarations.
4745 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
4746 IMPLICIT INTEGER(I-N)
4747 INTEGER PYK,PYCHGE,PYCOMP
4748
4749C...Commonblocks.
4750 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
4751 COMMON/PYCTAG/NCT,MCT(4000,2)
4752 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
4753 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
4754 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
4755 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
4756 COMMON/PYINT1/MINT(400),VINT(400)
4757 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
4758 COMMON/PYINT4/MWID(500),WIDS(500,5)
4759 SAVE /PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
4760 &/PYINT1/,/PYINT2/,/PYINT4/
4761
4762C...HEPEUP for output.
4763 INTEGER MAXNUP
4764 PARAMETER (MAXNUP=500)
4765 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
4766 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
4767 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
4768 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
4769 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
4770 SAVE /HEPEUP/
4771
4772C...Stop if no subprocesses on.
4773 IF(MINT(121).EQ.1.AND.MSTI(53).EQ.1) THEN
4774 WRITE(MSTU(11),5100)
4775 STOP
4776 ENDIF
4777
4778C...Special flags for hard-process generation only.
4779 MSTP71=MSTP(71)
4780 MSTP(71)=0
4781 MST128=MSTP(128)
4782 MSTP(128)=1
4783
4784C...Initial values for some counters.
4785 N=0
4786 MINT(5)=MINT(5)+1
4787 MINT(7)=0
4788 MINT(8)=0
4789 MINT(30)=0
4790 MINT(83)=0
4791 MINT(84)=MSTP(126)
4792 MSTU(24)=0
4793 MSTU70=0
4794 MSTJ14=MSTJ(14)
4795C...Normally, use K(I,4:5) colour info rather than /PYCTAG/.
4796 MINT(33)=0
4797
4798C...If variable energies: redo incoming kinematics and cross-section.
4799 MSTI(61)=0
4800 IF(MSTP(171).EQ.1) THEN
4801 CALL PYINKI(1)
4802 IF(MSTI(61).EQ.1) THEN
4803 MINT(5)=MINT(5)-1
4804 RETURN
4805 ENDIF
4806 IF(MINT(121).GT.1) CALL PYSAVE(3,1)
4807 CALL PYXTOT
4808 ENDIF
4809
4810C...Do not allow pileup events.
4811 MINT(82)=1
4812
4813C...Generate variables of hard scattering.
4814 MINT(51)=0
4815 MSTI(52)=0
4816 100 CONTINUE
4817 IF(MINT(51).NE.0.OR.MSTU(24).NE.0) MSTI(52)=MSTI(52)+1
4818 MINT(31)=0
4819 MINT(51)=0
4820 MINT(57)=0
4821 CALL PYRAND
4822 IF(MSTI(61).EQ.1) THEN
4823 MINT(5)=MINT(5)-1
4824 RETURN
4825 ENDIF
4826 IF(MINT(51).EQ.2) RETURN
4827 ISUB=MINT(1)
4828
4829 IF((ISUB.LE.90.OR.ISUB.GE.95).AND.ISUB.NE.99) THEN
4830C...Hard scattering (including low-pT):
4831C...reconstruct kinematics and colour flow of hard scattering.
4832 MINT31=MINT(31)
4833 110 MINT(31)=MINT31
4834 MINT(51)=0
4835 CALL PYSCAT
4836 IF(MINT(51).EQ.1) GOTO 100
4837 IPU1=MINT(84)+1
4838 IPU2=MINT(84)+2
4839
4840C...Decay of final state resonances.
4841 MINT(32)=0
4842 IF(MSTP(41).GE.1.AND.ISET(ISUB).LE.10.AND.ISUB.NE.95)
4843 & CALL PYRESD(0)
4844 IF(MINT(51).EQ.1) GOTO 100
4845 MINT(52)=N
4846
4847C...Longitudinal boost of hard scattering.
4848 BETAZ=(VINT(41)-VINT(42))/(VINT(41)+VINT(42))
4849 CALL PYROBO(MINT(84)+1,N,0D0,0D0,0D0,0D0,BETAZ)
4850
4851 ELSEIF(ISUB.NE.99) THEN
4852C...Diffractive and elastic scattering.
4853 CALL PYDIFF
4854
4855 ELSE
4856C...DIS scattering (photon flux external).
4857 CALL PYDISG
4858 IF(MINT(51).EQ.1) GOTO 100
4859 ENDIF
4860
4861C...Check that no odd resonance left undecayed.
4862 MINT(54)=N
4863 NFIX=N
4864 DO 120 I=MINT(84)+1,NFIX
4865 IF(K(I,1).GE.1.AND.K(I,1).LE.10.AND.K(I,2).NE.21.AND.
4866 & K(I,2).NE.22) THEN
4867 KCA=PYCOMP(K(I,2))
4868 IF(MWID(KCA).NE.0.AND.MDCY(KCA,1).GE.1) THEN
4869 CALL PYRESD(I)
4870 IF(MINT(51).EQ.1) GOTO 100
4871 ENDIF
4872 ENDIF
4873 120 CONTINUE
4874
4875C...Boost hadronic subsystem to overall rest frame.
4876C..(Only relevant when photon inside lepton beam.)
4877 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(4,WTGAGA)
4878
4879C...Store event information and calculate Monte Carlo estimates of
4880C...subprocess cross-sections.
4881 130 CALL PYDOCU
4882
4883C...Transform to the desired coordinate frame.
4884 140 CALL PYFRAM(MSTP(124))
4885 MSTU(70)=MSTU70
4886 PARU(21)=VINT(1)
4887
4888C...Restore special flags for hard-process generation only.
4889 MSTP(71)=MSTP71
4890 MSTP(128)=MST128
4891
4892C...Trace colour tags; convert to LHA style labels.
4893 NCT=100
4894 DO 150 I=MINT(84)+1,N
4895 MCT(I,1)=0
4896 MCT(I,2)=0
4897 150 CONTINUE
4898 DO 160 I=MINT(84)+1,N
4899 KQ=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
4900 IF(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
4901 IF(K(I,4).NE.0.AND.(KQ.EQ.1.OR.KQ.EQ.2).AND.MCT(I,1).EQ.0)
4902 & THEN
4903 IMO=MOD(K(I,4)/MSTU(5),MSTU(5))
4904 IDA=MOD(K(I,4),MSTU(5))
4905 IF(IMO.NE.0.AND.MOD(K(IMO,5)/MSTU(5),MSTU(5)).EQ.I.AND.
4906 & MCT(IMO,2).NE.0) THEN
4907 MCT(I,1)=MCT(IMO,2)
4908 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,4),MSTU(5)).EQ.I.AND.
4909 & MCT(IMO,1).NE.0) THEN
4910 MCT(I,1)=MCT(IMO,1)
4911 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,5),MSTU(5)).EQ.I.AND.
4912 & MCT(IDA,2).NE.0) THEN
4913 MCT(I,1)=MCT(IDA,2)
4914 ELSE
4915 NCT=NCT+1
4916 MCT(I,1)=NCT
4917 ENDIF
4918 ENDIF
4919 IF(K(I,5).NE.0.AND.(KQ.EQ.-1.OR.KQ.EQ.2).AND.MCT(I,2).EQ.0)
4920 & THEN
4921 IMO=MOD(K(I,5)/MSTU(5),MSTU(5))
4922 IDA=MOD(K(I,5),MSTU(5))
4923 IF(IMO.NE.0.AND.MOD(K(IMO,4)/MSTU(5),MSTU(5)).EQ.I.AND.
4924 & MCT(IMO,1).NE.0) THEN
4925 MCT(I,2)=MCT(IMO,1)
4926 ELSEIF(IMO.NE.0.AND.MOD(K(IMO,5),MSTU(5)).EQ.I.AND.
4927 & MCT(IMO,2).NE.0) THEN
4928 MCT(I,2)=MCT(IMO,2)
4929 ELSEIF(IDA.NE.0.AND.MOD(K(IDA,4),MSTU(5)).EQ.I.AND.
4930 & MCT(IDA,1).NE.0) THEN
4931 MCT(I,2)=MCT(IDA,1)
4932 ELSE
4933 NCT=NCT+1
4934 MCT(I,2)=NCT
4935 ENDIF
4936 ENDIF
4937 ENDIF
4938 160 CONTINUE
4939
4940C...Put event in HEPEUP commonblock.
4941 NUP=N-MINT(84)
4942 IDPRUP=MINT(1)
4943 XWGTUP=1D0
4944 SCALUP=VINT(53)
4945 AQEDUP=VINT(57)
4946 AQCDUP=VINT(58)
4947 DO 180 I=1,NUP
4948 IDUP(I)=K(I+MINT(84),2)
4949 IF(I.LE.2) THEN
4950 ISTUP(I)=-1
4951 MOTHUP(1,I)=0
4952 MOTHUP(2,I)=0
4953 ELSEIF(K(I+4,3).EQ.0) THEN
4954 ISTUP(I)=1
4955 MOTHUP(1,I)=1
4956 MOTHUP(2,I)=2
4957 ELSE
4958 ISTUP(I)=1
4959 MOTHUP(1,I)=K(I+MINT(84),3)-MINT(84)
4960 MOTHUP(2,I)=0
4961 ENDIF
4962 IF(I.GE.3.AND.K(I+MINT(84),3).GT.0)
4963 & ISTUP(K(I+MINT(84),3)-MINT(84))=2
4964 ICOLUP(1,I)=MCT(I+MINT(84),1)
4965 ICOLUP(2,I)=MCT(I+MINT(84),2)
4966 DO 170 J=1,5
4967 PUP(J,I)=P(I+MINT(84),J)
4968 170 CONTINUE
4969 VTIMUP(I)=V(I,5)
4970 SPINUP(I)=9D0
4971 180 CONTINUE
4972
4973C...Optionally write out event to disk. Minimal size for time/spin fields.
4974 IF(MSTP(162).GT.0) THEN
4975 WRITE(MSTP(162),5200) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
4976 DO 190 I=1,NUP
4977 IF(VTIMUP(I).EQ.0D0) THEN
4978 WRITE(MSTP(162),5300) IDUP(I),ISTUP(I),MOTHUP(1,I),
4979 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4980 & ' 0. 9.'
4981 ELSE
4982 WRITE(MSTP(162),5400) IDUP(I),ISTUP(I),MOTHUP(1,I),
4983 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5),
4984 & VTIMUP(I),' 9.'
4985 ENDIF
4986 190 CONTINUE
4987
4988C...Optional extra line with parton-density information.
4989 IF(MSTP(165).GE.1) WRITE(MSTP(162),5500) MSTI(15),MSTI(16),
4990 & PARI(33),PARI(34),PARI(23),PARI(29),PARI(30)
4991 ENDIF
4992
4993C...Error messages and other print formats.
4994 5100 FORMAT(1X,'Error: no subprocess switched on.'/
4995 &1X,'Execution stopped.')
4996 5200 FORMAT(1P,2I6,4E14.6)
4997 5300 FORMAT(1P,I8,5I5,5E18.10,A6)
4998 5400 FORMAT(1P,I8,5I5,5E18.10,E12.4,A3)
4999 5500 FORMAT(1P,'#pdf ',2I5,5E18.10)
5000
5001 RETURN
5002 END
5003
5004C*********************************************************************
5005
5006C...PYUPIN
5007C...Fills the HEPRUP commonblock with info on incoming beams and allowed
5008C...processes, and optionally stores that information on file.
5009
5010 SUBROUTINE PYUPIN
5011
5012C...Double precision and integer declarations.
5013 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5014 IMPLICIT INTEGER(I-N)
5015
5016C...Commonblocks.
5017 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5018 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5019 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5020 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
5021 SAVE /PYJETS/,/PYSUBS/,/PYPARS/,/PYINT5/
5022
5023C...User process initialization commonblock.
5024 INTEGER MAXPUP
5025 PARAMETER (MAXPUP=100)
5026 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5027 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5028 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5029 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5030 &LPRUP(MAXPUP)
5031 SAVE /HEPRUP/
5032
5033C...Store info on incoming beams.
5034 IDBMUP(1)=K(1,2)
5035 IDBMUP(2)=K(2,2)
5036 EBMUP(1)=P(1,4)
5037 EBMUP(2)=P(2,4)
5038 PDFGUP(1)=0
5039 PDFGUP(2)=0
5040 PDFSUP(1)=MSTP(51)
5041 PDFSUP(2)=MSTP(51)
5042
5043C...Event weighting strategy.
5044 IDWTUP=3
5045
5046C...Info on individual processes.
5047 NPRUP=0
5048 DO 100 ISUB=1,500
5049 IF(MSUB(ISUB).EQ.1) THEN
5050 NPRUP=NPRUP+1
5051 XSECUP(NPRUP)=1D9*XSEC(ISUB,3)
5052 XERRUP(NPRUP)=XSECUP(NPRUP)/SQRT(MAX(1D0,DBLE(NGEN(ISUB,3))))
5053 XMAXUP(NPRUP)=1D0
5054 LPRUP(NPRUP)=ISUB
5055 ENDIF
5056 100 CONTINUE
5057
5058C...Write info to file.
5059 IF(MSTP(161).GT.0) THEN
5060 WRITE(MSTP(161),5100) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),
5061 & PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5062 DO 110 IPR=1,NPRUP
5063 WRITE(MSTP(161),5200) XSECUP(IPR),XERRUP(IPR),XMAXUP(IPR),
5064 & LPRUP(IPR)
5065 110 CONTINUE
5066 ENDIF
5067
5068C...Formats for printout.
5069 5100 FORMAT(1P,2I8,2E14.6,6I6)
5070 5200 FORMAT(1P,3E14.6,I6)
5071
5072 RETURN
5073 END
5074
5075
5076C*********************************************************************
5077
5078C...Combine the two old-style Pythia initialization and event files
5079C...into a single Les Houches Event File.
5080
5081 SUBROUTINE PYLHEF
5082
5083C...Double precision and integer declarations.
5084 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5085 IMPLICIT INTEGER(I-N)
5086
5087C...PYTHIA commonblock: only used to provide read/write units and version.
5088 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5089 SAVE /PYPARS/
5090
5091C...User process initialization commonblock.
5092 INTEGER MAXPUP
5093 PARAMETER (MAXPUP=100)
5094 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5095 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5096 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5097 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5098 &LPRUP(MAXPUP)
5099 SAVE /HEPRUP/
5100
5101C...User process event common block.
5102 INTEGER MAXNUP
5103 PARAMETER (MAXNUP=500)
5104 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
5105 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
5106 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
5107 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
5108 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
5109 SAVE /HEPEUP/
5110
5111C...Lines to read in assumed never longer than 200 characters.
5112 PARAMETER (MAXLEN=200)
5113 CHARACTER*(MAXLEN) STRING
5114
5115C...Format for reading lines.
5116 CHARACTER*6 STRFMT
5117 STRFMT='(A000)'
5118 WRITE(STRFMT(3:5),'(I3)') MAXLEN
5119
5120C...Rewind initialization and event files.
5121 REWIND MSTP(161)
5122 REWIND MSTP(162)
5123
5124C...Write header info.
5125 WRITE(MSTP(163),'(A)') '<LesHouchesEvents version="1.0">'
5126 WRITE(MSTP(163),'(A)') '<!--'
5127 WRITE(MSTP(163),'(A,I1,A1,I3)') 'File generated with PYTHIA ',
5128 &MSTP(181),'.',MSTP(182)
5129 WRITE(MSTP(163),'(A)') '-->'
5130
5131C...Read first line of initialization info and get number of processes.
5132 READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5133 READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),
5134 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
5135
5136C...Copy initialization lines, omitting trailing blanks.
5137C...Embed in <init> ... </init> block.
5138 WRITE(MSTP(163),'(A)') '<init>'
5139 DO 140 IPR=0,NPRUP
5140 IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
5141 LEN=MAXLEN+1
5142 120 LEN=LEN-1
5143 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
5144 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5145 140 CONTINUE
5146 WRITE(MSTP(163),'(A)') '</init>'
5147
5148C...Begin event loop. Read first line of event info or already done.
5149 READ(MSTP(162),'(A)',END=320,ERR=400) STRING
5150 200 CONTINUE
5151
5152C...Look at first line to know number of particles in event.
5153 READ(STRING,*,ERR=400) NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP
5154
5155C...Begin an <event> block. Copy event lines, omitting trailing blanks.
5156 WRITE(MSTP(163),'(A)') '<event>'
5157 DO 240 I=0,NUP
5158 IF(I.GT.0) READ(MSTP(162),'(A)',END=400,ERR=400) STRING
5159 LEN=MAXLEN+1
5160 220 LEN=LEN-1
5161 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 220
5162 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5163 240 CONTINUE
5164
5165C...Copy trailing comment lines - with a # in the first column - as is.
5166 260 READ(MSTP(162),'(A)',END=300,ERR=400) STRING
5167 IF(STRING(1:1).EQ.'#') THEN
5168 LEN=MAXLEN+1
5169 280 LEN=LEN-1
5170 IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 280
5171 WRITE(MSTP(163),'(A)',ERR=400) STRING(1:LEN)
5172 GOTO 260
5173 ENDIF
5174
5175C..End the <event> block. Loop back to look for next event.
5176 WRITE(MSTP(163),'(A)') '</event>'
5177 GOTO 200
5178
5179C...Successfully reached end of event loop: write closing tag
5180C...and remove temporary intermediate files (unless asked not to).
5181 300 WRITE(MSTP(163),'(A)') '</event>'
5182 320 WRITE(MSTP(163),'(A)') '</LesHouchesEvents>'
5183 IF(MSTP(164).EQ.1) RETURN
5184 CLOSE(MSTP(161),ERR=400,STATUS='DELETE')
5185 CLOSE(MSTP(162),ERR=400,STATUS='DELETE')
5186 RETURN
5187
5188C...Error exit.
5189 400 WRITE(*,*) ' PYLHEF file joining failed!'
5190
5191 RETURN
5192 END
5193
5194C*********************************************************************
5195
5196C...PYINRE
5197C...Calculates full and effective widths of gauge bosons, stores
5198C...masses and widths, rescales coefficients to be used for
5199C...resonance production generation.
5200
5201 SUBROUTINE PYINRE
5202
5203C...Double precision and integer declarations.
5204 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5205 IMPLICIT INTEGER(I-N)
5206 INTEGER PYK,PYCHGE,PYCOMP
5207C...Parameter statement to help give large particle numbers.
5208 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
5209 &KEXCIT=4000000,KDIMEN=5000000)
5210C...Commonblocks.
5211 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5212 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5213 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
5214 COMMON/PYDAT4/CHAF(500,2)
5215 CHARACTER CHAF*16
5216 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5217 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5218 COMMON/PYINT1/MINT(400),VINT(400)
5219 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
5220 COMMON/PYINT4/MWID(500),WIDS(500,5)
5221 COMMON/PYINT6/PROC(0:500)
5222 CHARACTER PROC*28
5223 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
5224 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYSUBS/,/PYPARS/,
5225 &/PYINT1/,/PYINT2/,/PYINT4/,/PYINT6/,/PYMSSM/
5226C...Local arrays and data.
5227 CHARACTER PRTMP*9
5228 DIMENSION WDTP(0:400),WDTE(0:400,0:5),WDTPM(0:400),
5229 &WDTEM(0:400,0:5),KCORD(500),PMORD(500)
5230
5231C...Born level couplings in MSSM Higgs doublet sector.
5232 XW=PARU(102)
5233 XWV=XW
5234 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
5235 XW1=1D0-XW
5236 IF(MSTP(4).EQ.2) THEN
5237 TANBE=PARU(141)
5238 RATBE=((1D0-TANBE**2)/(1D0+TANBE**2))**2
5239 SQMZ=PMAS(23,1)**2
5240 SQMW=PMAS(24,1)**2
5241 SQMH=PMAS(25,1)**2
5242 SQMA=SQMH*(SQMZ-SQMH)/(SQMZ*RATBE-SQMH)
5243 SQMHP=0.5D0*(SQMA+SQMZ+SQRT((SQMA+SQMZ)**2-4D0*SQMA*SQMZ*RATBE))
5244 SQMHC=SQMA+SQMW
5245 IF(SQMH.GE.SQMZ.OR.MIN(SQMA,SQMHP,SQMHC).LE.0D0) THEN
5246 WRITE(MSTU(11),5000)
5247 CALL PYSTOP(101)
5248 ENDIF
5249 PMAS(35,1)=SQRT(SQMHP)
5250 PMAS(36,1)=SQRT(SQMA)
5251 PMAS(37,1)=SQRT(SQMHC)
5252 ALSU=0.5D0*ATAN(2D0*TANBE*(SQMA+SQMZ)/((1D0-TANBE**2)*
5253 & (SQMA-SQMZ)))
5254 BESU=ATAN(TANBE)
5255 PARU(142)=1D0
5256 PARU(143)=1D0
5257 PARU(161)=-SIN(ALSU)/COS(BESU)
5258 PARU(162)=COS(ALSU)/SIN(BESU)
5259 PARU(163)=PARU(161)
5260 PARU(164)=SIN(BESU-ALSU)
5261 PARU(165)=PARU(164)
5262 PARU(168)=SIN(BESU-ALSU)+0.5D0*COS(2D0*BESU)*SIN(BESU+ALSU)/XW
5263 PARU(171)=COS(ALSU)/COS(BESU)
5264 PARU(172)=SIN(ALSU)/SIN(BESU)
5265 PARU(173)=PARU(171)
5266 PARU(174)=COS(BESU-ALSU)
5267 PARU(175)=PARU(174)
5268 PARU(176)=COS(2D0*ALSU)*COS(BESU+ALSU)-2D0*SIN(2D0*ALSU)*
5269 & SIN(BESU+ALSU)
5270 PARU(177)=COS(2D0*BESU)*COS(BESU+ALSU)
5271 PARU(178)=COS(BESU-ALSU)-0.5D0*COS(2D0*BESU)*COS(BESU+ALSU)/XW
5272 PARU(181)=TANBE
5273 PARU(182)=1D0/TANBE
5274 PARU(183)=PARU(181)
5275 PARU(184)=0D0
5276 PARU(185)=PARU(184)
5277 PARU(186)=COS(BESU-ALSU)
5278 PARU(187)=SIN(BESU-ALSU)
5279 PARU(188)=PARU(186)
5280 PARU(189)=PARU(187)
5281 PARU(190)=0D0
5282 PARU(195)=COS(BESU-ALSU)
5283 ENDIF
5284
5285C...Reset effective widths of gauge bosons.
5286 DO 110 I=1,500
5287 DO 100 J=1,5
5288 WIDS(I,J)=1D0
5289 100 CONTINUE
5290 110 CONTINUE
5291
5292C...Order resonances by increasing mass (except Z0 and W+/-).
5293 NRES=0
5294 DO 140 KC=1,500
5295 KF=KCHG(KC,4)
5296 IF(KF.EQ.0) GOTO 140
5297 IF(MWID(KC).EQ.0) GOTO 140
5298 IF(KC.EQ.7.OR.KC.EQ.8.OR.KC.EQ.17.OR.KC.EQ.18) THEN
5299 IF(MSTP(1).LE.3) GOTO 140
5300 ENDIF
5301 IF(KF/KSUSY1.EQ.1.OR.KF/KSUSY1.EQ.2) THEN
5302 IF(IMSS(1).LE.0) GOTO 140
5303 ENDIF
5304 NRES=NRES+1
5305 PMRES=PMAS(KC,1)
5306 IF(KC.EQ.23.OR.KC.EQ.24) PMRES=0D0
5307 DO 120 I1=NRES-1,1,-1
5308 IF(PMRES.GE.PMORD(I1)) GOTO 130
5309 KCORD(I1+1)=KCORD(I1)
5310 PMORD(I1+1)=PMORD(I1)
5311 120 CONTINUE
5312 130 KCORD(I1+1)=KC
5313 PMORD(I1+1)=PMRES
5314 140 CONTINUE
5315
5316C...Loop over possible resonances.
5317 DO 180 I=1,NRES
5318 KC=KCORD(I)
5319 KF=KCHG(KC,4)
5320
5321C...Check that no fourth generation channels on by mistake.
5322 IF(MSTP(1).LE.3) THEN
5323 DO 150 J=1,MDCY(KC,3)
5324 IDC=J+MDCY(KC,2)-1
5325 KFA1=IABS(KFDP(IDC,1))
5326 KFA2=IABS(KFDP(IDC,2))
5327 IF(KFA1.EQ.7.OR.KFA1.EQ.8.OR.KFA1.EQ.17.OR.KFA1.EQ.18.OR.
5328 & KFA2.EQ.7.OR.KFA2.EQ.8.OR.KFA2.EQ.17.OR.KFA2.EQ.18)
5329 & MDME(IDC,1)=-1
5330 150 CONTINUE
5331 ENDIF
5332
5333C...Check that no supersymmetric channels on by mistake.
5334 IF(IMSS(1).LE.0) THEN
5335 DO 160 J=1,MDCY(KC,3)
5336 IDC=J+MDCY(KC,2)-1
5337 KFA1S=IABS(KFDP(IDC,1))/KSUSY1
5338 KFA2S=IABS(KFDP(IDC,2))/KSUSY1
5339 IF(KFA1S.EQ.1.OR.KFA1S.EQ.2.OR.KFA2S.EQ.1.OR.KFA2S.EQ.2)
5340 & MDME(IDC,1)=-1
5341 160 CONTINUE
5342 ENDIF
5343
5344C...Find mass and evaluate width.
5345 PMR=PMAS(KC,1)
5346 IF(KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) MINT(62)=1
5347 IF(MWID(KC).EQ.3) MINT(63)=1
5348 CALL PYWIDT(KF,PMR**2,WDTP,WDTE)
5349 MINT(51)=0
5350
5351C...Evaluate suppression factors due to non-simulated channels.
5352 IF(KCHG(KC,3).EQ.0) THEN
5353 WDTP0I=0D0
5354 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5355 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))**2+
5356 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5357 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5358 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5359 WIDS(KC,3)=0D0
5360 WIDS(KC,4)=0D0
5361 WIDS(KC,5)=0D0
5362 ELSE
5363 IF(MWID(KC).EQ.3) MINT(63)=1
5364 CALL PYWIDT(-KF,PMR**2,WDTPM,WDTEM)
5365 MINT(51)=0
5366 WDTP0I=0D0
5367 IF(WDTP(0).GT.0D0) WDTP0I=1D0/WDTP(0)
5368 WIDS(KC,1)=((WDTE(0,1)+WDTE(0,2))*(WDTEM(0,1)+WDTEM(0,3))+
5369 & (WDTE(0,1)+WDTE(0,2))*(WDTEM(0,4)+WDTEM(0,5))+
5370 & (WDTE(0,4)+WDTE(0,5))*(WDTEM(0,1)+WDTEM(0,3))+
5371 & WDTE(0,4)*WDTEM(0,5)+WDTE(0,5)*WDTEM(0,4))*WDTP0I**2
5372 WIDS(KC,2)=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*WDTP0I
5373 WIDS(KC,3)=(WDTEM(0,1)+WDTEM(0,3)+WDTEM(0,4))*WDTP0I
5374 WIDS(KC,4)=((WDTE(0,1)+WDTE(0,2))**2+
5375 & 2D0*(WDTE(0,1)+WDTE(0,2))*(WDTE(0,4)+WDTE(0,5))+
5376 & 2D0*WDTE(0,4)*WDTE(0,5))*WDTP0I**2
5377 WIDS(KC,5)=((WDTEM(0,1)+WDTEM(0,3))**2+
5378 & 2D0*(WDTEM(0,1)+WDTEM(0,3))*(WDTEM(0,4)+WDTEM(0,5))+
5379 & 2D0*WDTEM(0,4)*WDTEM(0,5))*WDTP0I**2
5380 ENDIF
5381
5382C...Set resonance widths and branching ratios;
5383C...also on/off switch for decays.
5384 IF(MWID(KC).EQ.1.OR.MWID(KC).EQ.3) THEN
5385 PMAS(KC,2)=WDTP(0)
5386 PMAS(KC,3)=MIN(0.9D0*PMAS(KC,1),10D0*PMAS(KC,2))
5387 IF(MSTP(41).EQ.0.OR.MSTP(41).EQ.1) MDCY(KC,1)=MSTP(41)
5388 DO 170 J=1,MDCY(KC,3)
5389 IDC=J+MDCY(KC,2)-1
5390 BRAT(IDC)=0D0
5391 IF(WDTP(0).GT.0D0) BRAT(IDC)=WDTP(J)/WDTP(0)
5392 170 CONTINUE
5393 ENDIF
5394 180 CONTINUE
5395
5396C...Flavours of leptoquark: redefine charge and name.
5397 KFLQQ=KFDP(MDCY(42,2),1)
5398 KFLQL=KFDP(MDCY(42,2),2)
5399 KCHG(42,1)=KCHG(PYCOMP(KFLQQ),1)*ISIGN(1,KFLQQ)+
5400 &KCHG(PYCOMP(KFLQL),1)*ISIGN(1,KFLQL)
5401 LL=1
5402 IF(IABS(KFLQL).EQ.13) LL=2
5403 IF(IABS(KFLQL).EQ.15) LL=3
5404 CHAF(42,1)='LQ_'//CHAF(IABS(KFLQQ),1)(1:1)//
5405 &CHAF(IABS(KFLQL),1)(1:LL)//' '
5406 CHAF(42,2)=CHAF(42,2)(1:4+LL)//'bar '
5407
5408C...Special cases in treatment of gamma*/Z0: redefine process name.
5409 IF(MSTP(43).EQ.1) THEN
5410 PROC(1)='f + fbar -> gamma*'
5411 PROC(15)='f + fbar -> g + gamma*'
5412 PROC(19)='f + fbar -> gamma + gamma*'
5413 PROC(30)='f + g -> f + gamma*'
5414 PROC(35)='f + gamma -> f + gamma*'
5415 ELSEIF(MSTP(43).EQ.2) THEN
5416 PROC(1)='f + fbar -> Z0'
5417 PROC(15)='f + fbar -> g + Z0'
5418 PROC(19)='f + fbar -> gamma + Z0'
5419 PROC(30)='f + g -> f + Z0'
5420 PROC(35)='f + gamma -> f + Z0'
5421 ELSEIF(MSTP(43).EQ.3) THEN
5422 PROC(1)='f + fbar -> gamma*/Z0'
5423 PROC(15)='f + fbar -> g + gamma*/Z0'
5424 PROC(19)='f+ fbar -> gamma + gamma*/Z0'
5425 PROC(30)='f + g -> f + gamma*/Z0'
5426 PROC(35)='f + gamma -> f + gamma*/Z0'
5427 ENDIF
5428
5429C...Special cases in treatment of gamma*/Z0/Z'0: redefine process name.
5430 IF(MSTP(44).EQ.1) THEN
5431 PROC(141)='f + fbar -> gamma*'
5432 ELSEIF(MSTP(44).EQ.2) THEN
5433 PROC(141)='f + fbar -> Z0'
5434 ELSEIF(MSTP(44).EQ.3) THEN
5435 PROC(141)='f + fbar -> Z''0'
5436 ELSEIF(MSTP(44).EQ.4) THEN
5437 PROC(141)='f + fbar -> gamma*/Z0'
5438 ELSEIF(MSTP(44).EQ.5) THEN
5439 PROC(141)='f + fbar -> gamma*/Z''0'
5440 ELSEIF(MSTP(44).EQ.6) THEN
5441 PROC(141)='f + fbar -> Z0/Z''0'
5442 ELSEIF(MSTP(44).EQ.7) THEN
5443 PROC(141)='f + fbar -> gamma*/Z0/Z''0'
5444 ENDIF
5445
5446C...Special cases in treatment of WW -> WW: redefine process name.
5447 IF(MSTP(45).EQ.1) THEN
5448 PROC(77)='W+ + W+ -> W+ + W+'
5449 ELSEIF(MSTP(45).EQ.2) THEN
5450 PROC(77)='W+ + W- -> W+ + W-'
5451 ELSEIF(MSTP(45).EQ.3) THEN
5452 PROC(77)='W+/- + W+/- -> W+/- + W+/-'
5453 ENDIF
5454
5455C...Initialize Generic Processes
5456 KFGEN=9900001
5457 KCGEN=PYCOMP(KFGEN)
5458 IF(KCGEN.GT.0) THEN
5459 IDCY=MDCY(KCGEN,2)
5460 IF(IDCY.GT.0) THEN
5461 KFF1=KFDP(IDCY+1,1)
5462 KFF2=KFDP(IDCY+1,2)
5463 KCF1=PYCOMP(KFF1)
5464 KCF2=PYCOMP(KFF2)
5465 IJ1=1
5466 IJ2=1
5467 KCI1=PYCOMP(KFDP(IDCY,1))
5468 IF(KFDP(IDCY,1).LT.0) IJ1=2
5469 KCI2=PYCOMP(KFDP(IDCY,2))
5470 IF(KFDP(IDCY,2).LT.0) IJ2=2
5471 ITMP1=0
5472 190 ITMP1=ITMP1+1
5473 IF(CHAF(KCI1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.4)
5474 & GOTO 190
5475 ITMP2=0
5476 200 ITMP2=ITMP2+1
5477 IF(CHAF(KCI2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.4)
5478 & GOTO 200
5479 PRTMP=CHAF(KCI1,IJ1)(1:ITMP1)//'+'//CHAF(KCI2,IJ2)(1:ITMP2)
5480 ITMP3=0
5481 205 ITMP3=ITMP3+1
5482 IF(PRTMP(ITMP3+1:ITMP3+1).NE.' '.AND.ITMP3.LT.9)
5483 & GOTO 205
5484 PROC(481)=PRTMP(1:ITMP3)//' -> '//CHAF(KCGEN,1)
5485 IJ1=1
5486 IJ2=1
5487 IF(KFF1.LT.0) IJ1=2
5488 IF(KFF2.LT.0) IJ2=2
5489 ITMP1=0
5490 210 ITMP1=ITMP1+1
5491 IF(CHAF(KCF1,IJ1)(ITMP1+1:ITMP1+1).NE.' '.AND.ITMP1.LT.8)
5492 & GOTO 210
5493 ITMP2=0
5494 220 ITMP2=ITMP2+1
5495 IF(CHAF(KCF2,IJ2)(ITMP2+1:ITMP2+1).NE.' '.AND.ITMP2.LT.8)
5496 & GOTO 220
5497 PROC(482)=PRTMP(1:ITMP3)//' -> '//CHAF(KCF1,IJ1)(1:ITMP1)//
5498 & '+'//CHAF(KCF2,IJ2)(1:ITMP2)
5499 ENDIF
5500 ENDIF
5501
5502
5503
5504C...Format for error information.
5505 5000 FORMAT(1X,'Error: unphysical input tan^2(beta) and m_H ',
5506 &'combination'/1X,'Execution stopped!')
5507
5508 RETURN
5509 END
5510
5511C*********************************************************************
5512
5513C...PYINBM
5514C...Identifies the two incoming particles and the choice of frame.
5515
5516 SUBROUTINE PYINBM(CHFRAM,CHBEAM,CHTARG,WIN)
5517
5518C...Double precision and integer declarations.
5519 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5520 IMPLICIT INTEGER(I-N)
5521 INTEGER PYK,PYCHGE,PYCOMP
5522
5523C...User process initialization commonblock.
5524 INTEGER MAXPUP
5525 PARAMETER (MAXPUP=100)
5526 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5527 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5528 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5529 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5530 &LPRUP(MAXPUP)
5531 SAVE /HEPRUP/
5532
5533C...Commonblocks.
5534 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5535 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5536 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5537 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5538 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5539 COMMON/PYINT1/MINT(400),VINT(400)
5540 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5541
5542C...Local arrays, character variables and data.
5543 CHARACTER CHFRAM*12,CHBEAM*12,CHTARG*12,CHCOM(3)*12,CHALP(2)*26,
5544 &CHIDNT(3)*12,CHTEMP*12,CHCDE(39)*12,CHINIT*76,CHNAME*16
5545 DIMENSION LEN(3),KCDE(39),PM(2)
5546 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
5547 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
5548 DATA CHCDE/ 'e- ','e+ ','nu_e ',
5549 &'nu_ebar ','mu- ','mu+ ','nu_mu ',
5550 &'nu_mubar ','tau- ','tau+ ','nu_tau ',
5551 &'nu_taubar ','pi+ ','pi- ','n0 ',
5552 &'nbar0 ','p+ ','pbar- ','gamma ',
5553 &'lambda0 ','sigma- ','sigma0 ','sigma+ ',
5554 &'xi- ','xi0 ','omega- ','pi0 ',
5555 &'reggeon ','pomeron ','gamma/e- ','gamma/e+ ',
5556 &'gamma/mu- ','gamma/mu+ ','gamma/tau- ','gamma/tau+ ',
5557 &'k+ ','k- ','ks0 ','kl0 '/
5558 DATA KCDE/11,-11,12,-12,13,-13,14,-14,15,-15,16,-16,
5559 &211,-211,2112,-2112,2212,-2212,22,3122,3112,3212,3222,
5560 &3312,3322,3334,111,110,990,6*22,321,-321,310,130/
5561
5562C...Store initial energy. Default frame.
5563 VINT(290)=WIN
5564 MINT(111)=0
5565
5566C...Special user process initialization; convert to normal input.
5567 IF(CHFRAM(1:1).EQ.'u'.OR.CHFRAM(1:1).EQ.'U') THEN
5568 MINT(111)=11
5569 IF(PDFGUP(1).EQ.-9.OR.PDFGUP(2).EQ.-9) MINT(111)=12
5570 CALL PYNAME(IDBMUP(1),CHNAME)
5571 CHBEAM=CHNAME(1:12)
5572 CALL PYNAME(IDBMUP(2),CHNAME)
5573 CHTARG=CHNAME(1:12)
5574 ENDIF
5575
5576C...Convert character variables to lowercase and find their length.
5577 CHCOM(1)=CHFRAM
5578 CHCOM(2)=CHBEAM
5579 CHCOM(3)=CHTARG
5580 DO 130 I=1,3
5581 LEN(I)=12
5582 DO 110 LL=12,1,-1
5583 IF(LEN(I).EQ.LL.AND.CHCOM(I)(LL:LL).EQ.' ') LEN(I)=LL-1
5584 DO 100 LA=1,26
5585 IF(CHCOM(I)(LL:LL).EQ.CHALP(2)(LA:LA)) CHCOM(I)(LL:LL)=
5586 & CHALP(1)(LA:LA)
5587 100 CONTINUE
5588 110 CONTINUE
5589 CHIDNT(I)=CHCOM(I)
5590
5591C...Fix up bar, underscore and charge in particle name (if needed).
5592 DO 120 LL=1,10
5593 IF(CHIDNT(I)(LL:LL).EQ.'~') THEN
5594 CHTEMP=CHIDNT(I)
5595 CHIDNT(I)=CHTEMP(1:LL-1)//'bar'//CHTEMP(LL+1:10)//' '
5596 ENDIF
5597 120 CONTINUE
5598 IF(CHIDNT(I)(1:2).EQ.'nu'.AND.CHIDNT(I)(3:3).NE.'_') THEN
5599 CHTEMP=CHIDNT(I)
5600 CHIDNT(I)='nu_'//CHTEMP(3:7)
5601 ELSEIF(CHIDNT(I)(1:2).EQ.'n ') THEN
5602 CHIDNT(I)(1:3)='n0 '
5603 ELSEIF(CHIDNT(I)(1:4).EQ.'nbar') THEN
5604 CHIDNT(I)(1:5)='nbar0'
5605 ELSEIF(CHIDNT(I)(1:2).EQ.'p ') THEN
5606 CHIDNT(I)(1:3)='p+ '
5607 ELSEIF(CHIDNT(I)(1:4).EQ.'pbar'.OR.
5608 & CHIDNT(I)(1:2).EQ.'p-') THEN
5609 CHIDNT(I)(1:5)='pbar-'
5610 ELSEIF(CHIDNT(I)(1:6).EQ.'lambda') THEN
5611 CHIDNT(I)(7:7)='0'
5612 ELSEIF(CHIDNT(I)(1:3).EQ.'reg') THEN
5613 CHIDNT(I)(1:7)='reggeon'
5614 ELSEIF(CHIDNT(I)(1:3).EQ.'pom') THEN
5615 CHIDNT(I)(1:7)='pomeron'
5616 ENDIF
5617 130 CONTINUE
5618
5619C...Identify free initialization.
5620 IF(CHCOM(1)(1:2).EQ.'no') THEN
5621 MINT(65)=1
5622 RETURN
5623 ENDIF
5624
5625C...Identify incoming beam and target particles.
5626 DO 160 I=1,2
5627 DO 140 J=1,39
5628 IF(CHIDNT(I+1).EQ.CHCDE(J)) MINT(10+I)=KCDE(J)
5629 140 CONTINUE
5630 PM(I)=PYMASS(MINT(10+I))
5631 VINT(2+I)=PM(I)
5632 MINT(140+I)=0
5633 IF(MINT(10+I).EQ.22.AND.CHIDNT(I+1)(6:6).EQ.'/') THEN
5634 CHTEMP=CHIDNT(I+1)(7:12)//' '
5635 DO 150 J=1,12
5636 IF(CHTEMP.EQ.CHCDE(J)) MINT(140+I)=KCDE(J)
5637 150 CONTINUE
5638 PM(I)=PYMASS(MINT(140+I))
5639 VINT(302+I)=PM(I)
5640 ENDIF
5641 160 CONTINUE
5642 IF(MINT(11).EQ.0) WRITE(MSTU(11),5000) CHBEAM(1:LEN(2))
5643 IF(MINT(12).EQ.0) WRITE(MSTU(11),5100) CHTARG(1:LEN(3))
5644 IF(MINT(11).EQ.0.OR.MINT(12).EQ.0) CALL PYSTOP(7)
5645
5646C...Identify choice of frame and input energies.
5647 CHINIT=' '
5648
5649C...Events defined in the CM frame.
5650 IF(CHCOM(1)(1:2).EQ.'cm') THEN
5651 MINT(111)=1
5652 S=WIN**2
5653 IF(MSTP(122).GE.1) THEN
5654 IF(CHCOM(2)(1:1).NE.'e') THEN
5655 LOFFS=(31-(LEN(2)+LEN(3)))/2
5656 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for a '//
5657 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5658 & ' collider'//' '
5659 ELSE
5660 LOFFS=(30-(LEN(2)+LEN(3)))/2
5661 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for an '//
5662 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5663 & ' collider'//' '
5664 ENDIF
5665 WRITE(MSTU(11),5200) CHINIT
5666 WRITE(MSTU(11),5300) WIN
5667 ENDIF
5668
5669C...Events defined in fixed target frame.
5670 ELSEIF(CHCOM(1)(1:3).EQ.'fix') THEN
5671 MINT(111)=2
5672 S=PM(1)**2+PM(2)**2+2D0*PM(2)*SQRT(PM(1)**2+WIN**2)
5673 IF(MSTP(122).GE.1) THEN
5674 LOFFS=(29-(LEN(2)+LEN(3)))/2
5675 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5676 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5677 & ' fixed target'//' '
5678 WRITE(MSTU(11),5200) CHINIT
5679 WRITE(MSTU(11),5400) WIN
5680 WRITE(MSTU(11),5500) SQRT(S)
5681 ENDIF
5682
5683C...Frame defined by user three-vectors.
5684 ELSEIF(CHCOM(1)(1:1).EQ.'3') THEN
5685 MINT(111)=3
5686 P(1,5)=PM(1)
5687 P(2,5)=PM(2)
5688 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5689 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5690 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5691 & (P(1,3)+P(2,3))**2
5692 IF(MSTP(122).GE.1) THEN
5693 LOFFS=(22-(LEN(2)+LEN(3)))/2
5694 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5695 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5696 & ' user configuration'//' '
5697 WRITE(MSTU(11),5200) CHINIT
5698 WRITE(MSTU(11),5600)
5699 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5700 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5701 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5702 ENDIF
5703
5704C...Frame defined by user four-vectors.
5705 ELSEIF(CHCOM(1)(1:1).EQ.'4') THEN
5706 MINT(111)=4
5707 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5708 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5709 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5710 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5711 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5712 & (P(1,3)+P(2,3))**2
5713 IF(MSTP(122).GE.1) THEN
5714 LOFFS=(22-(LEN(2)+LEN(3)))/2
5715 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5716 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5717 & ' user configuration'//' '
5718 WRITE(MSTU(11),5200) CHINIT
5719 WRITE(MSTU(11),5600)
5720 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5721 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5722 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5723 ENDIF
5724
5725C...Frame defined by user five-vectors.
5726 ELSEIF(CHCOM(1)(1:1).EQ.'5') THEN
5727 MINT(111)=5
5728 S=(P(1,4)+P(2,4))**2-(P(1,1)+P(2,1))**2-(P(1,2)+P(2,2))**2-
5729 & (P(1,3)+P(2,3))**2
5730 IF(MSTP(122).GE.1) THEN
5731 LOFFS=(22-(LEN(2)+LEN(3)))/2
5732 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5733 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5734 & ' user configuration'//' '
5735 WRITE(MSTU(11),5200) CHINIT
5736 WRITE(MSTU(11),5600)
5737 WRITE(MSTU(11),5700) CHCOM(2),P(1,1),P(1,2),P(1,3),P(1,4)
5738 WRITE(MSTU(11),5700) CHCOM(3),P(2,1),P(2,2),P(2,3),P(2,4)
5739 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5740 ENDIF
5741
5742C...Frame defined by HEPRUP common block.
5743 ELSEIF(MINT(111).GE.11) THEN
5744 S=(EBMUP(1)+EBMUP(2))**2-(SQRT(MAX(0D0,EBMUP(1)**2-PM(1)**2))-
5745 & SQRT(MAX(0D0,EBMUP(2)**2-PM(2)**2)))**2
5746 IF(MSTP(122).GE.1) THEN
5747 LOFFS=(22-(LEN(2)+LEN(3)))/2
5748 CHINIT(LOFFS+1:76)='PYTHIA will be initialized for '//
5749 & CHCOM(2)(1:LEN(2))//' on '//CHCOM(3)(1:LEN(3))//
5750 & ' user configuration'//' '
5751 WRITE(MSTU(11),5200) CHINIT
5752 WRITE(MSTU(11),6000) EBMUP(1),EBMUP(2)
5753 WRITE(MSTU(11),5500) SQRT(MAX(0D0,S))
5754 ENDIF
5755
5756C...Unknown frame. Error for too low CM energy.
5757 ELSE
5758 WRITE(MSTU(11),5800) CHFRAM(1:LEN(1))
5759 CALL PYSTOP(7)
5760 ENDIF
5761 IF(S.LT.PARP(2)**2) THEN
5762 WRITE(MSTU(11),5900) SQRT(S)
5763 CALL PYSTOP(7)
5764 ENDIF
5765
5766C...Formats for initialization and error information.
5767 5000 FORMAT(1X,'Error: unrecognized beam particle ''',A,'''D0'/
5768 &1X,'Execution stopped!')
5769 5100 FORMAT(1X,'Error: unrecognized target particle ''',A,'''D0'/
5770 &1X,'Execution stopped!')
5771 5200 FORMAT(/1X,78('=')/1X,'I',76X,'I'/1X,'I',A76,'I')
5772 5300 FORMAT(1X,'I',18X,'at',1X,F10.3,1X,'GeV center-of-mass energy',
5773 &19X,'I'/1X,'I',76X,'I'/1X,78('='))
5774 5400 FORMAT(1X,'I',22X,'at',1X,F10.3,1X,'GeV/c lab-momentum',22X,'I')
5775 5500 FORMAT(1X,'I',76X,'I'/1X,'I',11X,'corresponding to',1X,F10.3,1X,
5776 &'GeV center-of-mass energy',12X,'I'/1X,'I',76X,'I'/1X,78('='))
5777 5600 FORMAT(1X,'I',76X,'I'/1X,'I',18X,'px (GeV/c)',3X,'py (GeV/c)',3X,
5778 &'pz (GeV/c)',6X,'E (GeV)',9X,'I')
5779 5700 FORMAT(1X,'I',8X,A8,4(2X,F10.3,1X),8X,'I')
5780 5800 FORMAT(1X,'Error: unrecognized coordinate frame ''',A,'''D0'/
5781 &1X,'Execution stopped!')
5782 5900 FORMAT(1X,'Error: too low CM energy,',F8.3,' GeV for event ',
5783 &'generation.'/1X,'Execution stopped!')
5784 6000 FORMAT(1X,'I',12X,'with',1X,F10.3,1X,'GeV on',1X,F10.3,1X,
5785 &'GeV beam energies',13X,'I')
5786
5787 RETURN
5788 END
5789
5790C*********************************************************************
5791
5792C...PYINKI
5793C...Sets up kinematics, including rotations and boosts to/from CM frame.
5794
5795 SUBROUTINE PYINKI(MODKI)
5796
5797C...Double precision and integer declarations.
5798 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5799 IMPLICIT INTEGER(I-N)
5800 INTEGER PYK,PYCHGE,PYCOMP
5801
5802C...User process initialization commonblock.
5803 INTEGER MAXPUP
5804 PARAMETER (MAXPUP=100)
5805 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
5806 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
5807 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
5808 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
5809 &LPRUP(MAXPUP)
5810 SAVE /HEPRUP/
5811
5812C...Commonblocks.
5813 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
5814 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
5815 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
5816 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
5817 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
5818 COMMON/PYINT1/MINT(400),VINT(400)
5819 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
5820
5821C...Set initial flavour state.
5822 N=2
5823 DO 100 I=1,2
5824 K(I,1)=1
5825 K(I,2)=MINT(10+I)
5826 IF(MINT(140+I).NE.0) K(I,2)=MINT(140+I)
5827 100 CONTINUE
5828
5829C...Reset boost. Do kinematics for various cases.
5830 DO 110 J=6,10
5831 VINT(J)=0D0
5832 110 CONTINUE
5833
5834C...Set up kinematics for events defined in CM frame.
5835 IF(MINT(111).EQ.1) THEN
5836 WIN=VINT(290)
5837 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5838 S=WIN**2
5839 P(1,5)=VINT(3)
5840 P(2,5)=VINT(4)
5841 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5842 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5843 P(1,1)=0D0
5844 P(1,2)=0D0
5845 P(2,1)=0D0
5846 P(2,2)=0D0
5847 P(1,3)=SQRT(((S-P(1,5)**2-P(2,5)**2)**2-(2D0*P(1,5)*P(2,5))**2)/
5848 & (4D0*S))
5849 P(2,3)=-P(1,3)
5850 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5851 P(2,4)=SQRT(P(2,3)**2+P(2,5)**2)
5852
5853C...Set up kinematics for fixed target events.
5854 ELSEIF(MINT(111).EQ.2) THEN
5855 WIN=VINT(290)
5856 IF(MODKI.EQ.1) WIN=PARP(171)*VINT(290)
5857 P(1,5)=VINT(3)
5858 P(2,5)=VINT(4)
5859 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5860 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5861 P(1,1)=0D0
5862 P(1,2)=0D0
5863 P(2,1)=0D0
5864 P(2,2)=0D0
5865 P(1,3)=WIN
5866 P(1,4)=SQRT(P(1,3)**2+P(1,5)**2)
5867 P(2,3)=0D0
5868 P(2,4)=P(2,5)
5869 S=P(1,5)**2+P(2,5)**2+2D0*P(2,4)*P(1,4)
5870 VINT(10)=P(1,3)/(P(1,4)+P(2,4))
5871 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5872
5873C...Set up kinematics for events in user-defined frame.
5874 ELSEIF(MINT(111).EQ.3) THEN
5875 P(1,5)=VINT(3)
5876 P(2,5)=VINT(4)
5877 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5878 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5879 P(1,4)=SQRT(P(1,1)**2+P(1,2)**2+P(1,3)**2+P(1,5)**2)
5880 P(2,4)=SQRT(P(2,1)**2+P(2,2)**2+P(2,3)**2+P(2,5)**2)
5881 DO 120 J=1,3
5882 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5883 120 CONTINUE
5884 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5885 VINT(7)=PYANGL(P(1,1),P(1,2))
5886 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5887 VINT(6)=PYANGL(P(1,3),P(1,1))
5888 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5889 S=P(1,5)**2+P(2,5)**2+2D0*(P(1,4)*P(2,4)-P(1,3)*P(2,3))
5890
5891C...Set up kinematics for events with user-defined four-vectors.
5892 ELSEIF(MINT(111).EQ.4) THEN
5893 PMS1=P(1,4)**2-P(1,1)**2-P(1,2)**2-P(1,3)**2
5894 P(1,5)=SIGN(SQRT(ABS(PMS1)),PMS1)
5895 PMS2=P(2,4)**2-P(2,1)**2-P(2,2)**2-P(2,3)**2
5896 P(2,5)=SIGN(SQRT(ABS(PMS2)),PMS2)
5897 DO 130 J=1,3
5898 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5899 130 CONTINUE
5900 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5901 VINT(7)=PYANGL(P(1,1),P(1,2))
5902 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5903 VINT(6)=PYANGL(P(1,3),P(1,1))
5904 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5905 S=(P(1,4)+P(2,4))**2
5906
5907C...Set up kinematics for events with user-defined five-vectors.
5908 ELSEIF(MINT(111).EQ.5) THEN
5909 DO 140 J=1,3
5910 VINT(7+J)=(P(1,J)+P(2,J))/(P(1,4)+P(2,4))
5911 140 CONTINUE
5912 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
5913 VINT(7)=PYANGL(P(1,1),P(1,2))
5914 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
5915 VINT(6)=PYANGL(P(1,3),P(1,1))
5916 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
5917 S=(P(1,4)+P(2,4))**2
5918
5919C...Set up kinematics for events with external user processes.
5920 ELSEIF(MINT(111).GE.11) THEN
5921 P(1,5)=VINT(3)
5922 P(2,5)=VINT(4)
5923 IF(MINT(141).NE.0) P(1,5)=VINT(303)
5924 IF(MINT(142).NE.0) P(2,5)=VINT(304)
5925 P(1,1)=0D0
5926 P(1,2)=0D0
5927 P(2,1)=0D0
5928 P(2,2)=0D0
5929 P(1,3)=SQRT(MAX(0D0,EBMUP(1)**2-P(1,5)**2))
5930 P(2,3)=-SQRT(MAX(0D0,EBMUP(2)**2-P(2,5)**2))
5931 P(1,4)=EBMUP(1)
5932 P(2,4)=EBMUP(2)
5933 VINT(10)=(P(1,3)+P(2,3))/(P(1,4)+P(2,4))
5934 CALL PYROBO(0,0,0D0,0D0,0D0,0D0,-VINT(10))
5935 S=(P(1,4)+P(2,4))**2
5936 ENDIF
5937
5938C...Return or error for too low CM energy.
5939 IF(MODKI.EQ.1.AND.S.LT.PARP(2)**2) THEN
5940 IF(MSTP(172).LE.1) THEN
5941 CALL PYERRM(23,
5942 & '(PYINKI:) too low invariant mass in this event')
5943 ELSE
5944 MSTI(61)=1
5945 RETURN
5946 ENDIF
5947 ENDIF
5948
5949C...Save information on incoming particles.
5950 VINT(1)=SQRT(S)
5951 VINT(2)=S
5952 IF(MINT(111).GE.4) THEN
5953 IF(MINT(141).EQ.0) THEN
5954 VINT(3)=P(1,5)
5955 IF(MINT(11).EQ.22.AND.P(1,5).LT.0) VINT(307)=P(1,5)**2
5956 ELSE
5957 VINT(303)=P(1,5)
5958 ENDIF
5959 IF(MINT(142).EQ.0) THEN
5960 VINT(4)=P(2,5)
5961 IF(MINT(12).EQ.22.AND.P(2,5).LT.0) VINT(308)=P(2,5)**2
5962 ELSE
5963 VINT(304)=P(2,5)
5964 ENDIF
5965 ENDIF
5966 VINT(5)=P(1,3)
5967 IF(MODKI.EQ.0) VINT(289)=S
5968 DO 150 J=1,5
5969 V(1,J)=0D0
5970 V(2,J)=0D0
5971 VINT(290+J)=P(1,J)
5972 VINT(295+J)=P(2,J)
5973 150 CONTINUE
5974
5975C...Store pT cut-off and related constants to be used in generation.
5976 IF(MODKI.EQ.0) VINT(285)=CKIN(3)
5977 IF(MSTP(82).LE.1) THEN
5978 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
5979 ELSE
5980 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
5981 ENDIF
5982 VINT(149)=4D0*PTMN**2/S
5983 VINT(154)=PTMN
5984
5985 RETURN
5986 END
5987
5988C*********************************************************************
5989
5990C...PYINPR
5991C...Selects partonic subprocesses to be included in the simulation.
5992
5993 SUBROUTINE PYINPR
5994
5995C...Double precision and integer declarations.
5996 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
5997 IMPLICIT INTEGER(I-N)
5998 INTEGER PYK,PYCHGE,PYCOMP
5999
6000C...User process initialization commonblock.
6001 INTEGER MAXPUP
6002 PARAMETER (MAXPUP=100)
6003 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
6004 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
6005 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
6006 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
6007 &LPRUP(MAXPUP)
6008 SAVE /HEPRUP/
6009
6010C...Commonblocks and character variables.
6011 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6012 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6013 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
6014 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
6015 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6016 COMMON/PYINT1/MINT(400),VINT(400)
6017 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
6018 COMMON/PYINT6/PROC(0:500)
6019 CHARACTER PROC*28
6020 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
6021 &/PYINT2/,/PYINT6/
6022 CHARACTER CHIPR*10
6023
6024
6025C...Reset processes to be included.
6026 IF(MSEL.NE.0) THEN
6027 DO 100 I=1,500
6028 MSUB(I)=0
6029 100 CONTINUE
6030 ENDIF
6031
6032C...Set running pTmin scale.
6033 IF(MSTP(82).LE.1) THEN
6034 PTMRUN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
6035 ELSE
6036 PTMRUN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
6037 ENDIF
6038
6039C...Begin by assuming incoming photon to enter subprocess.
6040 IF(MINT(11).EQ.22) MINT(15)=22
6041 IF(MINT(12).EQ.22) MINT(16)=22
6042
6043C...For e-gamma with MSTP(14)=10 allow mixture of VMD and anomalous.
6044 IF(MINT(121).EQ.2.AND.MSTP(14).EQ.10) THEN
6045 MSUB(10)=1
6046 MINT(123)=MINT(122)+1
6047
6048C...For gamma-p or gamma-gamma with MSTP(14) = 10, 20, 25 or 30
6049C...allow mixture.
6050C...Here also set a few parameters otherwise normally not touched.
6051 ELSEIF(MINT(121).GT.1) THEN
6052
6053C...Parton distributions dampened at small Q2; go to low energies,
6054C...alpha_s <1; no minimum pT cut-off a priori.
6055 IF(MSTP(18).EQ.2) THEN
6056 MSTP(57)=3
6057 PARP(2)=2D0
6058 PARU(115)=1D0
6059 CKIN(5)=0.2D0
6060 CKIN(6)=0.2D0
6061 ENDIF
6062
6063C...Define pT cut-off parameters and whether run involves low-pT.
6064 PTMVMD=PTMRUN
6065 VINT(154)=PTMVMD
6066 PTMDIR=PTMVMD
6067 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6068 PTMANO=PTMVMD
6069 IF(MSTP(15).EQ.5) PTMANO=0.60D0+
6070 & 0.125D0*LOG(1D0+0.10D0*VINT(1))**2
6071 IPTL=1
6072 IF(VINT(285).GT.MAX(PTMVMD,PTMDIR,PTMANO)) IPTL=0
6073 IF(MSEL.EQ.2) IPTL=1
6074
6075C...Set up for p/gamma * gamma; real or virtual photons.
6076 IF(MINT(121).EQ.3.OR.MINT(121).EQ.6.OR.(MINT(121).EQ.4.AND.
6077 & MSTP(14).EQ.30)) THEN
6078
6079C...Set up for p/VMD * VMD.
6080 IF(MINT(122).EQ.1) THEN
6081 MINT(123)=2
6082 MSUB(11)=1
6083 MSUB(12)=1
6084 MSUB(13)=1
6085 MSUB(28)=1
6086 MSUB(53)=1
6087 MSUB(68)=1
6088 IF(IPTL.EQ.1) MSUB(95)=1
6089 IF(MSEL.EQ.2) THEN
6090 MSUB(91)=1
6091 MSUB(92)=1
6092 MSUB(93)=1
6093 MSUB(94)=1
6094 ENDIF
6095 IF(IPTL.EQ.1) CKIN(3)=0D0
6096
6097C...Set up for p/VMD * direct gamma.
6098 ELSEIF(MINT(122).EQ.2) THEN
6099 MINT(123)=0
6100 IF(MINT(121).EQ.6) MINT(123)=5
6101 MSUB(131)=1
6102 MSUB(132)=1
6103 MSUB(135)=1
6104 MSUB(136)=1
6105 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6106
6107C...Set up for p/VMD * anomalous gamma.
6108 ELSEIF(MINT(122).EQ.3) THEN
6109 MINT(123)=3
6110 IF(MINT(121).EQ.6) MINT(123)=7
6111 MSUB(11)=1
6112 MSUB(12)=1
6113 MSUB(13)=1
6114 MSUB(28)=1
6115 MSUB(53)=1
6116 MSUB(68)=1
6117 IF(IPTL.EQ.1) MSUB(95)=1
6118 IF(MSEL.EQ.2) THEN
6119 MSUB(91)=1
6120 MSUB(92)=1
6121 MSUB(93)=1
6122 MSUB(94)=1
6123 ENDIF
6124 IF(IPTL.EQ.1) CKIN(3)=0D0
6125
6126C...Set up for DIS * p.
6127 ELSEIF(MINT(122).EQ.4.AND.(IABS(MINT(11)).GT.100.OR.
6128 & IABS(MINT(12)).GT.100)) THEN
6129 MINT(123)=8
6130 IF(IPTL.EQ.1) MSUB(99)=1
6131
6132C...Set up for direct * direct gamma (switch off leptons).
6133 ELSEIF(MINT(122).EQ.4) THEN
6134 MINT(123)=0
6135 MSUB(137)=1
6136 MSUB(138)=1
6137 MSUB(139)=1
6138 MSUB(140)=1
6139 DO 110 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6140 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6141 110 CONTINUE
6142 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6143
6144C...Set up for direct * anomalous gamma.
6145 ELSEIF(MINT(122).EQ.5) THEN
6146 MINT(123)=6
6147 MSUB(131)=1
6148 MSUB(132)=1
6149 MSUB(135)=1
6150 MSUB(136)=1
6151 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6152
6153C...Set up for anomalous * anomalous gamma.
6154 ELSEIF(MINT(122).EQ.6) THEN
6155 MINT(123)=3
6156 MSUB(11)=1
6157 MSUB(12)=1
6158 MSUB(13)=1
6159 MSUB(28)=1
6160 MSUB(53)=1
6161 MSUB(68)=1
6162 IF(IPTL.EQ.1) MSUB(95)=1
6163 IF(MSEL.EQ.2) THEN
6164 MSUB(91)=1
6165 MSUB(92)=1
6166 MSUB(93)=1
6167 MSUB(94)=1
6168 ENDIF
6169 IF(IPTL.EQ.1) CKIN(3)=0D0
6170 ENDIF
6171
6172C...Set up for gamma* * gamma*; virtual photons = dir, VMD, anom.
6173 ELSEIF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6174
6175C...Set up for direct * direct gamma (switch off leptons).
6176 IF(MINT(122).EQ.1) THEN
6177 MINT(123)=0
6178 MSUB(137)=1
6179 MSUB(138)=1
6180 MSUB(139)=1
6181 MSUB(140)=1
6182 DO 120 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6183 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6184 120 CONTINUE
6185 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6186
6187C...Set up for direct * VMD and VMD * direct gamma.
6188 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.4) THEN
6189 MINT(123)=5
6190 MSUB(131)=1
6191 MSUB(132)=1
6192 MSUB(135)=1
6193 MSUB(136)=1
6194 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6195
6196C...Set up for direct * anomalous and anomalous * direct gamma.
6197 ELSEIF(MINT(122).EQ.3.OR.MINT(122).EQ.7) THEN
6198 MINT(123)=6
6199 MSUB(131)=1
6200 MSUB(132)=1
6201 MSUB(135)=1
6202 MSUB(136)=1
6203 IF(IPTL.EQ.1) CKIN(3)=PTMANO
6204
6205C...Set up for VMD*VMD.
6206 ELSEIF(MINT(122).EQ.5) THEN
6207 MINT(123)=2
6208 MSUB(11)=1
6209 MSUB(12)=1
6210 MSUB(13)=1
6211 MSUB(28)=1
6212 MSUB(53)=1
6213 MSUB(68)=1
6214 IF(IPTL.EQ.1) MSUB(95)=1
6215 IF(MSEL.EQ.2) THEN
6216 MSUB(91)=1
6217 MSUB(92)=1
6218 MSUB(93)=1
6219 MSUB(94)=1
6220 ENDIF
6221 IF(IPTL.EQ.1) CKIN(3)=0D0
6222
6223C...Set up for VMD * anomalous and anomalous * VMD gamma.
6224 ELSEIF(MINT(122).EQ.6.OR.MINT(122).EQ.8) THEN
6225 MINT(123)=7
6226 MSUB(11)=1
6227 MSUB(12)=1
6228 MSUB(13)=1
6229 MSUB(28)=1
6230 MSUB(53)=1
6231 MSUB(68)=1
6232 IF(IPTL.EQ.1) MSUB(95)=1
6233 IF(MSEL.EQ.2) THEN
6234 MSUB(91)=1
6235 MSUB(92)=1
6236 MSUB(93)=1
6237 MSUB(94)=1
6238 ENDIF
6239 IF(IPTL.EQ.1) CKIN(3)=0D0
6240
6241C...Set up for anomalous * anomalous gamma.
6242 ELSEIF(MINT(122).EQ.9) THEN
6243 MINT(123)=3
6244 MSUB(11)=1
6245 MSUB(12)=1
6246 MSUB(13)=1
6247 MSUB(28)=1
6248 MSUB(53)=1
6249 MSUB(68)=1
6250 IF(IPTL.EQ.1) MSUB(95)=1
6251 IF(MSEL.EQ.2) THEN
6252 MSUB(91)=1
6253 MSUB(92)=1
6254 MSUB(93)=1
6255 MSUB(94)=1
6256 ENDIF
6257 IF(IPTL.EQ.1) CKIN(3)=0D0
6258
6259C...Set up for DIS * VMD and VMD * DIS gamma.
6260 ELSEIF(MINT(122).EQ.10.OR.MINT(122).EQ.12) THEN
6261 MINT(123)=8
6262 IF(IPTL.EQ.1) MSUB(99)=1
6263
6264C...Set up for DIS * anomalous and anomalous * DIS gamma.
6265 ELSEIF(MINT(122).EQ.11.OR.MINT(122).EQ.13) THEN
6266 MINT(123)=9
6267 IF(IPTL.EQ.1) MSUB(99)=1
6268 ENDIF
6269
6270C...Set up for gamma* * p; virtual photons = dir, res.
6271 ELSEIF(MINT(121).EQ.2) THEN
6272
6273C...Set up for direct * p.
6274 IF(MINT(122).EQ.1) THEN
6275 MINT(123)=0
6276 MSUB(131)=1
6277 MSUB(132)=1
6278 MSUB(135)=1
6279 MSUB(136)=1
6280 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6281
6282C...Set up for resolved * p.
6283 ELSEIF(MINT(122).EQ.2) THEN
6284 MINT(123)=1
6285 MSUB(11)=1
6286 MSUB(12)=1
6287 MSUB(13)=1
6288 MSUB(28)=1
6289 MSUB(53)=1
6290 MSUB(68)=1
6291 IF(IPTL.EQ.1) MSUB(95)=1
6292 IF(MSEL.EQ.2) THEN
6293 MSUB(91)=1
6294 MSUB(92)=1
6295 MSUB(93)=1
6296 MSUB(94)=1
6297 ENDIF
6298 IF(IPTL.EQ.1) CKIN(3)=0D0
6299 ENDIF
6300
6301C...Set up for gamma* * gamma*; virtual photons = dir, res.
6302 ELSEIF(MINT(121).EQ.4) THEN
6303
6304C...Set up for direct * direct gamma (switch off leptons).
6305 IF(MINT(122).EQ.1) THEN
6306 MINT(123)=0
6307 MSUB(137)=1
6308 MSUB(138)=1
6309 MSUB(139)=1
6310 MSUB(140)=1
6311 DO 130 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6312 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6313 130 CONTINUE
6314 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6315
6316C...Set up for direct * resolved and resolved * direct gamma.
6317 ELSEIF(MINT(122).EQ.2.OR.MINT(122).EQ.3) THEN
6318 MINT(123)=5
6319 MSUB(131)=1
6320 MSUB(132)=1
6321 MSUB(135)=1
6322 MSUB(136)=1
6323 IF(IPTL.EQ.1) CKIN(3)=PTMDIR
6324
6325C...Set up for resolved * resolved gamma.
6326 ELSEIF(MINT(122).EQ.4) THEN
6327 MINT(123)=2
6328 MSUB(11)=1
6329 MSUB(12)=1
6330 MSUB(13)=1
6331 MSUB(28)=1
6332 MSUB(53)=1
6333 MSUB(68)=1
6334 IF(IPTL.EQ.1) MSUB(95)=1
6335 IF(MSEL.EQ.2) THEN
6336 MSUB(91)=1
6337 MSUB(92)=1
6338 MSUB(93)=1
6339 MSUB(94)=1
6340 ENDIF
6341 IF(IPTL.EQ.1) CKIN(3)=0D0
6342 ENDIF
6343
6344C...End of special set up for gamma-p and gamma-gamma.
6345 ENDIF
6346 CKIN(1)=2D0*CKIN(3)
6347 ENDIF
6348
6349C...Flavour information for individual beams.
6350 DO 140 I=1,2
6351 MINT(40+I)=1
6352 IF(MINT(123).GE.1.AND.MINT(10+I).EQ.22) MINT(40+I)=2
6353 IF(IABS(MINT(10+I)).GT.100) MINT(40+I)=2
6354 MINT(44+I)=MINT(40+I)
6355 IF(MSTP(11).GE.1.AND.(IABS(MINT(10+I)).EQ.11.OR.
6356 & IABS(MINT(10+I)).EQ.13.OR.IABS(MINT(10+I)).EQ.15)) MINT(44+I)=3
6357 140 CONTINUE
6358
6359C...If two real gammas, whereof one direct, pick the first.
6360C...For two virtual photons, keep requested order.
6361 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6362 IF(MSTP(14).LE.10.AND.MINT(123).GE.4.AND.MINT(123).LE.6) THEN
6363 MINT(41)=1
6364 MINT(45)=1
6365 ELSEIF(MSTP(14).EQ.12.OR.MSTP(14).EQ.13.OR.MSTP(14).EQ.22.OR.
6366 & MSTP(14).EQ.26.OR.MSTP(14).EQ.27) THEN
6367 MINT(41)=1
6368 MINT(45)=1
6369 ELSEIF(MSTP(14).EQ.14.OR.MSTP(14).EQ.17.OR.MSTP(14).EQ.23.OR.
6370 & MSTP(14).EQ.28.OR.MSTP(14).EQ.29) THEN
6371 MINT(42)=1
6372 MINT(46)=1
6373 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.2
6374 & .OR.MINT(122).EQ.3.OR.MINT(122).EQ.10.OR.MINT(122).EQ.11)) THEN
6375 MINT(41)=1
6376 MINT(45)=1
6377 ELSEIF((MSTP(14).EQ.20.OR.MSTP(14).EQ.30).AND.(MINT(122).EQ.4
6378 & .OR.MINT(122).EQ.7.OR.MINT(122).EQ.12.OR.MINT(122).EQ.13)) THEN
6379 MINT(42)=1
6380 MINT(46)=1
6381 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.2) THEN
6382 MINT(41)=1
6383 MINT(45)=1
6384 ELSEIF(MSTP(14).EQ.25.AND.MINT(122).EQ.3) THEN
6385 MINT(42)=1
6386 MINT(46)=1
6387 ENDIF
6388 ELSEIF(MINT(11).EQ.22.OR.MINT(12).EQ.22) THEN
6389 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.28.OR.MINT(122).EQ.4) THEN
6390 IF(MINT(11).EQ.22) THEN
6391 MINT(41)=1
6392 MINT(45)=1
6393 ELSE
6394 MINT(42)=1
6395 MINT(46)=1
6396 ENDIF
6397 ENDIF
6398 IF(MINT(123).GE.4.AND.MINT(123).LE.7) CALL PYERRM(26,
6399 & '(PYINPR:) unallowed MSTP(14) code for single photon')
6400 ENDIF
6401
6402C...Flavour information on combination of incoming particles.
6403 MINT(43)=2*MINT(41)+MINT(42)-2
6404 MINT(44)=MINT(43)
6405 IF(MINT(123).LE.0) THEN
6406 IF(MINT(11).EQ.22) MINT(43)=MINT(43)+2
6407 IF(MINT(12).EQ.22) MINT(43)=MINT(43)+1
6408 ELSEIF(MINT(123).LE.3) THEN
6409 IF(MINT(11).EQ.22) MINT(44)=MINT(44)-2
6410 IF(MINT(12).EQ.22) MINT(44)=MINT(44)-1
6411 ELSEIF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
6412 MINT(43)=4
6413 MINT(44)=1
6414 ENDIF
6415 MINT(47)=2*MIN(2,MINT(45))+MIN(2,MINT(46))-2
6416 IF(MIN(MINT(45),MINT(46)).EQ.3) MINT(47)=5
6417 IF(MINT(45).EQ.1.AND.MINT(46).EQ.3) MINT(47)=6
6418 IF(MINT(45).EQ.3.AND.MINT(46).EQ.1) MINT(47)=7
6419 MINT(50)=0
6420 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2.AND.MINT(111).NE.12) MINT(50)=1
6421 MINT(107)=0
6422 MINT(108)=0
6423 IF(MINT(121).EQ.9.OR.MINT(121).EQ.13) THEN
6424 IF((MINT(122).GE.4.AND.MINT(122).LE.6).OR.MINT(122).EQ.12)
6425 & MINT(107)=2
6426 IF((MINT(122).GE.7.AND.MINT(122).LE.9).OR.MINT(122).EQ.13)
6427 & MINT(107)=3
6428 IF(MINT(122).EQ.10.OR.MINT(122).EQ.11) MINT(107)=4
6429 IF(MINT(122).EQ.2.OR.MINT(122).EQ.5.OR.MINT(122).EQ.8.OR.
6430 & MINT(122).EQ.10) MINT(108)=2
6431 IF(MINT(122).EQ.3.OR.MINT(122).EQ.6.OR.MINT(122).EQ.9.OR.
6432 & MINT(122).EQ.11) MINT(108)=3
6433 IF(MINT(122).EQ.12.OR.MINT(122).EQ.13) MINT(108)=4
6434 ELSEIF(MINT(121).EQ.4.AND.MSTP(14).EQ.25) THEN
6435 IF(MINT(122).GE.3) MINT(107)=1
6436 IF(MINT(122).EQ.2.OR.MINT(122).EQ.4) MINT(108)=1
6437 ELSEIF(MINT(121).EQ.2) THEN
6438 IF(MINT(122).EQ.2.AND.MINT(11).EQ.22) MINT(107)=1
6439 IF(MINT(122).EQ.2.AND.MINT(12).EQ.22) MINT(108)=1
6440 ELSE
6441 IF(MINT(11).EQ.22) THEN
6442 MINT(107)=MINT(123)
6443 IF(MINT(123).GE.4) MINT(107)=0
6444 IF(MINT(123).EQ.7) MINT(107)=2
6445 IF(MSTP(14).EQ.26.OR.MSTP(14).EQ.27) MINT(107)=4
6446 IF(MSTP(14).EQ.28) MINT(107)=2
6447 IF(MSTP(14).EQ.29) MINT(107)=3
6448 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6449 & MINT(107)=4
6450 ENDIF
6451 IF(MINT(12).EQ.22) THEN
6452 MINT(108)=MINT(123)
6453 IF(MINT(123).GE.4) MINT(108)=MINT(123)-3
6454 IF(MINT(123).EQ.7) MINT(108)=3
6455 IF(MSTP(14).EQ.26) MINT(108)=2
6456 IF(MSTP(14).EQ.27) MINT(108)=3
6457 IF(MSTP(14).EQ.28.OR.MSTP(14).EQ.29) MINT(108)=4
6458 IF(MSTP(14).EQ.30.AND.MINT(121).EQ.4.AND.MINT(122).EQ.4)
6459 & MINT(108)=4
6460 ENDIF
6461 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.(MSTP(14).EQ.14.OR.
6462 & MSTP(14).EQ.17.OR.MSTP(14).EQ.18.OR.MSTP(14).EQ.23)) THEN
6463 MINTTP=MINT(107)
6464 MINT(107)=MINT(108)
6465 MINT(108)=MINTTP
6466 ENDIF
6467 ENDIF
6468 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
6469 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
6470
6471C...Select default processes according to incoming beams
6472C...(already done for gamma-p and gamma-gamma with
6473C...MSTP(14) = 10, 20, 25 or 30).
6474 IF(MINT(121).GT.1) THEN
6475 ELSEIF(MSEL.EQ.1.OR.MSEL.EQ.2) THEN
6476
6477 IF(MINT(43).EQ.1) THEN
6478C...Lepton + lepton -> gamma/Z0 or W.
6479 IF(MINT(11)+MINT(12).EQ.0) MSUB(1)=1
6480 IF(MINT(11)+MINT(12).NE.0) MSUB(2)=1
6481
6482 ELSEIF(MINT(43).LE.3.AND.MINT(123).EQ.0.AND.
6483 & (MINT(11).EQ.22.OR.MINT(12).EQ.22)) THEN
6484C...Unresolved photon + lepton: Compton scattering.
6485 MSUB(133)=1
6486 MSUB(134)=1
6487
6488 ELSEIF((MINT(123).EQ.8.OR.MINT(123).EQ.9).AND.(MINT(11).EQ.22
6489 & .OR.MINT(12).EQ.22)) THEN
6490C...DIS as pure gamma* + f -> f process.
6491 MSUB(99)=1
6492
6493 ELSEIF(MINT(43).LE.3) THEN
6494C...Lepton + hadron: deep inelastic scattering.
6495 MSUB(10)=1
6496
6497 ELSEIF(MINT(123).EQ.0.AND.MINT(11).EQ.22.AND.
6498 & MINT(12).EQ.22) THEN
6499C...Two unresolved photons: fermion pair production,
6500C...exclude lepton pairs.
6501 DO 150 ISUB=137,140
6502 MSUB(ISUB)=1
6503 150 CONTINUE
6504 DO 160 II=MDCY(22,2),MDCY(22,2)+MDCY(22,3)-1
6505 IF(IABS(KFDP(II,1)).GE.10) MDME(II,1)=MIN(0,MDME(II,1))
6506 160 CONTINUE
6507 PTMDIR=PTMRUN
6508 IF(MSTP(18).EQ.2) PTMDIR=PARP(15)
6509 IF(CKIN(3).LT.PTMRUN.OR.MSEL.EQ.2) CKIN(3)=PTMDIR
6510 CKIN(1)=MAX(CKIN(1),2D0*CKIN(3))
6511
6512 ELSEIF((MINT(123).EQ.0.AND.(MINT(11).EQ.22.OR.MINT(12).EQ.22))
6513 & .OR.(MINT(123).GE.4.AND.MINT(123).LE.6.AND.MINT(11).EQ.22.AND.
6514 & MINT(12).EQ.22)) THEN
6515C...Unresolved photon + hadron: photon-parton scattering.
6516 DO 170 ISUB=131,136
6517 MSUB(ISUB)=1
6518 170 CONTINUE
6519
6520 ELSEIF(MSEL.EQ.1) THEN
6521C...High-pT QCD processes:
6522 MSUB(11)=1
6523 MSUB(12)=1
6524 MSUB(13)=1
6525 MSUB(28)=1
6526 MSUB(53)=1
6527 MSUB(68)=1
6528 PTMN=PTMRUN
6529 VINT(154)=PTMN
6530 IF(CKIN(3).LT.PTMN) MSUB(95)=1
6531 IF(MSUB(95).EQ.1.AND.MINT(50).EQ.0) MSUB(95)=0
6532
6533 ELSE
6534C...All QCD processes:
6535 MSUB(11)=1
6536 MSUB(12)=1
6537 MSUB(13)=1
6538 MSUB(28)=1
6539 MSUB(53)=1
6540 MSUB(68)=1
6541 MSUB(91)=1
6542 MSUB(92)=1
6543 MSUB(93)=1
6544 MSUB(94)=1
6545 MSUB(95)=1
6546 ENDIF
6547
6548 ELSEIF(MSEL.GE.4.AND.MSEL.LE.8) THEN
6549C...Heavy quark production.
6550 MSUB(81)=1
6551 MSUB(82)=1
6552 MSUB(84)=1
6553 DO 180 J=1,MIN(8,MDCY(21,3))
6554 MDME(MDCY(21,2)+J-1,1)=0
6555 180 CONTINUE
6556 MDME(MDCY(21,2)+MSEL-1,1)=1
6557 MSUB(85)=1
6558 DO 190 J=1,MIN(12,MDCY(22,3))
6559 MDME(MDCY(22,2)+J-1,1)=0
6560 190 CONTINUE
6561 MDME(MDCY(22,2)+MSEL-1,1)=1
6562
6563 ELSEIF(MSEL.EQ.10) THEN
6564C...Prompt photon production:
6565 MSUB(14)=1
6566 MSUB(18)=1
6567 MSUB(29)=1
6568
6569 ELSEIF(MSEL.EQ.11) THEN
6570C...Z0/gamma* production:
6571 MSUB(1)=1
6572
6573 ELSEIF(MSEL.EQ.12) THEN
6574C...W+/- production:
6575 MSUB(2)=1
6576
6577 ELSEIF(MSEL.EQ.13) THEN
6578C...Z0 + jet:
6579 MSUB(15)=1
6580 MSUB(30)=1
6581
6582 ELSEIF(MSEL.EQ.14) THEN
6583C...W+/- + jet:
6584 MSUB(16)=1
6585 MSUB(31)=1
6586
6587 ELSEIF(MSEL.EQ.15) THEN
6588C...Z0 & W+/- pair production:
6589 MSUB(19)=1
6590 MSUB(20)=1
6591 MSUB(22)=1
6592 MSUB(23)=1
6593 MSUB(25)=1
6594
6595 ELSEIF(MSEL.EQ.16) THEN
6596C...h0 production:
6597 MSUB(3)=1
6598 MSUB(102)=1
6599 MSUB(103)=1
6600 MSUB(123)=1
6601 MSUB(124)=1
6602
6603 ELSEIF(MSEL.EQ.17) THEN
6604C...h0 & Z0 or W+/- pair production:
6605 MSUB(24)=1
6606 MSUB(26)=1
6607
6608 ELSEIF(MSEL.EQ.18) THEN
6609C...h0 production; interesting processes in e+e-.
6610 MSUB(24)=1
6611 MSUB(103)=1
6612 MSUB(123)=1
6613 MSUB(124)=1
6614
6615 ELSEIF(MSEL.EQ.19) THEN
6616C...h0, H0 and A0 production; interesting processes in e+e-.
6617 MSUB(24)=1
6618 MSUB(103)=1
6619 MSUB(123)=1
6620 MSUB(124)=1
6621 MSUB(153)=1
6622 MSUB(171)=1
6623 MSUB(173)=1
6624 MSUB(174)=1
6625 MSUB(158)=1
6626 MSUB(176)=1
6627 MSUB(178)=1
6628 MSUB(179)=1
6629
6630 ELSEIF(MSEL.EQ.21) THEN
6631C...Z'0 production:
6632 MSUB(141)=1
6633
6634 ELSEIF(MSEL.EQ.22) THEN
6635C...W'+/- production:
6636 MSUB(142)=1
6637
6638 ELSEIF(MSEL.EQ.23) THEN
6639C...H+/- production:
6640 MSUB(143)=1
6641
6642 ELSEIF(MSEL.EQ.24) THEN
6643C...R production:
6644 MSUB(144)=1
6645
6646 ELSEIF(MSEL.EQ.25) THEN
6647C...LQ (leptoquark) production.
6648 MSUB(145)=1
6649 MSUB(162)=1
6650 MSUB(163)=1
6651 MSUB(164)=1
6652
6653 ELSEIF(MSEL.GE.35.AND.MSEL.LE.38) THEN
6654C...Production of one heavy quark (W exchange):
6655 MSUB(83)=1
6656 DO 200 J=1,MIN(8,MDCY(21,3))
6657 MDME(MDCY(21,2)+J-1,1)=0
6658 200 CONTINUE
6659 MDME(MDCY(21,2)+MSEL-31,1)=1
6660
6661CMRENNA++Define SUSY alternatives.
6662 ELSEIF(MSEL.EQ.39) THEN
6663C...Turn on all SUSY processes.
6664 IF(MINT(43).EQ.4) THEN
6665C...Hadron-hadron processes.
6666 DO 210 I=201,296
6667 IF(ISET(I).GE.0) MSUB(I)=1
6668 210 CONTINUE
6669 ELSEIF(MINT(43).EQ.1) THEN
6670C...Lepton-lepton processes: QED production of squarks.
6671 DO 220 I=201,214
6672 MSUB(I)=1
6673 220 CONTINUE
6674 MSUB(210)=0
6675 MSUB(211)=0
6676 MSUB(212)=0
6677 DO 230 I=216,228
6678 MSUB(I)=1
6679 230 CONTINUE
6680 DO 240 I=261,263
6681 MSUB(I)=1
6682 240 CONTINUE
6683 MSUB(277)=1
6684 MSUB(278)=1
6685 ENDIF
6686
6687 ELSEIF(MSEL.EQ.40) THEN
6688C...Gluinos and squarks.
6689 IF(MINT(43).EQ.4) THEN
6690 MSUB(243)=1
6691 MSUB(244)=1
6692 MSUB(258)=1
6693 MSUB(259)=1
6694 MSUB(261)=1
6695 MSUB(262)=1
6696 MSUB(264)=1
6697 MSUB(265)=1
6698 DO 250 I=271,296
6699 MSUB(I)=1
6700 250 CONTINUE
6701 ELSEIF(MINT(43).EQ.1) THEN
6702 MSUB(277)=1
6703 MSUB(278)=1
6704 ENDIF
6705
6706 ELSEIF(MSEL.EQ.41) THEN
6707C...Stop production.
6708 MSUB(261)=1
6709 MSUB(262)=1
6710 MSUB(263)=1
6711 IF(MINT(43).EQ.4) THEN
6712 MSUB(264)=1
6713 MSUB(265)=1
6714 ENDIF
6715
6716 ELSEIF(MSEL.EQ.42) THEN
6717C...Slepton production.
6718 DO 260 I=201,214
6719 MSUB(I)=1
6720 260 CONTINUE
6721 IF(MINT(43).NE.4) THEN
6722 MSUB(210)=0
6723 MSUB(211)=0
6724 MSUB(212)=0
6725 ENDIF
6726
6727 ELSEIF(MSEL.EQ.43) THEN
6728C...Neutralino/Chargino + Gluino/Squark.
6729 IF(MINT(43).EQ.4) THEN
6730 DO 270 I=237,242
6731 MSUB(I)=1
6732 270 CONTINUE
6733 DO 280 I=246,254
6734 MSUB(I)=1
6735 280 CONTINUE
6736 MSUB(256)=1
6737 ENDIF
6738
6739 ELSEIF(MSEL.EQ.44) THEN
6740C...Neutralino/Chargino pair production.
6741 IF(MINT(43).EQ.4) THEN
6742 DO 290 I=216,236
6743 MSUB(I)=1
6744 290 CONTINUE
6745 ELSEIF(MINT(43).EQ.1) THEN
6746 DO 300 I=216,228
6747 MSUB(I)=1
6748 300 CONTINUE
6749 ENDIF
6750
6751 ELSEIF(MSEL.EQ.45) THEN
6752C...Sbottom production.
6753 MSUB(287)=1
6754 MSUB(288)=1
6755 IF(MINT(43).EQ.4) THEN
6756 DO 310 I=281,296
6757 MSUB(I)=1
6758 310 CONTINUE
6759 ENDIF
6760
6761 ELSEIF(MSEL.EQ.50) THEN
6762C...Pair production of technipions and gauge bosons.
6763 DO 320 I=361,368
6764 MSUB(I)=1
6765 320 CONTINUE
6766 IF(MINT(43).EQ.4) THEN
6767 DO 330 I=370,377
6768 MSUB(I)=1
6769 330 CONTINUE
6770 ENDIF
6771
6772 ELSEIF(MSEL.EQ.51) THEN
6773C...QCD 2 -> 2 processes with compositeness/technicolor modifications.
6774 DO 340 I=381,386
6775 MSUB(I)=1
6776 340 CONTINUE
6777
6778 ELSEIF(MSEL.EQ.61) THEN
6779C...Charmonium production in colour octet model, with recoiling parton.
6780 DO 342 I=421,439
6781 MSUB(I)=1
6782 342 CONTINUE
6783
6784 ELSEIF(MSEL.EQ.62) THEN
6785C...Bottomonium production in colour octet model, with recoiling parton.
6786 DO 344 I=461,479
6787 MSUB(I)=1
6788 344 CONTINUE
6789
6790 ELSEIF(MSEL.EQ.63) THEN
6791C...Charmonium and bottomonium production in colour octet model.
6792 DO 346 I=421,439
6793 MSUB(I)=1
6794 MSUB(I+40)=1
6795 346 CONTINUE
6796 ENDIF
6797
6798C...Find heaviest new quark flavour allowed in processes 81-84.
6799 KFLQM=1
6800 DO 350 I=1,MIN(8,MDCY(21,3))
6801 IDC=I+MDCY(21,2)-1
6802 IF(MDME(IDC,1).LE.0) GOTO 350
6803 KFLQM=I
6804 350 CONTINUE
6805 IF(MSTP(7).GE.1.AND.MSTP(7).LE.8.AND.(MSEL.LE.3.OR.MSEL.GE.9))
6806 &KFLQM=MSTP(7)
6807 MINT(55)=KFLQM
6808 KFPR(81,1)=KFLQM
6809 KFPR(81,2)=KFLQM
6810 KFPR(82,1)=KFLQM
6811 KFPR(82,2)=KFLQM
6812 KFPR(83,1)=KFLQM
6813 KFPR(84,1)=KFLQM
6814 KFPR(84,2)=KFLQM
6815
6816C...Find heaviest new fermion flavour allowed in process 85.
6817 KFLFM=1
6818 DO 360 I=1,MIN(12,MDCY(22,3))
6819 IDC=I+MDCY(22,2)-1
6820 IF(MDME(IDC,1).LE.0) GOTO 360
6821 KFLFM=KFDP(IDC,1)
6822 360 CONTINUE
6823 IF(((MSTP(7).GE.1.AND.MSTP(7).LE.8).OR.(MSTP(7).GE.11.AND.
6824 &MSTP(7).LE.18)).AND.(MSEL.LE.3.OR.MSEL.GE.9)) KFLFM=MSTP(7)
6825 MINT(56)=KFLFM
6826 KFPR(85,1)=KFLFM
6827 KFPR(85,2)=KFLFM
6828
6829C...Initialize Generic Processes
6830 KFGEN=9900001
6831 KCGEN=PYCOMP(KFGEN)
6832 IF(KCGEN.GT.0) THEN
6833 IDCY=MDCY(KCGEN,2)
6834 IF(IDCY.GT.0) THEN
6835 KFF1=KFDP(IDCY+1,1)
6836 KFF2=KFDP(IDCY+1,2)
6837 KCF1=PYCOMP(KFF1)
6838 KCF2=PYCOMP(KFF2)
6839 JCOL1=IABS(KCHG(KCF1,2))
6840 IF(JCOL1.EQ.1) THEN
6841 KF1=KFF1
6842 KF2=KFF2
6843 ELSE
6844 KF1=KFF2
6845 KF2=KFF1
6846 ENDIF
6847 KFPR(481,1)=KF1
6848 KFPR(481,2)=KF2
6849 KFPR(482,1)=KF1
6850 KFPR(482,2)=KF2
6851 ENDIF
6852 IF(KFDP(IDCY,1).EQ.21.OR.KFDP(IDCY,2).EQ.21) THEN
6853 KFIN(1,0)=1
6854 KFIN(2,0)=1
6855 ENDIF
6856 ENDIF
6857
6858C...Import relevant information on external user processes.
6859 IF(MINT(111).GE.11) THEN
6860 IPYPR=0
6861 DO 390 IUP=1,NPRUP
6862C...Find next empty PYTHIA process number slot and enable it.
6863 370 IPYPR=IPYPR+1
6864 IF(IPYPR.GT.500) CALL PYERRM(26,
6865 & '(PYINPR.) no more empty slots for user processes')
6866 IF(ISET(IPYPR).GE.0.AND.ISET(IPYPR).LE.9) GOTO 370
6867 IF(IPYPR.GE.91.AND.IPYPR.LE.100) GOTO 370
6868 ISET(IPYPR)=11
6869C...Overwrite KFPR with references back to process number and ID.
6870 KFPR(IPYPR,1)=IUP
6871 KFPR(IPYPR,2)=LPRUP(IUP)
6872C...Process title.
6873 WRITE(CHIPR,'(I10)') LPRUP(IUP)
6874 ICHIN=1
6875 DO 380 ICH=1,9
6876 IF(CHIPR(ICH:ICH).EQ.' ') ICHIN=ICH+1
6877 380 CONTINUE
6878 PROC(IPYPR)='User process '//CHIPR(ICHIN:10)//' '
6879C...Switch on process.
6880 MSUB(IPYPR)=1
6881 390 CONTINUE
6882 ENDIF
6883
6884 RETURN
6885 END
6886
6887C*********************************************************************
6888
6889C...PYXTOT
6890C...Parametrizes total, elastic and diffractive cross-sections
6891C...for different energies and beams. Donnachie-Landshoff for
6892C...total and Schuler-Sjostrand for elastic and diffractive.
6893C...Process code IPROC:
6894C...= 1 : p + p;
6895C...= 2 : pbar + p;
6896C...= 3 : pi+ + p;
6897C...= 4 : pi- + p;
6898C...= 5 : pi0 + p;
6899C...= 6 : phi + p;
6900C...= 7 : J/psi + p;
6901C...= 11 : rho + rho;
6902C...= 12 : rho + phi;
6903C...= 13 : rho + J/psi;
6904C...= 14 : phi + phi;
6905C...= 15 : phi + J/psi;
6906C...= 16 : J/psi + J/psi;
6907C...= 21 : gamma + p (DL);
6908C...= 22 : gamma + p (VDM).
6909C...= 23 : gamma + pi (DL);
6910C...= 24 : gamma + pi (VDM);
6911C...= 25 : gamma + gamma (DL);
6912C...= 26 : gamma + gamma (VDM).
6913
6914 SUBROUTINE PYXTOT
6915
6916C...Double precision and integer declarations.
6917 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
6918 IMPLICIT INTEGER(I-N)
6919 INTEGER PYK,PYCHGE,PYCOMP
6920C...Commonblocks.
6921 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
6922 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
6923 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
6924 COMMON/PYINT1/MINT(400),VINT(400)
6925 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
6926 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
6927 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT5/,/PYINT7/
6928C...Local arrays.
6929 DIMENSION NPROC(30),XPAR(30),YPAR(30),IHADA(20),IHADB(20),
6930 &PMHAD(4),BHAD(4),BETP(4),IFITSD(20),IFITDD(20),CEFFS(10,8),
6931 &CEFFD(10,9),SIGTMP(6,0:5)
6932
6933C...Common constants.
6934 DATA EPS/0.0808D0/, ETA/-0.4525D0/, ALP/0.25D0/, CRES/2D0/,
6935 &PMRC/1.062D0/, SMP/0.880D0/, FACEL/0.0511D0/, FACSD/0.0336D0/,
6936 &FACDD/0.0084D0/
6937
6938C...Number of multiple processes to be evaluated (= 0 : undefined).
6939 DATA NPROC/7*1,3*0,6*1,4*0,4*3,2*6,4*0/
6940C...X and Y parameters of sigmatot = X * s**epsilon + Y * s**(-eta).
6941 DATA XPAR/2*21.70D0,3*13.63D0,10.01D0,0.970D0,3*0D0,
6942 &8.56D0,6.29D0,0.609D0,4.62D0,0.447D0,0.0434D0,4*0D0,
6943 &0.0677D0,0.0534D0,0.0425D0,0.0335D0,2.11D-4,1.31D-4,4*0D0/
6944 DATA YPAR/
6945 &56.08D0,98.39D0,27.56D0,36.02D0,31.79D0,-1.51D0,-0.146D0,3*0D0,
6946 &13.08D0,-0.62D0,-0.060D0,0.030D0,-0.0028D0,0.00028D0,4*0D0,
6947 &0.129D0,0.115D0,0.081D0,0.072D0,2.15D-4,1.70D-4,4*0D0/
6948
6949C...Beam and target hadron class:
6950C...= 1 : p/n ; = 2 : pi/rho/omega; = 3 : phi; = 4 : J/psi.
6951 DATA IHADA/2*1,3*2,3,4,3*0,3*2,2*3,4,4*0/
6952 DATA IHADB/7*1,3*0,2,3,4,3,2*4,4*0/
6953C...Characteristic class masses, slope parameters, beta = sqrt(X).
6954 DATA PMHAD/0.938D0,0.770D0,1.020D0,3.097D0/
6955 DATA BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
6956 DATA BETP/4.658D0,2.926D0,2.149D0,0.208D0/
6957
6958C...Fitting constants used in parametrizations of diffractive results.
6959 DATA IFITSD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6960 DATA IFITDD/2*1,3*2,3,4,3*0,5,6,7,8,9,10,4*0/
6961 DATA ((CEFFS(J1,J2),J2=1,8),J1=1,10)/
6962 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.213D0, 0.0D0, -0.47D0, 150D0,
6963 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.267D0, 0.0D0, -0.47D0, 100D0,
6964 &0.213D0, 0.0D0, -0.47D0, 150D0, 0.232D0, 0.0D0, -0.47D0, 110D0,
6965 &0.213D0, 7.0D0, -0.55D0, 800D0, 0.115D0, 0.0D0, -0.47D0, 110D0,
6966 &0.267D0, 0.0D0, -0.46D0, 75D0, 0.267D0, 0.0D0, -0.46D0, 75D0,
6967 &0.232D0, 0.0D0, -0.46D0, 85D0, 0.267D0, 0.0D0, -0.48D0, 100D0,
6968 &0.115D0, 0.0D0, -0.50D0, 90D0, 0.267D0, 6.0D0, -0.56D0, 420D0,
6969 &0.232D0, 0.0D0, -0.48D0, 110D0, 0.232D0, 0.0D0, -0.48D0, 110D0,
6970 &0.115D0, 0.0D0, -0.52D0, 120D0, 0.232D0, 6.0D0, -0.56D0, 470D0,
6971 &0.115D0, 5.5D0, -0.58D0, 570D0, 0.115D0, 5.5D0, -0.58D0, 570D0/
6972 DATA ((CEFFD(J1,J2),J2=1,9),J1=1,10)/
6973 &3.11D0, -7.34D0, 9.71D0, 0.068D0, -0.42D0, 1.31D0,
6974 &-1.37D0, 35.0D0, 118D0, 3.11D0, -7.10D0, 10.6D0,
6975 &0.073D0, -0.41D0, 1.17D0, -1.41D0, 31.6D0, 95D0,
6976 &3.12D0, -7.43D0, 9.21D0, 0.067D0, -0.44D0, 1.41D0,
6977 &-1.35D0, 36.5D0, 132D0, 3.13D0, -8.18D0, -4.20D0,
6978 &0.056D0, -0.71D0, 3.12D0, -1.12D0, 55.2D0, 1298D0,
6979 &3.11D0, -6.90D0, 11.4D0, 0.078D0, -0.40D0, 1.05D0,
6980 &-1.40D0, 28.4D0, 78D0, 3.11D0, -7.13D0, 10.0D0,
6981 &0.071D0, -0.41D0, 1.23D0, -1.34D0, 33.1D0, 105D0,
6982 &3.12D0, -7.90D0, -1.49D0, 0.054D0, -0.64D0, 2.72D0,
6983 &-1.13D0, 53.1D0, 995D0, 3.11D0, -7.39D0, 8.22D0,
6984 &0.065D0, -0.44D0, 1.45D0, -1.36D0, 38.1D0, 148D0,
6985 &3.18D0, -8.95D0, -3.37D0, 0.057D0, -0.76D0, 3.32D0,
6986 &-1.12D0, 55.6D0, 1472D0, 4.18D0, -29.2D0, 56.2D0,
6987 &0.074D0, -1.36D0, 6.67D0, -1.14D0, 116.2D0, 6532D0/
6988
6989C...Parameters. Combinations of the energy.
6990 AEM=PARU(101)
6991 PMTH=PARP(102)
6992 S=VINT(2)
6993 SRT=VINT(1)
6994 SEPS=S**EPS
6995 SETA=S**ETA
6996 SLOG=LOG(S)
6997
6998C...Ratio of gamma/pi (for rescaling in parton distributions).
6999 VINT(281)=(XPAR(22)*SEPS+YPAR(22)*SETA)/
7000 &(XPAR(5)*SEPS+YPAR(5)*SETA)
7001 VINT(317)=1D0
7002 IF(MINT(50).NE.1) RETURN
7003
7004C...Order flavours of incoming particles: KF1 < KF2.
7005 IF(IABS(MINT(11)).LE.IABS(MINT(12))) THEN
7006 KF1=IABS(MINT(11))
7007 KF2=IABS(MINT(12))
7008 IORD=1
7009 ELSE
7010 KF1=IABS(MINT(12))
7011 KF2=IABS(MINT(11))
7012 IORD=2
7013 ENDIF
7014 ISGN12=ISIGN(1,MINT(11)*MINT(12))
7015
7016C...Find process number (for lookup tables).
7017 IF(KF1.GT.1000) THEN
7018 IPROC=1
7019 IF(ISGN12.LT.0) IPROC=2
7020 ELSEIF(KF1.GT.100.AND.KF2.GT.1000) THEN
7021 IPROC=3
7022 IF(ISGN12.LT.0) IPROC=4
7023 IF(KF1.EQ.111) IPROC=5
7024 ELSEIF(KF1.GT.100) THEN
7025 IPROC=11
7026 ELSEIF(KF2.GT.1000) THEN
7027 IPROC=21
7028 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=22
7029 ELSEIF(KF2.GT.100) THEN
7030 IPROC=23
7031 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3) IPROC=24
7032 ELSE
7033 IPROC=25
7034 IF(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7) IPROC=26
7035 ENDIF
7036
7037C... Number of multiple processes to be stored; beam/target side.
7038 NPR=NPROC(IPROC)
7039 MINT(101)=1
7040 MINT(102)=1
7041 IF(NPR.EQ.3) THEN
7042 MINT(100+IORD)=4
7043 ELSEIF(NPR.EQ.6) THEN
7044 MINT(101)=4
7045 MINT(102)=4
7046 ENDIF
7047 N1=0
7048 IF(MINT(101).EQ.4) N1=4
7049 N2=0
7050 IF(MINT(102).EQ.4) N2=4
7051
7052C...Do not do any more for user-set or undefined cross-sections.
7053 IF(MSTP(31).LE.0) RETURN
7054 IF(NPR.EQ.0) CALL PYERRM(26,
7055 &'(PYXTOT:) cross section for this process not yet implemented')
7056
7057C...Parameters. Combinations of the energy.
7058 AEM=PARU(101)
7059 PMTH=PARP(102)
7060 S=VINT(2)
7061 SRT=VINT(1)
7062 SEPS=S**EPS
7063 SETA=S**ETA
7064 SLOG=LOG(S)
7065
7066C...Loop over multiple processes (for VDM).
7067 DO 110 I=1,NPR
7068 IF(NPR.EQ.1) THEN
7069 IPR=IPROC
7070 ELSEIF(NPR.EQ.3) THEN
7071 IPR=I+4
7072 IF(KF2.LT.1000) IPR=I+10
7073 ELSEIF(NPR.EQ.6) THEN
7074 IPR=I+10
7075 ENDIF
7076
7077C...Evaluate hadron species, mass, slope contribution and fit number.
7078 IHA=IHADA(IPR)
7079 IHB=IHADB(IPR)
7080 PMA=PMHAD(IHA)
7081 PMB=PMHAD(IHB)
7082 BHA=BHAD(IHA)
7083 BHB=BHAD(IHB)
7084 ISD=IFITSD(IPR)
7085 IDD=IFITDD(IPR)
7086
7087C...Skip if energy too low relative to masses.
7088 DO 100 J=0,5
7089 SIGTMP(I,J)=0D0
7090 100 CONTINUE
7091 IF(SRT.LT.PMA+PMB+PARP(104)) GOTO 110
7092
7093C...Total cross-section. Elastic slope parameter and cross-section.
7094 SIGTMP(I,0)=XPAR(IPR)*SEPS+YPAR(IPR)*SETA
7095 BEL=2D0*BHA+2D0*BHB+4D0*SEPS-4.2D0
7096 SIGTMP(I,1)=FACEL*SIGTMP(I,0)**2/BEL
7097
7098C...Diffractive scattering A + B -> X + B.
7099 BSD=2D0*BHB
7100 SQML=(PMA+PMTH)**2
7101 SQMU=S*CEFFS(ISD,1)+CEFFS(ISD,2)
7102 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7103 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7104 BXB=CEFFS(ISD,3)+CEFFS(ISD,4)/S
7105 SUM2=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)/
7106 & (BSD+2D0*ALP*LOG(S/((PMA+PMTH)*(PMA+PMRC)))+BXB)
7107 SIGTMP(I,2)=FACSD*XPAR(IPR)*BETP(IHB)*MAX(0D0,SUM1+SUM2)
7108
7109C...Diffractive scattering A + B -> A + X.
7110 BSD=2D0*BHA
7111 SQML=(PMB+PMTH)**2
7112 SQMU=S*CEFFS(ISD,5)+CEFFS(ISD,6)
7113 SUM1=LOG((BSD+2D0*ALP*LOG(S/SQML))/
7114 & (BSD+2D0*ALP*LOG(S/SQMU)))/(2D0*ALP)
7115 BAX=CEFFS(ISD,7)+CEFFS(ISD,8)/S
7116 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/
7117 & (BSD+2D0*ALP*LOG(S/((PMB+PMTH)*(PMB+PMRC)))+BAX)
7118 SIGTMP(I,3)=FACSD*XPAR(IPR)*BETP(IHA)*MAX(0D0,SUM1+SUM2)
7119
7120C...Order single diffractive correctly.
7121 IF(IORD.EQ.2) THEN
7122 SIGSAV=SIGTMP(I,2)
7123 SIGTMP(I,2)=SIGTMP(I,3)
7124 SIGTMP(I,3)=SIGSAV
7125 ENDIF
7126
7127C...Double diffractive scattering A + B -> X1 + X2.
7128 YEFF=LOG(S*SMP/((PMA+PMTH)*(PMB+PMTH))**2)
7129 DEFF=CEFFD(IDD,1)+CEFFD(IDD,2)/SLOG+CEFFD(IDD,3)/SLOG**2
7130 SUM1=(DEFF+YEFF*(LOG(MAX(1D-10,YEFF/DEFF))-1D0))/(2D0*ALP)
7131 IF(YEFF.LE.0) SUM1=0D0
7132 SQMU=S*(CEFFD(IDD,4)+CEFFD(IDD,5)/SLOG+CEFFD(IDD,6)/SLOG**2)
7133 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMA+PMTH)**2*(PMB+PMTH)*(PMB+PMRC))))
7134 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMB+PMTH)*(PMB+PMRC))))
7135 SUM2=CRES*LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)*LOG(SLUP/SLDN)/
7136 & (2D0*ALP)
7137 SLUP=LOG(MAX(1.1D0,S/(ALP*(PMB+PMTH)**2*(PMA+PMTH)*(PMA+PMRC))))
7138 SLDN=LOG(MAX(1.1D0,S/(ALP*SQMU*(PMA+PMTH)*(PMA+PMRC))))
7139 SUM3=CRES*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*LOG(SLUP/SLDN)/
7140 & (2D0*ALP)
7141 BXX=CEFFD(IDD,7)+CEFFD(IDD,8)/SRT+CEFFD(IDD,9)/S
7142 SLRR=LOG(S/(ALP*(PMA+PMTH)*(PMA+PMRC)*(PMB+PMTH)*(PMB+PMRC)))
7143 SUM4=CRES**2*LOG(1D0+((PMA+PMRC)/(PMA+PMTH))**2)*
7144 & LOG(1D0+((PMB+PMRC)/(PMB+PMTH))**2)/MAX(0.1D0,2D0*ALP*SLRR+BXX)
7145 SIGTMP(I,4)=FACDD*XPAR(IPR)*MAX(0D0,SUM1+SUM2+SUM3+SUM4)
7146
7147C...Non-diffractive by unitarity.
7148 SIGTMP(I,5)=SIGTMP(I,0)-SIGTMP(I,1)-SIGTMP(I,2)-SIGTMP(I,3)-
7149 & SIGTMP(I,4)
7150 110 CONTINUE
7151
7152C...Put temporary results in output array: only one process.
7153 IF(MINT(101).EQ.1.AND.MINT(102).EQ.1) THEN
7154 DO 120 J=0,5
7155 SIGT(0,0,J)=SIGTMP(1,J)
7156 120 CONTINUE
7157
7158C...Beam multiple processes.
7159 ELSEIF(MINT(101).EQ.4.AND.MINT(102).EQ.1) THEN
7160 IF(MINT(107).EQ.2) THEN
7161 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7162 ELSE
7163 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7164 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7165 ENDIF
7166 IF(MSTP(20).GT.0) THEN
7167 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)))**MSTP(20)
7168 ENDIF
7169 DO 140 I=1,4
7170 IF(MINT(107).EQ.2) THEN
7171 CONV=(AEM/PARP(160+I))*VINT(317)
7172 ELSEIF(VINT(154).GT.PARP(15)) THEN
7173 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7174 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7175 ELSE
7176 CONV=0D0
7177 ENDIF
7178 I1=MAX(1,I-1)
7179 DO 130 J=0,5
7180 SIGT(I,0,J)=CONV*SIGTMP(I1,J)
7181 130 CONTINUE
7182 140 CONTINUE
7183 DO 150 J=0,5
7184 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7185 150 CONTINUE
7186
7187C...Target multiple processes.
7188 ELSEIF(MINT(101).EQ.1.AND.MINT(102).EQ.4) THEN
7189 IF(MINT(108).EQ.2) THEN
7190 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7191 ELSE
7192 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7193 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7194 ENDIF
7195 IF(MSTP(20).GT.0) THEN
7196 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(308)))**MSTP(20)
7197 ENDIF
7198 DO 170 I=1,4
7199 IF(MINT(108).EQ.2) THEN
7200 CONV=(AEM/PARP(160+I))*VINT(317)
7201 ELSEIF(VINT(154).GT.PARP(15)) THEN
7202 CONV=(AEM/PARU(1))*(KCHG(I,1)/3D0)**2*PARP(18)**2*
7203 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7204 ELSE
7205 CONV=0D0
7206 ENDIF
7207 IV=MAX(1,I-1)
7208 DO 160 J=0,5
7209 SIGT(0,I,J)=CONV*SIGTMP(IV,J)
7210 160 CONTINUE
7211 170 CONTINUE
7212 DO 180 J=0,5
7213 SIGT(0,0,J)=SIGT(0,1,J)+SIGT(0,2,J)+SIGT(0,3,J)+SIGT(0,4,J)
7214 180 CONTINUE
7215
7216C...Both beam and target multiple processes.
7217 ELSE
7218 IF(MINT(107).EQ.2) THEN
7219 VINT(317)=(PMHAD(2)**2/(PMHAD(2)**2+VINT(307)))**2
7220 ELSE
7221 VINT(317)=16D0*PARP(15)**2*VINT(154)**2/
7222 & ((4D0*PARP(15)**2+VINT(307))*(4D0*VINT(154)**2+VINT(307)))
7223 ENDIF
7224 IF(MINT(108).EQ.2) THEN
7225 VINT(317)=VINT(317)*(PMHAD(2)**2/(PMHAD(2)**2+VINT(308)))**2
7226 ELSE
7227 VINT(317)=VINT(317)*16D0*PARP(15)**2*VINT(154)**2/
7228 & ((4D0*PARP(15)**2+VINT(308))*(4D0*VINT(154)**2+VINT(308)))
7229 ENDIF
7230 IF(MSTP(20).GT.0) THEN
7231 VINT(317)=VINT(317)*(VINT(2)/(VINT(2)+VINT(307)+
7232 & VINT(308)))**MSTP(20)
7233 ENDIF
7234 DO 210 I1=1,4
7235 DO 200 I2=1,4
7236 IF(MINT(107).EQ.2) THEN
7237 CONV=(AEM/PARP(160+I1))*VINT(317)
7238 ELSEIF(VINT(154).GT.PARP(15)) THEN
7239 CONV=(AEM/PARU(1))*(KCHG(I1,1)/3D0)**2*PARP(18)**2*
7240 & (1D0/PARP(15)**2-1D0/VINT(154)**2)*VINT(317)
7241 ELSE
7242 CONV=0D0
7243 ENDIF
7244 IF(MINT(108).EQ.2) THEN
7245 CONV=CONV*(AEM/PARP(160+I2))
7246 ELSEIF(VINT(154).GT.PARP(15)) THEN
7247 CONV=CONV*(AEM/PARU(1))*(KCHG(I2,1)/3D0)**2*PARP(18)**2*
7248 & (1D0/PARP(15)**2-1D0/VINT(154)**2)
7249 ELSE
7250 CONV=0D0
7251 ENDIF
7252 IF(I1.LE.2) THEN
7253 IV=MAX(1,I2-1)
7254 ELSEIF(I2.LE.2) THEN
7255 IV=MAX(1,I1-1)
7256 ELSEIF(I1.EQ.I2) THEN
7257 IV=2*I1-2
7258 ELSE
7259 IV=5
7260 ENDIF
7261 DO 190 J=0,5
7262 JV=J
7263 IF(I2.GT.I1.AND.(J.EQ.2.OR.J.EQ.3)) JV=5-J
7264 SIGT(I1,I2,J)=CONV*SIGTMP(IV,JV)
7265 190 CONTINUE
7266 200 CONTINUE
7267 210 CONTINUE
7268 DO 230 J=0,5
7269 DO 220 I=1,4
7270 SIGT(I,0,J)=SIGT(I,1,J)+SIGT(I,2,J)+SIGT(I,3,J)+SIGT(I,4,J)
7271 SIGT(0,I,J)=SIGT(1,I,J)+SIGT(2,I,J)+SIGT(3,I,J)+SIGT(4,I,J)
7272 220 CONTINUE
7273 SIGT(0,0,J)=SIGT(1,0,J)+SIGT(2,0,J)+SIGT(3,0,J)+SIGT(4,0,J)
7274 230 CONTINUE
7275 ENDIF
7276
7277C...Scale up uniformly for Donnachie-Landshoff parametrization.
7278 IF(IPROC.EQ.21.OR.IPROC.EQ.23.OR.IPROC.EQ.25) THEN
7279 RFAC=(XPAR(IPROC)*SEPS+YPAR(IPROC)*SETA)/SIGT(0,0,0)
7280 DO 260 I1=0,N1
7281 DO 250 I2=0,N2
7282 DO 240 J=0,5
7283 SIGT(I1,I2,J)=RFAC*SIGT(I1,I2,J)
7284 240 CONTINUE
7285 250 CONTINUE
7286 260 CONTINUE
7287 ENDIF
7288
7289 RETURN
7290 END
7291
7292C*********************************************************************
7293
7294C...PYMAXI
7295C...Finds optimal set of coefficients for kinematical variable selection
7296C...and the maximum of the part of the differential cross-section used
7297C...in the event weighting.
7298
7299 SUBROUTINE PYMAXI
7300
7301C...Double precision and integer declarations.
7302 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
7303 IMPLICIT INTEGER(I-N)
7304 INTEGER PYK,PYCHGE,PYCOMP
7305C...Parameter statement to help give large particle numbers.
7306 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
7307 &KEXCIT=4000000,KDIMEN=5000000)
7308
7309C...User process initialization commonblock.
7310 INTEGER MAXPUP
7311 PARAMETER (MAXPUP=100)
7312 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
7313 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
7314 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
7315 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
7316 &LPRUP(MAXPUP)
7317 SAVE /HEPRUP/
7318
7319C...Commonblocks.
7320 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
7321 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
7322 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
7323 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
7324 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
7325 COMMON/PYINT1/MINT(400),VINT(400)
7326 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
7327 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
7328 COMMON/PYINT4/MWID(500),WIDS(500,5)
7329 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
7330 COMMON/PYINT6/PROC(0:500)
7331 CHARACTER PROC*28
7332 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
7333 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
7334 COMMON/PYTCCO/COEFX(194:380,2)
7335 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
7336 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
7337 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT6/,/PYINT7/,/PYTCCO/,
7338 &/PYTCSM/,/TCPARA/
7339C...Local arrays, character variables and data.
7340 LOGICAL IOK
7341 CHARACTER CVAR(4)*4
7342 DIMENSION NPTS(4),MVARPT(500,4),VINTPT(500,30),SIGSPT(500),
7343 &NAREL(9),WTREL(9),WTMAT(9,9),WTRELN(9),COEFU(9),COEFO(9),
7344 &IACCMX(4),SIGSMX(4),SIGSSM(3),PMMN(2),WTRSAV(9),TEMPC(9),
7345 &IQ(9),IP(9)
7346 DATA CVAR/'tau ','tau''','y* ','cth '/
7347 DATA SIGSSM/3*0D0/
7348
7349C...Initial values and loop over subprocesses.
7350 NPOSI=0
7351 VINT(143)=1D0
7352 VINT(144)=1D0
7353 XSEC(0,1)=0D0
7354 ITECH=0
7355 DO 460 ISUB=1,500
7356 MINT(1)=ISUB
7357 MINT(51)=0
7358
7359C...Find maximum weight factors for photon flux.
7360 IF(MSUB(ISUB).EQ.1.OR.(ISUB.GE.91.AND.ISUB.LE.100)) THEN
7361 IF(MINT(141).NE.0.OR.MINT(142).NE.0) CALL PYGAGA(2,WTGAGA)
7362 ENDIF
7363
7364C...Select subprocess to study: skip cases not applicable.
7365 IF(ISET(ISUB).EQ.11) THEN
7366 IF(MSUB(ISUB).NE.1) GOTO 460
7367C...User process intialization: cross section model dependent.
7368 IF(IABS(IDWTUP).EQ.1) THEN
7369 IF(IDWTUP.GT.0.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7370 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7371 XSEC(ISUB,1)=1.00000001D-9*ABS(XMAXUP(KFPR(ISUB,1)))
7372 ELSE
7373 IF((IDWTUP.EQ.2.OR.IDWTUP.EQ.3).AND.
7374 & XSECUP(KFPR(ISUB,1)).LT.0D0) CALL
7375 & PYERRM(26,'(PYMAXI:) Negative XSECUP for user process')
7376 IF(IDWTUP.EQ.2.AND.XMAXUP(KFPR(ISUB,1)).LT.0D0) CALL
7377 & PYERRM(26,'(PYMAXI:) Negative XMAXUP for user process')
7378 XSEC(ISUB,1)=1.00000001D-9*ABS(XSECUP(KFPR(ISUB,1)))
7379 ENDIF
7380 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7381 & WTGAGA*XSEC(ISUB,1)
7382 NPOSI=NPOSI+1
7383 GOTO 450
7384 ELSEIF(ISUB.GE.91.AND.ISUB.LE.95) THEN
7385 CALL PYSIGH(NCHN,SIGS)
7386 XSEC(ISUB,1)=SIGS
7387 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7388 & WTGAGA*XSEC(ISUB,1)
7389 IF(MSUB(ISUB).NE.1) GOTO 460
7390 NPOSI=NPOSI+1
7391 GOTO 450
7392 ELSEIF(ISUB.EQ.99.AND.MSUB(ISUB).EQ.1) THEN
7393 CALL PYSIGH(NCHN,SIGS)
7394 XSEC(ISUB,1)=SIGS
7395 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
7396 & WTGAGA*XSEC(ISUB,1)
7397 IF(XSEC(ISUB,1).EQ.0D0) THEN
7398 MSUB(ISUB)=0
7399 ELSE
7400 NPOSI=NPOSI+1
7401 ENDIF
7402 GOTO 450
7403 ELSEIF(ISUB.EQ.96) THEN
7404 IF(MINT(50).EQ.0) GOTO 460
7405 IF(MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0.AND.MSTP(131).LE.0)
7406 & GOTO 460
7407 IF(MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 460
7408 ELSEIF(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13.OR.ISUB.EQ.28.OR.
7409 & ISUB.EQ.53.OR.ISUB.EQ.68) THEN
7410 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7411 ELSEIF(ISUB.GE.381.AND.ISUB.LE.386) THEN
7412 IF(MSUB(ISUB).NE.1.OR.MSUB(95).EQ.1) GOTO 460
7413 ELSE
7414 IF(MSUB(ISUB).NE.1) GOTO 460
7415 ENDIF
7416 ISTSB=ISET(ISUB)
7417 IF(ISUB.EQ.96) ISTSB=2
7418 IF(MSTP(122).GE.2) WRITE(MSTU(11),5000) ISUB
7419 MWTXS=0
7420 IF(MSTP(142).GE.1.AND.ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+
7421 & MSUB(94)+MSUB(95).EQ.0) MWTXS=1
7422
7423C...Find resonances (explicit or implicit in cross-section).
7424 MINT(72)=0
7425 KFR1=0
7426 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
7427 KFR1=KFPR(ISUB,1)
7428 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165
7429 & .OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
7430 KFR1=23
7431 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172
7432 & .OR.ISUB.EQ.177) THEN
7433 KFR1=24
7434 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
7435 KFR1=25
7436 IF(MSTP(46).EQ.5) THEN
7437 KFR1=89
7438 PMAS(89,1)=PARP(45)
7439 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
7440 ENDIF
7441 ELSEIF(ISUB.EQ.481) THEN
7442 KFR1=9900001
7443 ENDIF
7444 CKMX=CKIN(2)
7445 IF(CKMX.LE.0D0) CKMX=VINT(1)
7446 KCR1=PYCOMP(KFR1)
7447 IF(KCR1.EQ.0) KFR1=0
7448 IF(KFR1.NE.0) THEN
7449 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
7450 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
7451 ENDIF
7452 IF(KFR1.NE.0) THEN
7453 TAUR1=PMAS(KCR1,1)**2/VINT(2)
7454 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
7455 MINT(72)=1
7456 MINT(73)=KFR1
7457 VINT(73)=TAUR1
7458 VINT(74)=GAMR1
7459 ENDIF
7460 KFR2=0
7461 KFR3=0
7462 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
7463 $ (ISUB.GE.361.AND.ISUB.LE.380))
7464 $ THEN
7465 KFR2=23
7466 IF(ISUB.EQ.141) THEN
7467 KCR2=PYCOMP(KFR2)
7468 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
7469 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
7470 KFR2=0
7471 ELSE
7472 TAUR2=PMAS(KCR2,1)**2/VINT(2)
7473 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
7474 MINT(72)=2
7475 MINT(74)=KFR2
7476 VINT(75)=TAUR2
7477 VINT(76)=GAMR2
7478 ENDIF
7479 ELSEIF(ITECH.EQ.0) THEN
7480 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
7481 ITECH=1
7482 KFR1=KTECHN+113
7483 KCR1=PYCOMP(KFR1)
7484 KFR2=KTECHN+223
7485 KCR2=PYCOMP(KFR2)
7486 KFR3=KTECHN+115
7487 KCR3=PYCOMP(KFR3)
7488 IRES=0
7489C...Order the resonances
7490 IF(PMAS(KCR3,1).LT.PMAS(KCR2,1)) THEN
7491 KCT=KCR3
7492 KCR3=KCR2
7493 KCR2=KCT
7494 ENDIF
7495 IF(PMAS(KCR3,1).LT.PMAS(KCR1,1)) THEN
7496 KCT=KCR3
7497 KCR3=KCR1
7498 KCR1=KCT
7499 ENDIF
7500 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7501 KCT=KCR2
7502 KCR2=KCR1
7503 KCR1=KCT
7504 ENDIF
7505 DO 101 I=1,3
7506 IF(I.EQ.1) THEN
7507 SHN0=PMAS(KCR1,1)**2
7508 ELSEIF(I.EQ.2) THEN
7509 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 101
7510 SHN0=PMAS(KCR2,1)**2
7511 ELSEIF(I.EQ.3) THEN
7512 IF(ABS(PMAS(KCR3,1)-PMAS(KCR3,1)).LE.1D-6) GOTO 101
7513 SHN0=PMAS(KCR3,1)**2
7514 ENDIF
7515 AEM=PYALEM(SHN0)
7516 FAR=SQRT(AEM/ALPRHT)
7517 SHN=SHN0*(1D0-FAR)
7518 CALL PYTECM(SHN,S1,WIDO,1)
7519 RES=SHN-S1
7520 SHN=S1*.99D0
7521 SHSTEP=2D0
7522 102 SHN=SHN+SHSTEP
7523 CALL PYTECM(SHN,S1,WIDO,1)
7524 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7525 IOK=.FALSE.
7526 IF(IRES.GT.0) THEN
7527 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7528 ELSEIF(IRES.EQ.0) THEN
7529 IOK=.TRUE.
7530 ENDIF
7531 IF(IOK) THEN
7532 IRES=IRES+1
7533 XMAS(IRES)=SQRT(S1)
7534 XWID(IRES)=WIDO
7535 ENDIF
7536 ENDIF
7537 RES=SHN-S1
7538 IF(IRES.LT.3.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 102
7539 101 CONTINUE
7540 JRES=0
7541 KFR1=KTECHN+213
7542 KCR1=PYCOMP(KFR1)
7543 KFR2=KTECHN+215
7544 KCR2=PYCOMP(KFR2)
7545 IF(PMAS(KCR2,1).LT.PMAS(KCR1,1)) THEN
7546 KCT=KCR2
7547 KCR2=KCR1
7548 KCR1=KCT
7549 ENDIF
7550 DO 103 I=1,2
7551 IF(I.EQ.1) THEN
7552 SHN0=PMAS(KCR1,1)**2
7553 ELSEIF(I.EQ.2) THEN
7554 IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LE.1D-6) GOTO 103
7555 SHN0=PMAS(KCR2,1)**2
7556 ENDIF
7557 AEM=PYALEM(SHN0)
7558 FAR=SQRT(AEM/ALPRHT)
7559 SHN=SHN0*(1D0-FAR)
7560 CALL PYTECM(SHN,S1,WIDO,2)
7561 RES=SHN-S1
7562 SHN=S1*.99D0
7563 SHSTEP=2D0
7564 104 SHN=SHN+SHSTEP
7565 CALL PYTECM(SHN,S1,WIDO,2)
7566 IF(RES.LT.0D0.AND.SHN-S1.GE.0D0) THEN
7567 IOK=.FALSE.
7568 IF(JRES.GT.0) THEN
7569 IF(ABS(SQRT(S1)-XMAS(IRES)).GT.1D-6) IOK=.TRUE.
7570 ELSEIF(JRES.EQ.0) THEN
7571 IOK=.TRUE.
7572 ENDIF
7573 IF(IOK) THEN
7574 JRES=JRES+1
7575 YMAS(JRES)=SQRT(S1)
7576 YWID(JRES)=WIDO
7577 ENDIF
7578 ENDIF
7579 RES=SHN-S1
7580 IF(JRES.LT.2.AND.SHN.LT.SHN0*(1D0+FAR)) GOTO 104
7581 103 CONTINUE
7582 ENDIF
7583 IF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368).OR.
7584 & ISUB.EQ.379.OR.ISUB.EQ.380) THEN
7585 MINT(72)=IRES
7586 IF(IRES.GE.1) THEN
7587 VINT(73)=XMAS(1)**2/VINT(2)
7588 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
7589 TAUR1=VINT(73)
7590 GAMR1=VINT(74)
7591 XM1=XMAS(1)
7592 XG1=XWID(1)
7593 KFR1=1
7594 ENDIF
7595 IF(IRES.GE.2) THEN
7596 VINT(75)=XMAS(2)**2/VINT(2)
7597 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
7598 TAUR2=VINT(75)
7599 GAMR2=VINT(76)
7600 XM2=XMAS(2)
7601 XG2=XWID(2)
7602 KFR2=2
7603 ENDIF
7604 IF(IRES.EQ.3) THEN
7605 VINT(77)=XMAS(3)**2/VINT(2)
7606 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
7607 TAUR3=VINT(77)
7608 GAMR3=VINT(78)
7609 XM3=XMAS(3)
7610 XG3=XWID(3)
7611 KFR3=3
7612 ENDIF
7613C...Charged current: rho+- and a+-
7614 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
7615 MINT(72)=IRES
7616 IF(JRES.GE.1) THEN
7617 VINT(73)=YMAS(1)**2/VINT(2)
7618 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
7619 KFR1=1
7620 TAUR1=VINT(73)
7621 GAMR1=VINT(74)
7622 XM1=YMAS(1)
7623 XG1=YWID(1)
7624 ENDIF
7625 IF(JRES.GE.2) THEN
7626 VINT(75)=YMAS(2)**2/VINT(2)
7627 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
7628 KFR2=2
7629 TAUR2=VINT(73)
7630 GAMR2=VINT(74)
7631 XM2=YMAS(2)
7632 XG2=YWID(2)
7633 ENDIF
7634 KFR3=0
7635 ENDIF
7636 IF(ISUB.NE.141) THEN
7637 IF(KFR1.NE.0.AND.(CKIN(1).GT.(XM1+20D0*XG1)
7638 & .OR.CKMX.LT.(XM1-20D0*XG1))) KFR1=0
7639 IF(KFR2.NE.0.AND.(CKIN(1).GT.(XM2+20D0*XG2)
7640 & .OR.CKMX.LT.(XM2-20D0*XG2))) KFR2=0
7641 IF(KFR3.NE.0.AND.(CKIN(1).GT.(XM3+20D0*XG3)
7642 & .OR.CKMX.LT.(XM3-20D0*XG3))) KFR3=0
7643 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
7644
7645 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
7646 MINT(72)=2
7647 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
7648 MINT(72)=2
7649 MINT(74)=KFR3
7650 VINT(75)=TAUR3
7651 VINT(76)=GAMR3
7652 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
7653 MINT(72)=2
7654 MINT(73)=KFR2
7655 VINT(73)=TAUR2
7656 VINT(74)=GAMR2
7657 MINT(74)=KFR3
7658 VINT(75)=TAUR3
7659 VINT(76)=GAMR3
7660 ELSEIF(KFR1.NE.0) THEN
7661 MINT(72)=1
7662 ELSEIF(KFR2.NE.0) THEN
7663 MINT(72)=1
7664 MINT(73)=KFR2
7665 VINT(73)=TAUR2
7666 VINT(74)=GAMR2
7667 ELSEIF(KFR3.NE.0) THEN
7668 MINT(72)=1
7669 MINT(73)=KFR3
7670 VINT(73)=TAUR3
7671 VINT(74)=GAMR3
7672 ELSE
7673 MINT(72)=0
7674 ENDIF
7675 ELSE
7676 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
7677
7678 ELSEIF(KFR2.NE.0) THEN
7679 KFR1=KFR2
7680 TAUR1=TAUR2
7681 GAMR1=GAMR2
7682 MINT(72)=1
7683 MINT(73)=KFR1
7684 VINT(73)=TAUR1
7685 VINT(74)=GAMR1
7686 KFR2=0
7687 ELSE
7688 MINT(72)=0
7689 ENDIF
7690 ENDIF
7691 ENDIF
7692
7693C...Find product masses and minimum pT of process.
7694 SQM3=0D0
7695 SQM4=0D0
7696 MINT(71)=0
7697 VINT(71)=CKIN(3)
7698 VINT(80)=1D0
7699 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7700 NBW=0
7701 DO 110 I=1,2
7702 PMMN(I)=0D0
7703 IF(KFPR(ISUB,I).EQ.0) THEN
7704 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
7705 & PARP(41)) THEN
7706 IF(I.EQ.1) SQM3=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7707 IF(I.EQ.2) SQM4=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
7708 ELSE
7709 NBW=NBW+1
7710C...This prevents SUSY/t particles from becoming too light.
7711 KFLW=KFPR(ISUB,I)
7712 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
7713 KCW=PYCOMP(KFLW)
7714 PMMN(I)=PMAS(KCW,1)
7715 DO 100 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
7716 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
7717 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
7718 & PMAS(PYCOMP(KFDP(IDC,2)),1)
7719 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
7720 & PMAS(PYCOMP(KFDP(IDC,3)),1)
7721 PMMN(I)=MIN(PMMN(I),PMSUM)
7722 ENDIF
7723 100 CONTINUE
7724 ELSEIF(KFLW.EQ.6) THEN
7725 PMMN(I)=PMAS(24,1)+PMAS(5,1)
7726 ENDIF
7727 ENDIF
7728 110 CONTINUE
7729 IF(NBW.GE.1) THEN
7730 CKIN41=CKIN(41)
7731 CKIN43=CKIN(43)
7732 CKIN(41)=MAX(PMMN(1),CKIN(41))
7733 CKIN(43)=MAX(PMMN(2),CKIN(43))
7734 CALL PYOFSH(3,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
7735 CKIN(41)=CKIN41
7736 CKIN(43)=CKIN43
7737 IF(MINT(51).EQ.1) THEN
7738 WRITE(MSTU(11),5100) ISUB
7739 MSUB(ISUB)=0
7740 GOTO 460
7741 ENDIF
7742 SQM3=PQM3**2
7743 SQM4=PQM4**2
7744 ENDIF
7745 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2) MINT(71)=1
7746 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
7747 IF(ISUB.EQ.96.AND.MSTP(82).LE.1) THEN
7748 VINT(71)=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
7749 ELSEIF(ISUB.EQ.96) THEN
7750 VINT(71)=0.08D0*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
7751 ENDIF
7752 ENDIF
7753 VINT(63)=SQM3
7754 VINT(64)=SQM4
7755
7756C...Prepare for additional variable choices in 2 -> 3.
7757 IF(ISTSB.EQ.5) THEN
7758 VINT(201)=0D0
7759 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
7760 VINT(206)=VINT(201)
7761 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
7762 VINT(204)=PMAS(23,1)
7763 IF(ISUB.EQ.124.OR.ISUB.EQ.351) VINT(204)=PMAS(24,1)
7764 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
7765 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182
7766 & .OR.ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
7767 & VINT(204)=VINT(201)
7768 VINT(209)=VINT(204)
7769 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
7770 ENDIF
7771
7772C...Number of points for each variable: tau, tau', y*, cos(theta-hat).
7773 IPEAK7=0
7774 NPTS(1)=2+2*MINT(72)
7775 IF(MINT(47).EQ.1) THEN
7776 IF(ISTSB.EQ.1.OR.ISTSB.EQ.2) NPTS(1)=1
7777 ELSEIF(MINT(47).GE.5) THEN
7778 IF(ISTSB.LE.2.OR.ISTSB.GT.5) THEN
7779 NPTS(1)=NPTS(1)+1
7780 IPEAK7=1
7781 ENDIF
7782 ENDIF
7783 NPTS(2)=1
7784 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
7785 IF(MINT(47).GE.2) NPTS(2)=2
7786 IF(MINT(47).GE.5) NPTS(2)=3
7787 ENDIF
7788 NPTS(3)=1
7789 IF(MINT(47).EQ.4.OR.MINT(47).EQ.5) THEN
7790 NPTS(3)=3
7791 IF(MINT(45).EQ.3) NPTS(3)=NPTS(3)+1
7792 IF(MINT(46).EQ.3) NPTS(3)=NPTS(3)+1
7793 ENDIF
7794 NPTS(4)=1
7795 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) NPTS(4)=5
7796 NTRY=NPTS(1)*NPTS(2)*NPTS(3)*NPTS(4)
7797
7798C...Reset coefficients of cross-section weighting.
7799 DO 120 J=1,20
7800 COEF(ISUB,J)=0D0
7801 120 CONTINUE
7802 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361
7803 & .AND.ISUB.LE.380)) THEN
7804 DO 125 J=1,2
7805 COEFX(ISUB,J)=0D0
7806 125 CONTINUE
7807 ENDIF
7808 COEF(ISUB,1)=1D0
7809 COEF(ISUB,8)=0.5D0
7810 COEF(ISUB,9)=0.5D0
7811 COEF(ISUB,13)=1D0
7812 COEF(ISUB,18)=1D0
7813 MCTH=0
7814 MTAUP=0
7815 METAUP=0
7816 VINT(23)=0D0
7817 VINT(26)=0D0
7818 SIGSAM=0D0
7819
7820C...Find limits and select tau, y*, cos(theta-hat) and tau' values,
7821C...in grid of phase space points.
7822 CALL PYKLIM(1)
7823 METAU=MINT(51)
7824 NACC=0
7825 DO 150 ITRY=1,NTRY
7826 MINT(51)=0
7827 IF(METAU.EQ.1) GOTO 150
7828 IF(MOD(ITRY-1,NPTS(2)*NPTS(3)*NPTS(4)).EQ.0) THEN
7829 MTAU=1+(ITRY-1)/(NPTS(2)*NPTS(3)*NPTS(4))
7830 IF(MINT(72).LE.2.AND.MTAU.GT.2+2*MINT(72)) THEN
7831 MTAU=7
7832 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.0.AND.MTAU.GE.7) THEN
7833 MTAU=MTAU+1
7834 ENDIF
7835 RTAU=0.5D0
7836C...Special case when both resonances have same mass,
7837C...as is often the case in process 194.
7838c IF(MINT(72).GE.2) THEN
7839c IF(ABS(PMAS(KCR2,1)-PMAS(KCR1,1)).LT.
7840c & 0.01D0*(PMAS(KCR2,1)+PMAS(KCR1,1))) THEN
7841c IF(MTAU.EQ.3.OR.MTAU.EQ.4) THEN
7842c RTAU=0.4D0
7843c ELSEIF(MTAU.EQ.5.OR.MTAU.EQ.6) THEN
7844c RTAU=0.6D0
7845c ENDIF
7846c ENDIF
7847c ENDIF
7848 CALL PYKMAP(1,MTAU,RTAU)
7849 IF(ISTSB.GE.3.AND.ISTSB.LE.5) CALL PYKLIM(4)
7850 METAUP=MINT(51)
7851 ENDIF
7852 IF(METAUP.EQ.1) GOTO 150
7853 IF(ISTSB.GE.3.AND.ISTSB.LE.5.AND.MOD(ITRY-1,NPTS(3)*NPTS(4))
7854 & .EQ.0) THEN
7855 MTAUP=1+MOD((ITRY-1)/(NPTS(3)*NPTS(4)),NPTS(2))
7856 CALL PYKMAP(4,MTAUP,0.5D0)
7857 ENDIF
7858 IF(MOD(ITRY-1,NPTS(3)*NPTS(4)).EQ.0) THEN
7859 CALL PYKLIM(2)
7860 MEYST=MINT(51)
7861 ENDIF
7862 IF(MEYST.EQ.1) GOTO 150
7863 IF(MOD(ITRY-1,NPTS(4)).EQ.0) THEN
7864 MYST=1+MOD((ITRY-1)/NPTS(4),NPTS(3))
7865 IF(MYST.EQ.4.AND.MINT(45).NE.3) MYST=5
7866 CALL PYKMAP(2,MYST,0.5D0)
7867 CALL PYKLIM(3)
7868 MECTH=MINT(51)
7869 ENDIF
7870 IF(MECTH.EQ.1) GOTO 150
7871 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
7872 MCTH=1+MOD(ITRY-1,NPTS(4))
7873 CALL PYKMAP(3,MCTH,0.5D0)
7874 ENDIF
7875 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1D0-VINT(23)**2)
7876
7877C...Store position and limits.
7878 MINT(51)=0
7879 CALL PYKLIM(0)
7880 IF(MINT(51).EQ.1) GOTO 150
7881 NACC=NACC+1
7882 MVARPT(NACC,1)=MTAU
7883 MVARPT(NACC,2)=MTAUP
7884 MVARPT(NACC,3)=MYST
7885 MVARPT(NACC,4)=MCTH
7886 DO 130 J=1,30
7887 VINTPT(NACC,J)=VINT(10+J)
7888 130 CONTINUE
7889
7890C...Normal case: calculate cross-section.
7891 IF(ISTSB.NE.5) THEN
7892 CALL PYSIGH(NCHN,SIGS)
7893 IF(MWTXS.EQ.1) THEN
7894 CALL PYEVWT(WTXS)
7895 SIGS=WTXS*SIGS
7896 ENDIF
7897
7898C..2 -> 3: find highest value out of a number of tries.
7899 ELSE
7900 SIGS=0D0
7901 DO 140 IKIN3=1,MSTP(129)
7902 CALL PYKMAP(5,0,0D0)
7903 IF(MINT(51).EQ.1) GOTO 140
7904 CALL PYSIGH(NCHN,SIGTMP)
7905 IF(MWTXS.EQ.1) THEN
7906 CALL PYEVWT(WTXS)
7907 SIGTMP=WTXS*SIGTMP
7908 ENDIF
7909 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
7910 140 CONTINUE
7911 ENDIF
7912
7913C...Store cross-section.
7914 SIGSPT(NACC)=SIGS
7915 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
7916 IF(MSTP(122).GE.2) WRITE(MSTU(11),5200) MTAU,MYST,MCTH,MTAUP,
7917 & VINT(21),VINT(22),VINT(23),VINT(26),SIGS
7918 150 CONTINUE
7919 IF(NACC.EQ.0) THEN
7920 WRITE(MSTU(11),5100) ISUB
7921 MSUB(ISUB)=0
7922 GOTO 460
7923 ELSEIF(SIGSAM.EQ.0D0) THEN
7924 WRITE(MSTU(11),5300) ISUB
7925 MSUB(ISUB)=0
7926 GOTO 460
7927 ENDIF
7928 IF(ISUB.NE.96) NPOSI=NPOSI+1
7929
7930C...Calculate integrals in tau over maximal phase space limits.
7931 TAUMIN=VINT(11)
7932 TAUMAX=VINT(31)
7933 ATAU1=LOG(TAUMAX/TAUMIN)
7934 IF(NPTS(1).GE.2) THEN
7935 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
7936 ENDIF
7937 IF(NPTS(1).GE.4) THEN
7938 ATAU3=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))/TAUR1
7939 ATAU4=(ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1))/
7940 & GAMR1
7941 ENDIF
7942 IF(NPTS(1).GE.6) THEN
7943 ATAU5=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))/TAUR2
7944 ATAU6=(ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2))/
7945 & GAMR2
7946 ENDIF
7947 IF(NPTS(1).GE.8) THEN
7948 ATAU8=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))/TAUR3
7949 ATAU9=(ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3))/
7950 & GAMR3
7951 ENDIF
7952 IF(IPEAK7.EQ.1) THEN
7953 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
7954 ENDIF
7955
7956C...Reset. Sum up cross-sections in points calculated.
7957 DO 320 IVAR=1,4
7958 IF(NPTS(IVAR).EQ.1) GOTO 320
7959 IF(ISUB.EQ.96.AND.IVAR.EQ.4) GOTO 320
7960 NBIN=NPTS(IVAR)
7961 DO 170 J1=1,NBIN
7962 NAREL(J1)=0
7963 WTREL(J1)=0D0
7964 COEFU(J1)=0D0
7965 DO 160 J2=1,NBIN
7966 WTMAT(J1,J2)=0D0
7967 160 CONTINUE
7968 170 CONTINUE
7969 DO 180 IACC=1,NACC
7970 IBIN=MVARPT(IACC,IVAR)
7971 IF(IVAR.EQ.1) THEN
7972 IF(IBIN.GT.7.AND.IPEAK7.EQ.0) THEN
7973 IBIN=IBIN-1
7974 ELSEIF(IBIN.EQ.7.AND.IPEAK7.EQ.1.AND.MSTP(72).LT.3) THEN
7975 IBIN=3+2*MINT(72)
7976 ENDIF
7977 ENDIF
7978 IF(IVAR.EQ.3.AND.IBIN.EQ.5.AND.MINT(45).NE.3) IBIN=4
7979 NAREL(IBIN)=NAREL(IBIN)+1
7980 WTREL(IBIN)=WTREL(IBIN)+SIGSPT(IACC)
7981
7982C...Sum up tau cross-section pieces in points used.
7983 IF(IVAR.EQ.1) THEN
7984 TAU=VINTPT(IACC,11)
7985 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
7986 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAU1/ATAU2)/TAU
7987 IF(NBIN.GE.4) THEN
7988 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAU1/ATAU3)/(TAU+TAUR1)
7989 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ATAU1/ATAU4)*TAU/
7990 & ((TAU-TAUR1)**2+GAMR1**2)
7991 ENDIF
7992 IF(NBIN.GE.6) THEN
7993 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ATAU1/ATAU5)/(TAU+TAUR2)
7994 WTMAT(IBIN,6)=WTMAT(IBIN,6)+(ATAU1/ATAU6)*TAU/
7995 & ((TAU-TAUR2)**2+GAMR2**2)
7996 ENDIF
7997 IF(MINT(72).LE.2.AND.IPEAK7.EQ.1) THEN
7998 WTMAT(IBIN,3+2*MINT(72))=WTMAT(IBIN,3+2*MINT(72))
7999 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
8000 ELSEIF(MINT(72).EQ.3.AND.IPEAK7.EQ.1) THEN
8001 WTMAT(IBIN,7)=WTMAT(IBIN,7)
8002 & +(ATAU1/ATAU7)*TAU/MAX(2D-10,1D0-TAU)
8003 ENDIF
8004 IF(MINT(72).EQ.3) THEN
8005 WTMAT(IBIN,7+IPEAK7)=WTMAT(IBIN,7+IPEAK7)
8006 & +(ATAU1/ATAU8)/(TAU+TAUR3)
8007 WTMAT(IBIN,8+IPEAK7)=WTMAT(IBIN,8+IPEAK7)
8008 & +(ATAU1/ATAU9)*TAU/((TAU-TAUR3)**2+GAMR3**2)
8009 ENDIF
8010C...Sum up tau' cross-section pieces in points used.
8011 ELSEIF(IVAR.EQ.2) THEN
8012 TAU=VINTPT(IACC,11)
8013 TAUP=VINTPT(IACC,16)
8014 TAUPMN=VINTPT(IACC,6)
8015 TAUPMX=VINTPT(IACC,26)
8016 ATAUP1=LOG(TAUPMX/TAUPMN)
8017 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
8018 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
8019 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ATAUP1/ATAUP2)*
8020 & (1D0-TAU/TAUP)**3/TAUP
8021 IF(NBIN.GE.3) THEN
8022 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
8023 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ATAUP1/ATAUP3)*
8024 & TAUP/MAX(2D-10,1D0-TAUP)
8025 ENDIF
8026
8027C...Sum up y* cross-section pieces in points used.
8028 ELSEIF(IVAR.EQ.3) THEN
8029 YST=VINTPT(IACC,12)
8030 YSTMIN=VINTPT(IACC,2)
8031 YSTMAX=VINTPT(IACC,22)
8032 AYST0=YSTMAX-YSTMIN
8033 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
8034 AYST2=AYST1
8035 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
8036 WTMAT(IBIN,1)=WTMAT(IBIN,1)+(AYST0/AYST1)*(YST-YSTMIN)
8037 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(AYST0/AYST2)*(YSTMAX-YST)
8038 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(AYST0/AYST3)/COSH(YST)
8039 IF(MINT(45).EQ.3) THEN
8040 TAUE=VINTPT(IACC,11)
8041 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
8042 YST0=-0.5D0*LOG(TAUE)
8043 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
8044 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
8045 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(AYST0/AYST4)/
8046 & MAX(1D-10,1D0-EXP(YST-YST0))
8047 ENDIF
8048 IF(MINT(46).EQ.3) THEN
8049 TAUE=VINTPT(IACC,11)
8050 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINTPT(IACC,16)
8051 YST0=-0.5D0*LOG(TAUE)
8052 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
8053 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
8054 WTMAT(IBIN,NBIN)=WTMAT(IBIN,NBIN)+(AYST0/AYST5)/
8055 & MAX(1D-10,1D0-EXP(-YST-YST0))
8056 ENDIF
8057
8058C...Sum up cos(theta-hat) cross-section pieces in points used.
8059 ELSE
8060 RM34=MAX(1D-20,2D0*SQM3*SQM4/(VINTPT(IACC,11)*VINT(2))**2)
8061 RSQM=1D0+RM34
8062 CTHMAX=SQRT(1D0-4D0*VINT(71)**2/(TAUMAX*VINT(2)))
8063 CTHMIN=-CTHMAX
8064 IF(CTHMAX.GT.0.9999D0) RM34=MAX(RM34,2D0*VINT(71)**2/
8065 & (TAUMAX*VINT(2)))
8066 ACTH1=CTHMAX-CTHMIN
8067 ACTH2=LOG(MAX(RM34,RSQM-CTHMIN)/MAX(RM34,RSQM-CTHMAX))
8068 ACTH3=LOG(MAX(RM34,RSQM+CTHMAX)/MAX(RM34,RSQM+CTHMIN))
8069 ACTH4=1D0/MAX(RM34,RSQM-CTHMAX)-1D0/MAX(RM34,RSQM-CTHMIN)
8070 ACTH5=1D0/MAX(RM34,RSQM+CTHMIN)-1D0/MAX(RM34,RSQM+CTHMAX)
8071 CTH=VINTPT(IACC,13)
8072 WTMAT(IBIN,1)=WTMAT(IBIN,1)+1D0
8073 WTMAT(IBIN,2)=WTMAT(IBIN,2)+(ACTH1/ACTH2)/
8074 & MAX(RM34,RSQM-CTH)
8075 WTMAT(IBIN,3)=WTMAT(IBIN,3)+(ACTH1/ACTH3)/
8076 & MAX(RM34,RSQM+CTH)
8077 WTMAT(IBIN,4)=WTMAT(IBIN,4)+(ACTH1/ACTH4)/
8078 & MAX(RM34,RSQM-CTH)**2
8079 WTMAT(IBIN,5)=WTMAT(IBIN,5)+(ACTH1/ACTH5)/
8080 & MAX(RM34,RSQM+CTH)**2
8081 ENDIF
8082 180 CONTINUE
8083
8084C...Check that equation system solvable.
8085 IF(MSTP(122).GE.2) WRITE(MSTU(11),5400) CVAR(IVAR)
8086 MSOLV=1
8087 WTRELS=0D0
8088 DO 190 IBIN=1,NBIN
8089 IF(MSTP(122).GE.2) WRITE(MSTU(11),5500) (WTMAT(IBIN,IRED),
8090 & IRED=1,NBIN),WTREL(IBIN)
8091 IF(NAREL(IBIN).EQ.0) MSOLV=0
8092 WTRELS=WTRELS+WTREL(IBIN)
8093 190 CONTINUE
8094 IF(ABS(WTRELS).LT.1D-20) MSOLV=0
8095
8096C...Solve to find relative importance of cross-section pieces.
8097 IF(MSOLV.EQ.1) THEN
8098 DO 200 IBIN=1,NBIN
8099 WTRELN(IBIN)=MAX(0.1D0,WTREL(IBIN)/WTRELS)
8100 WTRSAV(IBIN)=WTREL(IBIN)
8101 200 CONTINUE
8102C...Auxiliary vectors to record order of permutations
8103 DO I=1,NBIN
8104 IP(I) = I
8105 IQ(I) = I
8106 ENDDO
8107 DO 230 IRED=1,NBIN-1
8108 MROW=IRED
8109 RESMAX=ABS(WTREL(MROW))
8110C...Find row with largest residual
8111 DO JBIN=IRED+1,NBIN
8112 IF(RESMAX.LT.ABS(WTREL(JBIN))) THEN
8113 MROW=JBIN
8114 RESMAX=ABS(WTREL(MROW))
8115 ENDIF
8116 ENDDO
8117 IF(RESMAX.LT.1D-20) THEN
8118 MSOLV=0
8119 GOTO 260
8120 ENDIF
8121 MCOL = IRED
8122 AMAX = ABS(WTMAT(MROW,MCOL))
8123C...Find column with largest entry
8124 DO JBIN=IRED+1,NBIN
8125 IF (AMAX.LT.ABS(WTMAT(MROW,JBIN))) THEN
8126 MCOL = JBIN
8127 AMAX = ABS(WTMAT(MROW,MCOL))
8128 ENDIF
8129 ENDDO
8130C...Swap rows if necessary
8131 IF(MROW.NE.IRED) THEN
8132 DO JBIN=1,NBIN
8133 TMPE=WTMAT(IRED,JBIN)
8134 WTMAT(IRED,JBIN)=WTMAT(MROW,JBIN)
8135 WTMAT(MROW,JBIN)=TMPE
8136 ENDDO
8137 TMPE=WTREL(IRED)
8138 WTREL(IRED)=WTREL(MROW)
8139 WTREL(MROW)=TMPE
8140 MTMP=IQ(IRED)
8141 IQ(IRED)=IQ(MROW)
8142 IQ(MROW)=MTMP
8143 ENDIF
8144C...Swap columns if necessary
8145 IF(MCOL.NE.IRED) THEN
8146 DO JBIN=1,NBIN
8147 TMPE=WTMAT(JBIN,IRED)
8148 WTMAT(JBIN,IRED)=WTMAT(JBIN,MCOL)
8149 WTMAT(JBIN,MCOL)=TMPE
8150 ENDDO
8151 MTMP=IP(IRED)
8152 IP(IRED)=IP(MCOL)
8153 IP(MCOL)=MTMP
8154 ENDIF
8155C...Begin eliminating equations
8156 DO 220 IBIN=IRED+1,NBIN
8157 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8158 MSOLV=0
8159 GOTO 260
8160 ENDIF
8161C RQT=WTMAT(IBIN,IRED)/WTMAT(IRED,IRED)
8162 RQTU=WTMAT(IBIN,IRED)
8163 RQTL=WTMAT(IRED,IRED)
8164C...Switch order of operations
8165 WTREL(IBIN)=WTREL(IBIN)-RQTU*
8166 $ (WTREL(IRED)/RQTL)
8167 DO 210 ICOE=IRED,NBIN
8168 WTMAT(IBIN,ICOE)=WTMAT(IBIN,ICOE)-
8169 $ RQTU*(WTMAT(IRED,ICOE)/RQTL)
8170 210 CONTINUE
8171 220 CONTINUE
8172 230 CONTINUE
8173 DO 250 IRED=NBIN,1,-1
8174 DO 240 ICOE=IRED+1,NBIN
8175 WTREL(IRED)=WTREL(IRED)-WTMAT(IRED,ICOE)*COEFU(ICOE)
8176 240 CONTINUE
8177 IF(ABS(WTMAT(IRED,IRED)).LT.1D-20) THEN
8178 MSOLV=0
8179 GOTO 260
8180 ENDIF
8181 COEFU(IRED)=WTREL(IRED)/WTMAT(IRED,IRED)
8182 TEMPC(IRED)=COEFU(IRED)
8183 250 CONTINUE
8184C...Return to original order
8185 DO IBIN=1,NBIN
8186 MTMP=IP(IBIN)
8187 COEFU(MTMP)=TEMPC(IBIN)
8188 ENDDO
8189 ENDIF
8190
8191C...Share evenly if failure.
8192 260 IF(MSOLV.EQ.0) THEN
8193 DO 270 IBIN=1,NBIN
8194 COEFU(IBIN)=1D0
8195 WTRELN(IBIN)=0.1D0
8196 IF(WTRELS.GT.0D0) WTRELN(IBIN)=MAX(0.1D0,
8197 & WTRSAV(IBIN)/WTRELS)
8198 270 CONTINUE
8199 ENDIF
8200
8201C...Normalize coefficients, with piece shared democratically.
8202 COEFSU=0D0
8203 WTRELS=0D0
8204 DO 280 IBIN=1,NBIN
8205 COEFU(IBIN)=MAX(0D0,COEFU(IBIN))
8206 COEFSU=COEFSU+COEFU(IBIN)
8207 WTRELS=WTRELS+WTRELN(IBIN)
8208 280 CONTINUE
8209 IF(COEFSU.GT.0D0) THEN
8210 DO 290 IBIN=1,NBIN
8211 COEFO(IBIN)=PARP(122)/NBIN+(1D0-PARP(122))*0.5D0*
8212 & (COEFU(IBIN)/COEFSU+WTRELN(IBIN)/WTRELS)
8213 290 CONTINUE
8214 ELSE
8215 DO 300 IBIN=1,NBIN
8216 COEFO(IBIN)=1D0/NBIN
8217 300 CONTINUE
8218 ENDIF
8219 IF(IVAR.EQ.1) IOFF=0
8220 IF(IVAR.EQ.2) IOFF=17
8221 IF(IVAR.EQ.3) IOFF=7
8222 IF(IVAR.EQ.4) IOFF=12
8223 DO 310 IBIN=1,NBIN
8224 ICOF=IOFF+IBIN
8225 IF(IVAR.EQ.1) THEN
8226 IF(IBIN.EQ.NBIN.AND.(MINT(72).LE.2.AND.IPEAK7.EQ.1)) THEN
8227 ICOF=7
8228 ENDIF
8229 ENDIF
8230 IF(IVAR.EQ.3.AND.IBIN.EQ.4.AND.MINT(45).NE.3) ICOF=ICOF+1
8231 IF(IVAR.EQ.1.AND.IBIN.GE.7+IPEAK7.AND.MINT(72).EQ.3) THEN
8232 COEFX(ISUB,IBIN-6-IPEAK7)=COEFO(IBIN)
8233 ELSE
8234 COEF(ISUB,ICOF)=COEFO(IBIN)
8235 ENDIF
8236 310 CONTINUE
8237
8238 IF(MSTP(122).GE.2) WRITE(MSTU(11),5600) CVAR(IVAR),
8239 & (COEFO(IBIN),IBIN=1,NBIN)
8240
8241 320 CONTINUE
8242
8243C...Find two most promising maxima among points previously determined.
8244 DO 330 J=1,4
8245 IACCMX(J)=0
8246 SIGSMX(J)=0D0
8247 330 CONTINUE
8248 NMAX=0
8249 DO 390 IACC=1,NACC
8250 DO 340 J=1,30
8251 VINT(10+J)=VINTPT(IACC,J)
8252 340 CONTINUE
8253 IF(ISTSB.NE.5) THEN
8254 CALL PYSIGH(NCHN,SIGS)
8255 IF(MWTXS.EQ.1) THEN
8256 CALL PYEVWT(WTXS)
8257 SIGS=WTXS*SIGS
8258 ENDIF
8259 ELSE
8260 SIGS=0D0
8261 DO 350 IKIN3=1,MSTP(129)
8262 CALL PYKMAP(5,0,0D0)
8263 IF(MINT(51).EQ.1) GOTO 350
8264 CALL PYSIGH(NCHN,SIGTMP)
8265 IF(MWTXS.EQ.1) THEN
8266 CALL PYEVWT(WTXS)
8267 SIGTMP=WTXS*SIGTMP
8268 ENDIF
8269 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8270 350 CONTINUE
8271 ENDIF
8272 IEQ=0
8273 DO 360 IMV=1,NMAX
8274 IF(ABS(SIGS-SIGSMX(IMV)).LT.1D-4*(SIGS+SIGSMX(IMV))) IEQ=IMV
8275 360 CONTINUE
8276 IF(IEQ.EQ.0) THEN
8277 DO 370 IMV=NMAX,1,-1
8278 IIN=IMV+1
8279 IF(SIGS.LE.SIGSMX(IMV)) GOTO 380
8280 IACCMX(IMV+1)=IACCMX(IMV)
8281 SIGSMX(IMV+1)=SIGSMX(IMV)
8282 370 CONTINUE
8283 IIN=1
8284 380 IACCMX(IIN)=IACC
8285 SIGSMX(IIN)=SIGS
8286 IF(NMAX.LE.1) NMAX=NMAX+1
8287 ENDIF
8288 390 CONTINUE
8289
8290C...Read out starting position for search.
8291 IF(MSTP(122).GE.2) WRITE(MSTU(11),5700)
8292 SIGSAM=SIGSMX(1)
8293 DO 440 IMAX=1,NMAX
8294 IACC=IACCMX(IMAX)
8295 MTAU=MVARPT(IACC,1)
8296 MTAUP=MVARPT(IACC,2)
8297 MYST=MVARPT(IACC,3)
8298 MCTH=MVARPT(IACC,4)
8299 VTAU=0.5D0
8300 VYST=0.5D0
8301 VCTH=0.5D0
8302 VTAUP=0.5D0
8303
8304C...Starting point and step size in parameter space.
8305 DO 430 IRPT=1,2
8306 DO 420 IVAR=1,4
8307 IF(NPTS(IVAR).EQ.1) GOTO 420
8308 IF(IVAR.EQ.1) VVAR=VTAU
8309 IF(IVAR.EQ.2) VVAR=VTAUP
8310 IF(IVAR.EQ.3) VVAR=VYST
8311 IF(IVAR.EQ.4) VVAR=VCTH
8312 IF(IVAR.EQ.1) MVAR=MTAU
8313 IF(IVAR.EQ.2) MVAR=MTAUP
8314 IF(IVAR.EQ.3) MVAR=MYST
8315 IF(IVAR.EQ.4) MVAR=MCTH
8316 IF(IRPT.EQ.1) VDEL=0.1D0
8317 IF(IRPT.EQ.2) VDEL=MAX(0.01D0,MIN(0.05D0,VVAR-0.02D0,
8318 & 0.98D0-VVAR))
8319 IF(IRPT.EQ.1) VMAR=0.02D0
8320 IF(IRPT.EQ.2) VMAR=0.002D0
8321 IMOV0=1
8322 IF(IRPT.EQ.1.AND.IVAR.EQ.1) IMOV0=0
8323 DO 410 IMOV=IMOV0,8
8324
8325C...Define new point in parameter space.
8326 IF(IMOV.EQ.0) THEN
8327 INEW=2
8328 VNEW=VVAR
8329 ELSEIF(IMOV.EQ.1) THEN
8330 INEW=3
8331 VNEW=VVAR+VDEL
8332 ELSEIF(IMOV.EQ.2) THEN
8333 INEW=1
8334 VNEW=VVAR-VDEL
8335 ELSEIF(SIGSSM(3).GE.MAX(SIGSSM(1),SIGSSM(2)).AND.
8336 & VVAR+2D0*VDEL.LT.1D0-VMAR) THEN
8337 VVAR=VVAR+VDEL
8338 SIGSSM(1)=SIGSSM(2)
8339 SIGSSM(2)=SIGSSM(3)
8340 INEW=3
8341 VNEW=VVAR+VDEL
8342 ELSEIF(SIGSSM(1).GE.MAX(SIGSSM(2),SIGSSM(3)).AND.
8343 & VVAR-2D0*VDEL.GT.VMAR) THEN
8344 VVAR=VVAR-VDEL
8345 SIGSSM(3)=SIGSSM(2)
8346 SIGSSM(2)=SIGSSM(1)
8347 INEW=1
8348 VNEW=VVAR-VDEL
8349 ELSEIF(SIGSSM(3).GE.SIGSSM(1)) THEN
8350 VDEL=0.5D0*VDEL
8351 VVAR=VVAR+VDEL
8352 SIGSSM(1)=SIGSSM(2)
8353 INEW=2
8354 VNEW=VVAR
8355 ELSE
8356 VDEL=0.5D0*VDEL
8357 VVAR=VVAR-VDEL
8358 SIGSSM(3)=SIGSSM(2)
8359 INEW=2
8360 VNEW=VVAR
8361 ENDIF
8362
8363C...Convert to relevant variables and find derived new limits.
8364 ILERR=0
8365 IF(IVAR.EQ.1) THEN
8366 VTAU=VNEW
8367 CALL PYKMAP(1,MTAU,VTAU)
8368 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
8369 CALL PYKLIM(4)
8370 IF(MINT(51).EQ.1) ILERR=1
8371 ENDIF
8372 ENDIF
8373 IF(IVAR.LE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5.AND.
8374 & ILERR.EQ.0) THEN
8375 IF(IVAR.EQ.2) VTAUP=VNEW
8376 CALL PYKMAP(4,MTAUP,VTAUP)
8377 ENDIF
8378 IF(IVAR.LE.2.AND.ILERR.EQ.0) THEN
8379 CALL PYKLIM(2)
8380 IF(MINT(51).EQ.1) ILERR=1
8381 ENDIF
8382 IF(IVAR.LE.3.AND.ILERR.EQ.0) THEN
8383 IF(IVAR.EQ.3) VYST=VNEW
8384 CALL PYKMAP(2,MYST,VYST)
8385 CALL PYKLIM(3)
8386 IF(MINT(51).EQ.1) ILERR=1
8387 ENDIF
8388 IF((ISTSB.EQ.2.OR.ISTSB.EQ.4.OR.ISTSB.EQ.6).AND.
8389 & ILERR.EQ.0) THEN
8390 IF(IVAR.EQ.4) VCTH=VNEW
8391 CALL PYKMAP(3,MCTH,VCTH)
8392 ENDIF
8393 IF(ISUB.EQ.96) VINT(25)=VINT(21)*(1.-VINT(23)**2)
8394
8395C...Evaluate cross-section. Save new maximum. Final maximum.
8396 IF(ILERR.NE.0) THEN
8397 SIGS=0.
8398 ELSEIF(ISTSB.NE.5) THEN
8399 CALL PYSIGH(NCHN,SIGS)
8400 IF(MWTXS.EQ.1) THEN
8401 CALL PYEVWT(WTXS)
8402 SIGS=WTXS*SIGS
8403 ENDIF
8404 ELSE
8405 SIGS=0D0
8406 DO 400 IKIN3=1,MSTP(129)
8407 CALL PYKMAP(5,0,0D0)
8408 IF(MINT(51).EQ.1) GOTO 400
8409 CALL PYSIGH(NCHN,SIGTMP)
8410 IF(MWTXS.EQ.1) THEN
8411 CALL PYEVWT(WTXS)
8412 SIGTMP=WTXS*SIGTMP
8413 ENDIF
8414 IF(SIGTMP.GT.SIGS) SIGS=SIGTMP
8415 400 CONTINUE
8416 ENDIF
8417 SIGSSM(INEW)=SIGS
8418 IF(SIGS.GT.SIGSAM) SIGSAM=SIGS
8419 IF(MSTP(122).GE.2) WRITE(MSTU(11),5800) IMAX,IVAR,MVAR,
8420 & IMOV,VNEW,VINT(21),VINT(22),VINT(23),VINT(26),SIGS
8421 410 CONTINUE
8422 420 CONTINUE
8423 430 CONTINUE
8424 440 CONTINUE
8425 IF(MSTP(121).EQ.1) SIGSAM=PARP(121)*SIGSAM
8426 XSEC(ISUB,1)=1.05D0*SIGSAM
8427C...Add extra headroom for UED
8428 IF(ISUB.GT.310.AND.ISUB.LT.320) XSEC(ISUB,1)=XSEC(ISUB,1)*1.1D0
8429 IF(MINT(141).NE.0.OR.MINT(142).NE.0) XSEC(ISUB,1)=
8430 & WTGAGA*XSEC(ISUB,1)
8431 450 CONTINUE
8432 IF(MSTP(173).EQ.1.AND.ISUB.NE.96) XSEC(ISUB,1)=
8433 & PARP(174)*XSEC(ISUB,1)
8434 IF(ISUB.NE.96) XSEC(0,1)=XSEC(0,1)+XSEC(ISUB,1)
8435 460 CONTINUE
8436 MINT(51)=0
8437
8438C...Print summary table.
8439 IF(MINT(121).EQ.1.AND.NPOSI.EQ.0) THEN
8440 IF(MSTP(127).NE.1) THEN
8441 WRITE(MSTU(11),5900)
8442 CALL PYSTOP(1)
8443 ELSE
8444 WRITE(MSTU(11),6400)
8445 MSTI(53)=1
8446 ENDIF
8447 ENDIF
8448 IF(MSTP(122).GE.1) THEN
8449 WRITE(MSTU(11),6000)
8450 WRITE(MSTU(11),6100)
8451 DO 470 ISUB=1,500
8452 IF(MSUB(ISUB).NE.1.AND.ISUB.NE.96) GOTO 470
8453 IF(ISUB.EQ.96.AND.MINT(50).EQ.0) GOTO 470
8454 IF(ISUB.EQ.96.AND.MSUB(95).NE.1.AND.MOD(MSTP(81),10).LE.0)
8455 & GOTO 470
8456 IF(ISUB.EQ.96.AND.MINT(49).EQ.0.AND.MSTP(131).EQ.0) GOTO 470
8457 IF(MSUB(95).EQ.1.AND.(ISUB.EQ.11.OR.ISUB.EQ.12.OR.ISUB.EQ.13
8458 & .OR.ISUB.EQ.28.OR.ISUB.EQ.53.OR.ISUB.EQ.68)) GOTO 470
8459 IF(MSUB(95).EQ.1.AND.ISUB.GE.381.AND.ISUB.LE.386) GOTO 470
8460 WRITE(MSTU(11),6200) ISUB,PROC(ISUB),XSEC(ISUB,1)
8461 470 CONTINUE
8462 WRITE(MSTU(11),6300)
8463 ENDIF
8464
8465C...Format statements for maximization results.
8466 5000 FORMAT(/1X,'Coefficient optimization and maximum search for ',
8467 &'subprocess no',I4/1X,'Coefficient modes tau',10X,'y*',9X,
8468 &'cth',9X,'tau''',7X,'sigma')
8469 5100 FORMAT(1X,'Warning: requested subprocess ',I3,' has no allowed ',
8470 &'phase space.'/1X,'Process switched off!')
8471 5200 FORMAT(1X,4I4,F12.8,F12.6,F12.7,F12.8,1P,D12.4)
8472 5300 FORMAT(1X,'Warning: requested subprocess ',I3,' has vanishing ',
8473 &'cross-section.'/1X,'Process switched off!')
8474 5400 FORMAT(1X,'Coefficients of equation system to be solved for ',A4)
8475 5500 FORMAT(1X,1P,10D11.3)
8476 5600 FORMAT(1X,'Result for ',A4,':',9F9.4)
8477 5700 FORMAT(1X,'Maximum search for given coefficients'/2X,'MAX VAR ',
8478 &'MOD MOV VNEW',7X,'tau',7X,'y*',8X,'cth',7X,'tau''',7X,'sigma')
8479 5800 FORMAT(1X,4I4,F8.4,F11.7,F9.3,F11.6,F11.7,1P,D12.4)
8480 5900 FORMAT(1X,'Error: no requested process has non-vanishing ',
8481 &'cross-section.'/1X,'Execution stopped!')
8482 6000 FORMAT(/1X,8('*'),1X,'PYMAXI: summary of differential ',
8483 &'cross-section maximum search',1X,8('*'))
8484 6100 FORMAT(/11X,58('=')/11X,'I',38X,'I',17X,'I'/11X,'I ISUB ',
8485 &'Subprocess name',15X,'I Maximum value I'/11X,'I',38X,'I',
8486 &17X,'I'/11X,58('=')/11X,'I',38X,'I',17X,'I')
8487 6200 FORMAT(11X,'I',2X,I3,3X,A28,2X,'I',2X,1P,D12.4,3X,'I')
8488 6300 FORMAT(11X,'I',38X,'I',17X,'I'/11X,58('='))
8489 6400 FORMAT(1X,'Error: no requested process has non-vanishing ',
8490 &'cross-section.'/
8491 &1X,'Execution will stop if you try to generate events.')
8492
8493 RETURN
8494 END
8495
8496C*********************************************************************
8497
8498C...PYPILE
8499C...Initializes multiplicity distribution and selects mutliplicity
8500C...of pileup events, i.e. several events occuring at the same
8501C...beam crossing.
8502
8503 SUBROUTINE PYPILE(MPILE)
8504
8505C...Double precision and integer declarations.
8506 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8507 IMPLICIT INTEGER(I-N)
8508 INTEGER PYK,PYCHGE,PYCOMP
8509C...Commonblocks.
8510 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8511 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8512 COMMON/PYINT1/MINT(400),VINT(400)
8513 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8514 SAVE /PYDAT1/,/PYPARS/,/PYINT1/,/PYINT7/
8515C...Local arrays and saved variables.
8516 DIMENSION WTI(0:200)
8517 SAVE IMIN,IMAX,WTI,WTS
8518
8519C...Sum of allowed cross-sections for pileup events.
8520 IF(MPILE.EQ.1) THEN
8521 VINT(131)=SIGT(0,0,5)
8522 IF(MSTP(132).GE.2) VINT(131)=VINT(131)+SIGT(0,0,4)
8523 IF(MSTP(132).GE.3) VINT(131)=VINT(131)+SIGT(0,0,2)+SIGT(0,0,3)
8524 IF(MSTP(132).GE.4) VINT(131)=VINT(131)+SIGT(0,0,1)
8525 IF(MSTP(133).LE.0) RETURN
8526
8527C...Initialize multiplicity distribution at maximum.
8528 XNAVE=VINT(131)*PARP(131)
8529 IF(XNAVE.GT.120D0) WRITE(MSTU(11),5000) XNAVE
8530 INAVE=MAX(1,MIN(200,NINT(XNAVE)))
8531 WTI(INAVE)=1D0
8532 WTS=WTI(INAVE)
8533 WTN=WTI(INAVE)*INAVE
8534
8535C...Find shape of multiplicity distribution below maximum.
8536 IMIN=INAVE
8537 DO 100 I=INAVE-1,1,-1
8538 IF(MSTP(133).EQ.1) WTI(I)=WTI(I+1)*(I+1)/XNAVE
8539 IF(MSTP(133).GE.2) WTI(I)=WTI(I+1)*I/XNAVE
8540 IF(WTI(I).LT.1D-6) GOTO 110
8541 WTS=WTS+WTI(I)
8542 WTN=WTN+WTI(I)*I
8543 IMIN=I
8544 100 CONTINUE
8545
8546C...Find shape of multiplicity distribution above maximum.
8547 110 IMAX=INAVE
8548 DO 120 I=INAVE+1,200
8549 IF(MSTP(133).EQ.1) WTI(I)=WTI(I-1)*XNAVE/I
8550 IF(MSTP(133).GE.2) WTI(I)=WTI(I-1)*XNAVE/(I-1)
8551 IF(WTI(I).LT.1D-6) GOTO 130
8552 WTS=WTS+WTI(I)
8553 WTN=WTN+WTI(I)*I
8554 IMAX=I
8555 120 CONTINUE
8556 130 VINT(132)=XNAVE
8557 VINT(133)=WTN/WTS
8558 IF(MSTP(133).EQ.1.AND.IMIN.EQ.1) VINT(134)=
8559 & WTS/(WTS+WTI(1)/XNAVE)
8560 IF(MSTP(133).EQ.1.AND.IMIN.GT.1) VINT(134)=1D0
8561 IF(MSTP(133).GE.2) VINT(134)=XNAVE
8562
8563C...Pick multiplicity of pileup events.
8564 ELSE
8565 IF(MSTP(133).LE.0) THEN
8566 MINT(81)=MAX(1,MSTP(134))
8567 ELSE
8568 WTR=WTS*PYR(0)
8569 DO 140 I=IMIN,IMAX
8570 MINT(81)=I
8571 WTR=WTR-WTI(I)
8572 IF(WTR.LE.0D0) GOTO 150
8573 140 CONTINUE
8574 150 CONTINUE
8575 ENDIF
8576 ENDIF
8577
8578C...Format statement for error message.
8579 5000 FORMAT(1X,'Warning: requested average number of events per bunch',
8580 &'crossing too large, ',1P,D12.4)
8581
8582 RETURN
8583 END
8584
8585C*********************************************************************
8586
8587C...PYSAVE
8588C...Saves and restores parameter and cross section values for the
8589C...3 gamma-p and 6 (or 4, or 9, or 13) gamma-gamma alternatives.
8590C...Also makes random choice between alternatives.
8591
8592 SUBROUTINE PYSAVE(ISAVE,IGA)
8593
8594C...Double precision and integer declarations.
8595 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8596 IMPLICIT INTEGER(I-N)
8597 INTEGER PYK,PYCHGE,PYCOMP
8598C...Commonblocks.
8599 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8600 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8601 COMMON/PYINT1/MINT(400),VINT(400)
8602 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
8603 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8604 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
8605 SAVE /PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT5/,/PYINT7/
8606C...Local arrays and saved variables.
8607 DIMENSION NCP(15),NSUBCP(15,20),MSUBCP(15,20),COEFCP(15,20,20),
8608 &NGENCP(15,0:20,3),XSECCP(15,0:20,3),SIGTCP(15,0:6,0:6,0:5),
8609 &INTCP(15,20),RECP(15,20)
8610 SAVE NCP,NSUBCP,MSUBCP,COEFCP,NGENCP,XSECCP,SIGTCP,INTCP,RECP
8611
8612C...Save list of subprocesses and cross-section information.
8613 IF(ISAVE.EQ.1) THEN
8614 ICP=0
8615 DO 120 I=1,500
8616 IF(MSUB(I).EQ.0.AND.I.NE.96.AND.I.NE.97) GOTO 120
8617 ICP=ICP+1
8618 NSUBCP(IGA,ICP)=I
8619 MSUBCP(IGA,ICP)=MSUB(I)
8620 DO 100 J=1,20
8621 COEFCP(IGA,ICP,J)=COEF(I,J)
8622 100 CONTINUE
8623 DO 110 J=1,3
8624 NGENCP(IGA,ICP,J)=NGEN(I,J)
8625 XSECCP(IGA,ICP,J)=XSEC(I,J)
8626 110 CONTINUE
8627 120 CONTINUE
8628 NCP(IGA)=ICP
8629 DO 130 J=1,3
8630 NGENCP(IGA,0,J)=NGEN(0,J)
8631 XSECCP(IGA,0,J)=XSEC(0,J)
8632 130 CONTINUE
8633 DO 160 I1=0,6
8634 DO 150 I2=0,6
8635 DO 140 J=0,5
8636 SIGTCP(IGA,I1,I2,J)=SIGT(I1,I2,J)
8637 140 CONTINUE
8638 150 CONTINUE
8639 160 CONTINUE
8640
8641C...Save various common process variables.
8642 DO 170 J=1,10
8643 INTCP(IGA,J)=MINT(40+J)
8644 170 CONTINUE
8645 INTCP(IGA,11)=MINT(101)
8646 INTCP(IGA,12)=MINT(102)
8647 INTCP(IGA,13)=MINT(107)
8648 INTCP(IGA,14)=MINT(108)
8649 INTCP(IGA,15)=MINT(123)
8650 RECP(IGA,1)=CKIN(3)
8651 RECP(IGA,2)=VINT(318)
8652
8653C...Save cross-section information only.
8654 ELSEIF(ISAVE.EQ.2) THEN
8655 DO 190 ICP=1,NCP(IGA)
8656 I=NSUBCP(IGA,ICP)
8657 DO 180 J=1,3
8658 NGENCP(IGA,ICP,J)=NGEN(I,J)
8659 XSECCP(IGA,ICP,J)=XSEC(I,J)
8660 180 CONTINUE
8661 190 CONTINUE
8662 DO 200 J=1,3
8663 NGENCP(IGA,0,J)=NGEN(0,J)
8664 XSECCP(IGA,0,J)=XSEC(0,J)
8665 200 CONTINUE
8666
8667C...Choose between allowed alternatives.
8668 ELSEIF(ISAVE.EQ.3.OR.ISAVE.EQ.4) THEN
8669 IF(ISAVE.EQ.4) THEN
8670 XSUMCP=0D0
8671 DO 210 IG=1,MINT(121)
8672 XSUMCP=XSUMCP+XSECCP(IG,0,1)
8673 210 CONTINUE
8674 XSUMCP=XSUMCP*PYR(0)
8675 DO 220 IG=1,MINT(121)
8676 IGA=IG
8677 XSUMCP=XSUMCP-XSECCP(IG,0,1)
8678 IF(XSUMCP.LE.0D0) GOTO 230
8679 220 CONTINUE
8680 230 CONTINUE
8681 ENDIF
8682
8683C...Restore cross-section information.
8684 DO 240 I=1,500
8685 MSUB(I)=0
8686 240 CONTINUE
8687 DO 270 ICP=1,NCP(IGA)
8688 I=NSUBCP(IGA,ICP)
8689 MSUB(I)=MSUBCP(IGA,ICP)
8690 DO 250 J=1,20
8691 COEF(I,J)=COEFCP(IGA,ICP,J)
8692 250 CONTINUE
8693 DO 260 J=1,3
8694 NGEN(I,J)=NGENCP(IGA,ICP,J)
8695 XSEC(I,J)=XSECCP(IGA,ICP,J)
8696 260 CONTINUE
8697 270 CONTINUE
8698 DO 280 J=1,3
8699 NGEN(0,J)=NGENCP(IGA,0,J)
8700 XSEC(0,J)=XSECCP(IGA,0,J)
8701 280 CONTINUE
8702 DO 310 I1=0,6
8703 DO 300 I2=0,6
8704 DO 290 J=0,5
8705 SIGT(I1,I2,J)=SIGTCP(IGA,I1,I2,J)
8706 290 CONTINUE
8707 300 CONTINUE
8708 310 CONTINUE
8709
8710C...Restore various common process variables.
8711 DO 320 J=1,10
8712 MINT(40+J)=INTCP(IGA,J)
8713 320 CONTINUE
8714 MINT(101)=INTCP(IGA,11)
8715 MINT(102)=INTCP(IGA,12)
8716 MINT(107)=INTCP(IGA,13)
8717 MINT(108)=INTCP(IGA,14)
8718 MINT(123)=INTCP(IGA,15)
8719 CKIN(3)=RECP(IGA,1)
8720 CKIN(1)=2D0*CKIN(3)
8721 VINT(318)=RECP(IGA,2)
8722
8723C...Sum up cross-section info (for PYSTAT).
8724 ELSEIF(ISAVE.EQ.5) THEN
8725 DO 330 I=1,500
8726 MSUB(I)=0
8727 NGEN(I,1)=0
8728 NGEN(I,3)=0
8729 XSEC(I,3)=0D0
8730 330 CONTINUE
8731 NGEN(0,1)=0
8732 NGEN(0,2)=0
8733 NGEN(0,3)=0
8734 XSEC(0,3)=0
8735 DO 350 IG=1,MINT(121)
8736 DO 340 ICP=1,NCP(IG)
8737 I=NSUBCP(IG,ICP)
8738 IF(MSUBCP(IG,ICP).EQ.1) MSUB(I)=1
8739 NGEN(I,1)=NGEN(I,1)+NGENCP(IG,ICP,1)
8740 NGEN(I,3)=NGEN(I,3)+NGENCP(IG,ICP,3)
8741 XSEC(I,3)=XSEC(I,3)+XSECCP(IG,ICP,3)
8742 340 CONTINUE
8743 NGEN(0,1)=NGEN(0,1)+NGENCP(IG,0,1)
8744 NGEN(0,2)=NGEN(0,2)+NGENCP(IG,0,2)
8745 NGEN(0,3)=NGEN(0,3)+NGENCP(IG,0,3)
8746 XSEC(0,3)=XSEC(0,3)+XSECCP(IG,0,3)
8747 350 CONTINUE
8748 ENDIF
8749
8750 RETURN
8751 END
8752
8753C*********************************************************************
8754
8755C...PYGAGA
8756C...For lepton beams it gives photon-hadron or photon-photon systems
8757C...to be treated with the ordinary machinery and combines this with a
8758C...description of the lepton -> lepton + photon branching.
8759
8760 SUBROUTINE PYGAGA(IGAGA,WTGAGA)
8761
8762C...Double precision and integer declarations.
8763 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
8764 IMPLICIT INTEGER(I-N)
8765 INTEGER PYK,PYCHGE,PYCOMP
8766C...Commonblocks.
8767 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
8768 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
8769 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
8770 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
8771 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
8772 COMMON/PYINT1/MINT(400),VINT(400)
8773 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
8774 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
8775 &/PYINT5/
8776C...Local variables and data statement.
8777 DIMENSION PMS(2),XMIN(2),XMAX(2),Q2MIN(2),Q2MAX(2),PMC(3),
8778 &X(2),Q2(2),Y(2),THETA(2),PHI(2),PT(2),BETA(3)
8779 SAVE PMS,XMIN,XMAX,Q2MIN,Q2MAX,PMC,X,Q2,THETA,PHI,PT,W2MIN
8780 DATA EPS/1D-4/
8781
8782C...Initialize generation of photons inside leptons.
8783 IF(IGAGA.EQ.1) THEN
8784
8785C...Save quantities on incoming lepton system.
8786 VINT(301)=VINT(1)
8787 VINT(302)=VINT(2)
8788 PMS(1)=VINT(303)**2
8789 IF(MINT(141).EQ.0) PMS(1)=SIGN(VINT(3)**2,VINT(3))
8790 PMS(2)=VINT(304)**2
8791 IF(MINT(142).EQ.0) PMS(2)=SIGN(VINT(4)**2,VINT(4))
8792 PMC(3)=VINT(302)-PMS(1)-PMS(2)
8793 W2MIN=MAX(CKIN(77),2D0*CKIN(3),2D0*CKIN(5))**2
8794
8795C...Calculate range of x and Q2 values allowed in generation.
8796 DO 100 I=1,2
8797 PMC(I)=VINT(302)+PMS(I)-PMS(3-I)
8798 IF(MINT(140+I).NE.0) THEN
8799 XMIN(I)=MAX(CKIN(59+2*I),EPS)
8800 XMAX(I)=MIN(CKIN(60+2*I),1D0-2D0*VINT(301)*SQRT(PMS(I))/
8801 & PMC(I),1D0-EPS)
8802 YMIN=MAX(CKIN(71+2*I),EPS)
8803 YMAX=MIN(CKIN(72+2*I),1D0-EPS)
8804 IF(CKIN(64+2*I).GT.0D0) XMIN(I)=MAX(XMIN(I),
8805 & (YMIN*PMC(3)-CKIN(64+2*I))/PMC(I))
8806 XMAX(I)=MIN(XMAX(I),(YMAX*PMC(3)-CKIN(63+2*I))/PMC(I))
8807 THEMIN=MAX(CKIN(67+2*I),0D0)
8808 THEMAX=MIN(CKIN(68+2*I),PARU(1))
8809 IF(CKIN(68+2*I).LT.0D0) THEMAX=PARU(1)
8810 Q2MIN(I)=MAX(CKIN(63+2*I),XMIN(I)**2*PMS(I)/(1D0-XMIN(I))+
8811 & ((1D0-XMAX(I))*(VINT(302)-2D0*PMS(3-I))-
8812 & 2D0*PMS(I)/(1D0-XMAX(I)))*SIN(THEMIN/2D0)**2,0D0)
8813 Q2MAX(I)=XMAX(I)**2*PMS(I)/(1D0-XMAX(I))+
8814 & ((1D0-XMIN(I))*(VINT(302)-2D0*PMS(3-I))-
8815 & 2D0*PMS(I)/(1D0-XMIN(I)))*SIN(THEMAX/2D0)**2
8816 IF(CKIN(64+2*I).GT.0D0) Q2MAX(I)=MIN(CKIN(64+2*I),Q2MAX(I))
8817C...W limits when lepton on one side only.
8818 IF(MINT(143-I).EQ.0) THEN
8819 XMIN(I)=MAX(XMIN(I),(W2MIN-PMS(3-I))/PMC(I))
8820 IF(CKIN(78).GT.0D0) XMAX(I)=MIN(XMAX(I),
8821 & (CKIN(78)**2-PMS(3-I))/PMC(I))
8822 ENDIF
8823 ENDIF
8824 100 CONTINUE
8825
8826C...W limits when lepton on both sides.
8827 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8828 IF(CKIN(78).GT.0D0) XMAX(1)=MIN(XMAX(1),
8829 & (CKIN(78)**2+PMC(3)-PMC(2)*XMIN(2))/PMC(1))
8830 IF(CKIN(78).GT.0D0) XMAX(2)=MIN(XMAX(2),
8831 & (CKIN(78)**2+PMC(3)-PMC(1)*XMIN(1))/PMC(2))
8832 IF(IABS(MINT(141)).NE.IABS(MINT(142))) THEN
8833 XMIN(1)=MAX(XMIN(1),(PMS(1)-PMS(2)+VINT(302)*(W2MIN-
8834 & PMS(1)-PMS(2))/(PMC(2)*XMAX(2)+PMS(1)-PMS(2)))/PMC(1))
8835 XMIN(2)=MAX(XMIN(2),(PMS(2)-PMS(1)+VINT(302)*(W2MIN-
8836 & PMS(1)-PMS(2))/(PMC(1)*XMAX(1)+PMS(2)-PMS(1)))/PMC(2))
8837 ELSE
8838 XMIN(1)=MAX(XMIN(1),W2MIN/(VINT(302)*XMAX(2)))
8839 XMIN(2)=MAX(XMIN(2),W2MIN/(VINT(302)*XMAX(1)))
8840 ENDIF
8841 ENDIF
8842
8843C...Q2 and W values and photon flux weight factors for initialization.
8844 ELSEIF(IGAGA.EQ.2) THEN
8845 ISUB=MINT(1)
8846 MINT(15)=0
8847 MINT(16)=0
8848
8849C...W value for photon on one or both sides, and for processes
8850C...with gamma-gamma cross section peaked at small shat.
8851 IF(MINT(141).NE.0.AND.MINT(142).EQ.0) THEN
8852 VINT(2)=VINT(302)+PMS(1)-PMC(1)*(1D0-XMAX(1))
8853 ELSEIF(MINT(141).EQ.0.AND.MINT(142).NE.0) THEN
8854 VINT(2)=VINT(302)+PMS(2)-PMC(2)*(1D0-XMAX(2))
8855 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
8856 VINT(2)=MAX(CKIN(77)**2,12D0*MAX(CKIN(3),CKIN(5))**2)
8857 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8858 ELSE
8859 VINT(2)=XMAX(1)*XMAX(2)*VINT(302)
8860 IF(CKIN(78).GT.0D0) VINT(2)=MIN(VINT(2),CKIN(78)**2)
8861 ENDIF
8862 VINT(1)=SQRT(MAX(0D0,VINT(2)))
8863
8864C...Upper estimate of photon flux weight factor.
8865C...Initialization Q2 scale. Flag incoming unresolved photon.
8866 WTGAGA=1D0
8867 DO 110 I=1,2
8868 IF(MINT(140+I).NE.0) THEN
8869 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8870 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8871 IF(ISUB.EQ.99.AND.MINT(106+I).EQ.4.AND.MINT(109-I).EQ.3)
8872 & THEN
8873 Q2INIT=5D0+Q2MIN(3-I)
8874 ELSEIF(ISUB.EQ.99.AND.MINT(106+I).EQ.4) THEN
8875 Q2INIT=PMAS(PYCOMP(113),1)**2+Q2MIN(3-I)
8876 ELSEIF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
8877 Q2INIT=MAX(CKIN(1),2D0*CKIN(3),2D0*CKIN(5))**2/3D0
8878 ELSEIF((ISUB.EQ.138.AND.I.EQ.2).OR.
8879 & (ISUB.EQ.139.AND.I.EQ.1)) THEN
8880 Q2INIT=VINT(2)/3D0
8881 ELSEIF(ISUB.EQ.140) THEN
8882 Q2INIT=VINT(2)/2D0
8883 ELSE
8884 Q2INIT=Q2MIN(I)
8885 ENDIF
8886 VINT(2+I)=-SQRT(MAX(Q2MIN(I),MIN(Q2MAX(I),Q2INIT)))
8887 IF(MSTP(14).EQ.0.OR.(ISUB.GE.131.AND.ISUB.LE.140))
8888 & MINT(14+I)=22
8889 VINT(306+I)=VINT(2+I)**2
8890 ENDIF
8891 110 CONTINUE
8892 VINT(320)=WTGAGA
8893
8894C...Update pTmin and cross section information.
8895 IF(MSTP(82).LE.1) THEN
8896 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
8897 ELSE
8898 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
8899 ENDIF
8900 VINT(149)=4D0*PTMN**2/VINT(2)
8901 VINT(154)=PTMN
8902 CALL PYXTOT
8903 VINT(318)=VINT(317)
8904
8905C...Generate photons inside leptons and
8906C...calculate photon flux weight factors.
8907 ELSEIF(IGAGA.EQ.3) THEN
8908 ISUB=MINT(1)
8909 MINT(15)=0
8910 MINT(16)=0
8911
8912C...Generate phase space point and check against cuts.
8913 LOOP=0
8914 120 LOOP=LOOP+1
8915 DO 130 I=1,2
8916 IF(MINT(140+I).NE.0) THEN
8917C...Pick x and Q2
8918 X(I)=XMIN(I)*(XMAX(I)/XMIN(I))**PYR(0)
8919 Q2(I)=Q2MIN(I)*(Q2MAX(I)/Q2MIN(I))**PYR(0)
8920C...Cuts on internal consistency in x and Q2.
8921 IF(Q2(I).LT.X(I)**2*PMS(I)/(1D0-X(I))) GOTO 120
8922 IF(Q2(I).GT.(1D0-X(I))*(VINT(302)-2D0*PMS(3-I))-
8923 & (2D0-X(I)**2)*PMS(I)/(1D0-X(I))) GOTO 120
8924C...Cuts on y and theta.
8925 Y(I)=(PMC(I)*X(I)+Q2(I))/PMC(3)
8926 IF(Y(I).LT.CKIN(71+2*I).OR.Y(I).GT.CKIN(72+2*I)) GOTO 120
8927 RAT=((1D0-X(I))*Q2(I)-X(I)**2*PMS(I))/
8928 & ((1D0-X(I))**2*(VINT(302)-2D0*PMS(3-I)-2D0*PMS(I)))
8929 THETA(I)=2D0*ASIN(SQRT(MAX(0D0,MIN(1D0,RAT))))
8930 IF(THETA(I).LT.CKIN(67+2*I)) GOTO 120
8931 IF(CKIN(68+2*I).GT.0D0.AND.THETA(I).GT.CKIN(68+2*I))
8932 & GOTO 120
8933
8934C...Phi angle isotropic. Reconstruct pT.
8935 PHI(I)=PARU(2)*PYR(0)
8936 PT(I)=SQRT(((1D0-X(I))*PMC(I))**2/(4D0*VINT(302))-
8937 & PMS(I))*SIN(THETA(I))
8938
8939C...Store info on variables selected, for documentation purposes.
8940 VINT(2+I)=-SQRT(Q2(I))
8941 VINT(304+I)=X(I)
8942 VINT(306+I)=Q2(I)
8943 VINT(308+I)=Y(I)
8944 VINT(310+I)=THETA(I)
8945 VINT(312+I)=PHI(I)
8946 ELSE
8947 VINT(304+I)=1D0
8948 VINT(306+I)=0D0
8949 VINT(308+I)=1D0
8950 VINT(310+I)=0D0
8951 VINT(312+I)=0D0
8952 ENDIF
8953 130 CONTINUE
8954
8955C...Cut on W combines info from two sides.
8956 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
8957 W2=-Q2(1)-Q2(2)+0.5D0*X(1)*PMC(1)*X(2)*PMC(2)/VINT(302)-
8958 & 2D0*PT(1)*PT(2)*COS(PHI(1)-PHI(2))+2D0*
8959 & SQRT((0.5D0*X(1)*PMC(1)/VINT(301))**2+Q2(1)-PT(1)**2)*
8960 & SQRT((0.5D0*X(2)*PMC(2)/VINT(301))**2+Q2(2)-PT(2)**2)
8961 IF(W2.LT.W2MIN) GOTO 120
8962 IF(CKIN(78).GT.0D0.AND.W2.GT.CKIN(78)**2) GOTO 120
8963 PMS1=-Q2(1)
8964 PMS2=-Q2(2)
8965 ELSEIF(MINT(141).NE.0) THEN
8966 W2=(VINT(302)+PMS(1))*X(1)+PMS(2)*(1D0-X(1))
8967 PMS1=-Q2(1)
8968 PMS2=PMS(2)
8969 ELSEIF(MINT(142).NE.0) THEN
8970 W2=(VINT(302)+PMS(2))*X(2)+PMS(1)*(1D0-X(2))
8971 PMS1=PMS(1)
8972 PMS2=-Q2(2)
8973 ENDIF
8974
8975C...Store kinematics info for photon(s) in subsystem cm frame.
8976 VINT(2)=W2
8977 VINT(1)=SQRT(W2)
8978 VINT(291)=0D0
8979 VINT(292)=0D0
8980 VINT(293)=0.5D0*SQRT((W2-PMS1-PMS2)**2-4D0*PMS1*PMS2)/VINT(1)
8981 VINT(294)=0.5D0*(W2+PMS1-PMS2)/VINT(1)
8982 VINT(295)=SIGN(SQRT(ABS(PMS1)),PMS1)
8983 VINT(296)=0D0
8984 VINT(297)=0D0
8985 VINT(298)=-VINT(293)
8986 VINT(299)=0.5D0*(W2+PMS2-PMS1)/VINT(1)
8987 VINT(300)=SIGN(SQRT(ABS(PMS2)),PMS2)
8988
8989C...Assign weight for photon flux; different for transverse and
8990C...longitudinal photons. Flag incoming unresolved photon.
8991 WTGAGA=1D0
8992 DO 140 I=1,2
8993 IF(MINT(140+I).NE.0) THEN
8994 WTGAGA=WTGAGA*2D0*(PARU(101)/PARU(2))*
8995 & LOG(XMAX(I)/XMIN(I))*LOG(Q2MAX(I)/Q2MIN(I))
8996 IF(MSTP(16).EQ.0) THEN
8997 XY=X(I)
8998 ELSE
8999 WTGAGA=WTGAGA*X(I)/Y(I)
9000 XY=Y(I)
9001 ENDIF
9002 IF(ISUB.EQ.132.OR.ISUB.EQ.134.OR.ISUB.EQ.136) THEN
9003 WTGAGA=WTGAGA*(1D0-XY)
9004 ELSEIF(I.EQ.1.AND.(ISUB.EQ.139.OR.ISUB.EQ.140)) THEN
9005 WTGAGA=WTGAGA*(1D0-XY)
9006 ELSEIF(I.EQ.2.AND.(ISUB.EQ.138.OR.ISUB.EQ.140)) THEN
9007 WTGAGA=WTGAGA*(1D0-XY)
9008 ELSE
9009 WTGAGA=WTGAGA*(0.5D0*(1D0+(1D0-XY)**2)-
9010 & PMS(I)*XY**2/Q2(I))
9011 ENDIF
9012 IF(MINT(106+I).EQ.0) MINT(14+I)=22
9013 ENDIF
9014 140 CONTINUE
9015 VINT(319)=WTGAGA
9016 MINT(143)=LOOP
9017
9018C...Update pTmin and cross section information.
9019 IF(MSTP(82).LE.1) THEN
9020 PTMN=PARP(81)*(VINT(1)/PARP(89))**PARP(90)
9021 ELSE
9022 PTMN=PARP(82)*(VINT(1)/PARP(89))**PARP(90)
9023 ENDIF
9024 VINT(149)=4D0*PTMN**2/VINT(2)
9025 VINT(154)=PTMN
9026 CALL PYXTOT
9027
9028C...Reconstruct kinematics of photons inside leptons.
9029 ELSEIF(IGAGA.EQ.4) THEN
9030
9031C...Make place for incoming particles and scattered leptons.
9032 MOVE=3
9033 IF(MINT(141).NE.0.AND.MINT(142).NE.0) MOVE=4
9034 MINT(4)=MINT(4)+MOVE
9035 DO 160 I=MINT(84)-MOVE,MINT(83)+1,-1
9036 IF(K(I,1).EQ.21) THEN
9037 DO 150 J=1,5
9038 K(I+MOVE,J)=K(I,J)
9039 P(I+MOVE,J)=P(I,J)
9040 V(I+MOVE,J)=V(I,J)
9041 150 CONTINUE
9042 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
9043 & K(I+MOVE,3)=K(I,3)+MOVE
9044 IF(K(I,4).GT.MINT(83).AND.K(I,4).LE.MINT(84))
9045 & K(I+MOVE,4)=K(I,4)+MOVE
9046 IF(K(I,5).GT.MINT(83).AND.K(I,5).LE.MINT(84))
9047 & K(I+MOVE,5)=K(I,5)+MOVE
9048 ENDIF
9049 160 CONTINUE
9050 DO 170 I=MINT(84)+1,N
9051 IF(K(I,3).GT.MINT(83).AND.K(I,3).LE.MINT(84))
9052 & K(I,3)=K(I,3)+MOVE
9053 170 CONTINUE
9054
9055C...Fill in incoming particles.
9056 DO 190 I=MINT(83)+1,MINT(83)+MOVE
9057 DO 180 J=1,5
9058 K(I,J)=0
9059 P(I,J)=0D0
9060 V(I,J)=0D0
9061 180 CONTINUE
9062 190 CONTINUE
9063 DO 200 I=1,2
9064 K(MINT(83)+I,1)=21
9065 IF(MINT(140+I).NE.0) THEN
9066 K(MINT(83)+I,2)=MINT(140+I)
9067 P(MINT(83)+I,5)=VINT(302+I)
9068 ELSE
9069 K(MINT(83)+I,2)=MINT(10+I)
9070 P(MINT(83)+I,5)=VINT(2+I)
9071 ENDIF
9072 P(MINT(83)+I,3)=0.5D0*SQRT((PMC(3)**2-4D0*PMS(1)*PMS(2))/
9073 & VINT(302))*(-1D0)**(I+1)
9074 P(MINT(83)+I,4)=0.5D0*PMC(I)/VINT(301)
9075 200 CONTINUE
9076
9077C...New mother-daughter relations in documentation section.
9078 IF(MINT(141).NE.0.AND.MINT(142).NE.0) THEN
9079 K(MINT(83)+1,4)=MINT(83)+3
9080 K(MINT(83)+1,5)=MINT(83)+5
9081 K(MINT(83)+2,4)=MINT(83)+4
9082 K(MINT(83)+2,5)=MINT(83)+6
9083 K(MINT(83)+3,3)=MINT(83)+1
9084 K(MINT(83)+5,3)=MINT(83)+1
9085 K(MINT(83)+4,3)=MINT(83)+2
9086 K(MINT(83)+6,3)=MINT(83)+2
9087 ELSEIF(MINT(141).NE.0) THEN
9088 K(MINT(83)+1,4)=MINT(83)+3
9089 K(MINT(83)+1,5)=MINT(83)+4
9090 K(MINT(83)+2,4)=MINT(83)+5
9091 K(MINT(83)+3,3)=MINT(83)+1
9092 K(MINT(83)+4,3)=MINT(83)+1
9093 K(MINT(83)+5,3)=MINT(83)+2
9094 ELSEIF(MINT(142).NE.0) THEN
9095 K(MINT(83)+1,4)=MINT(83)+4
9096 K(MINT(83)+2,4)=MINT(83)+3
9097 K(MINT(83)+2,5)=MINT(83)+5
9098 K(MINT(83)+3,3)=MINT(83)+2
9099 K(MINT(83)+4,3)=MINT(83)+1
9100 K(MINT(83)+5,3)=MINT(83)+2
9101 ENDIF
9102
9103C...Fill scattered lepton(s).
9104 DO 210 I=1,2
9105 IF(MINT(140+I).NE.0) THEN
9106 LSC=MINT(83)+MIN(I+2,MOVE)
9107 K(LSC,1)=21
9108 K(LSC,2)=MINT(140+I)
9109 P(LSC,1)=PT(I)*COS(PHI(I))
9110 P(LSC,2)=PT(I)*SIN(PHI(I))
9111 P(LSC,4)=(1D0-X(I))*P(MINT(83)+I,4)
9112 P(LSC,3)=SQRT(P(LSC,4)**2-PMS(I))*COS(THETA(I))*
9113 & (-1D0)**(I-1)
9114 P(LSC,5)=VINT(302+I)
9115 ENDIF
9116 210 CONTINUE
9117
9118C...Find incoming four-vectors to subprocess.
9119 K(N+1,1)=21
9120 IF(MINT(141).NE.0) THEN
9121 DO 220 J=1,4
9122 P(N+1,J)=P(MINT(83)+1,J)-P(MINT(83)+3,J)
9123 220 CONTINUE
9124 ELSE
9125 DO 230 J=1,4
9126 P(N+1,J)=P(MINT(83)+1,J)
9127 230 CONTINUE
9128 ENDIF
9129 K(N+2,1)=21
9130 IF(MINT(142).NE.0) THEN
9131 DO 240 J=1,4
9132 P(N+2,J)=P(MINT(83)+2,J)-P(MINT(83)+MOVE,J)
9133 240 CONTINUE
9134 ELSE
9135 DO 250 J=1,4
9136 P(N+2,J)=P(MINT(83)+2,J)
9137 250 CONTINUE
9138 ENDIF
9139
9140C...Define boost and rotation between hadronic subsystem and
9141C...collision rest frame; boost hadronic subsystem to this frame.
9142 DO 260 J=1,3
9143 BETA(J)=(P(N+1,J)+P(N+2,J))/(P(N+1,4)+P(N+2,4))
9144 260 CONTINUE
9145 CALL PYROBO(N+1,N+2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
9146 BPHI=PYANGL(P(N+1,1),P(N+1,2))
9147 CALL PYROBO(N+1,N+2,0D0,-BPHI,0D0,0D0,0D0)
9148 BTHETA=PYANGL(P(N+1,3),P(N+1,1))
9149 CALL PYROBO(MINT(83)+MOVE+1,N,BTHETA,BPHI,BETA(1),BETA(2),
9150 & BETA(3))
9151
9152C...Add on scattered leptons to final state.
9153 DO 280 I=1,2
9154 IF(MINT(140+I).NE.0) THEN
9155 LSC=MINT(83)+MIN(I+2,MOVE)
9156 N=N+1
9157 DO 270 J=1,5
9158 K(N,J)=K(LSC,J)
9159 P(N,J)=P(LSC,J)
9160 V(N,J)=V(LSC,J)
9161 270 CONTINUE
9162 K(N,1)=1
9163 K(N,3)=LSC
9164 ENDIF
9165 280 CONTINUE
9166 ENDIF
9167
9168 RETURN
9169 END
9170
9171C*********************************************************************
9172
9173C...PYRAND
9174C...Generates quantities characterizing the high-pT scattering at the
9175C...parton level according to the matrix elements. Chooses incoming,
9176C...reacting partons, their momentum fractions and one of the possible
9177C...subprocesses.
9178
9179 SUBROUTINE PYRAND
9180
9181C...Double precision and integer declarations.
9182 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
9183 IMPLICIT INTEGER(I-N)
9184 INTEGER PYK,PYCHGE,PYCOMP
9185C...Parameter statement to help give large particle numbers.
9186 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
9187 &KEXCIT=4000000,KDIMEN=5000000)
9188
9189C...User process initialization and event commonblocks.
9190 INTEGER MAXPUP
9191 PARAMETER (MAXPUP=100)
9192 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
9193 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
9194 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
9195 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
9196 &LPRUP(MAXPUP)
9197 INTEGER MAXNUP
9198 PARAMETER (MAXNUP=500)
9199 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
9200 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
9201 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
9202 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
9203 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
9204 SAVE /HEPRUP/,/HEPEUP/
9205
9206C...Commonblocks.
9207 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
9208 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
9209 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
9210 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
9211 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
9212 COMMON/PYINT1/MINT(400),VINT(400)
9213 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
9214 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
9215 COMMON/PYINT4/MWID(500),WIDS(500,5)
9216 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
9217 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
9218 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
9219 COMMON/PYTCCO/COEFX(194:380,2)
9220 COMMON/TCPARA/IRES,JRES,XMAS(3),XWID(3),YMAS(2),YWID(2)
9221 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
9222 &/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,/PYMSSM/,/PYTCCO/,
9223 &/TCPARA/
9224C...Local arrays.
9225 DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)
9226
9227C...Parameters and data used in elastic/diffractive treatment.
9228 DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
9229 &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/
9230
9231C...Initial values, specifically for (first) semihard interaction.
9232 MINT(10)=0
9233 MINT(17)=0
9234 MINT(18)=0
9235 VINT(143)=1D0
9236 VINT(144)=1D0
9237 VINT(157)=0D0
9238 VINT(158)=0D0
9239 MFAIL=0
9240 IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
9241 ISUB=0
9242 ISTSB=0
9243 LOOP=0
9244 100 LOOP=LOOP+1
9245 MINT(51)=0
9246 MINT(143)=1
9247 VINT(97)=1D0
9248
9249C...Start by assuming incoming photon is entering subprocess.
9250 IF(MINT(11).EQ.22) THEN
9251 MINT(15)=22
9252 VINT(307)=VINT(3)**2
9253 ENDIF
9254 IF(MINT(12).EQ.22) THEN
9255 MINT(16)=22
9256 VINT(308)=VINT(4)**2
9257 ENDIF
9258 MINT(103)=MINT(11)
9259 MINT(104)=MINT(12)
9260
9261C...Choice of process type - first event of pileup.
9262 INMULT=0
9263 IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
9264 ELSEIF(MINT(82).EQ.1) THEN
9265
9266C...For gamma-p or gamma-gamma first pick between alternatives.
9267 IGA=0
9268 IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
9269 MINT(122)=IGA
9270
9271C...For real gamma + gamma with different nature, flip at random.
9272 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
9273 & MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
9274 MINTSV=MINT(41)
9275 MINT(41)=MINT(42)
9276 MINT(42)=MINTSV
9277 MINTSV=MINT(45)
9278 MINT(45)=MINT(46)
9279 MINT(46)=MINTSV
9280 MINTSV=MINT(107)
9281 MINT(107)=MINT(108)
9282 MINT(108)=MINTSV
9283 IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
9284 ENDIF
9285
9286C...Pick process type, possibly by user process machinery.
9287C...(If the latter, also event will be picked here.)
9288 IF(MINT(111).GE.11.AND.IABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
9289 CALL UPEVNT
9290 CALL PYUPRE
9291 ELSEIF(MINT(111).GE.11.AND.IABS(IDWTUP).GE.3) THEN
9292 CALL UPEVNT
9293 CALL PYUPRE
9294 ISUB=0
9295 110 ISUB=ISUB+1
9296 IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
9297 & ISUB.LT.500) GOTO 110
9298 ELSE
9299 RSUB=XSEC(0,1)*PYR(0)
9300 DO 120 I=1,500
9301 IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
9302 ISUB=I
9303 RSUB=RSUB-XSEC(I,1)
9304 IF(RSUB.LE.0D0) GOTO 130
9305 120 CONTINUE
9306 130 IF(ISUB.EQ.95) ISUB=96
9307 IF(ISUB.EQ.96) INMULT=1
9308 IF(ISET(ISUB).EQ.11) THEN
9309 IDPRUP=KFPR(ISUB,2)
9310 CALL UPEVNT
9311 CALL PYUPRE
9312 ENDIF
9313 ENDIF
9314
9315C...Choice of inclusive process type - pileup events.
9316 ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
9317 RSUB=VINT(131)*PYR(0)
9318 ISUB=96
9319 IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
9320 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
9321 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
9322 IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
9323 & ISUB=91
9324 IF(ISUB.EQ.96) INMULT=1
9325 ENDIF
9326
9327C...Choice of photon energy and flux factor inside lepton.
9328 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
9329 CALL PYGAGA(3,WTGAGA)
9330 IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
9331 CKIN(3)=MAX(VINT(285),VINT(154))
9332 CKIN(1)=2D0*CKIN(3)
9333 ENDIF
9334C...When necessary set direct/resolved photon by hand.
9335 ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
9336 IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
9337 IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
9338 ENDIF
9339
9340C...Restrict direct*resolved processes to pTmin >= Q,
9341C...to avoid doublecounting with DIS.
9342 IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
9343 IF(MINT(15).EQ.22) THEN
9344 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
9345 ELSE
9346 CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
9347 ENDIF
9348 CKIN(1)=2D0*CKIN(3)
9349 ENDIF
9350
9351C...Set up for multiple interactions (may include impact parameter).
9352 IF(INMULT.EQ.1) THEN
9353 IF(MINT(35).LE.1) CALL PYMULT(2)
9354 IF(MINT(35).GE.2) CALL PYMIGN(2)
9355 ENDIF
9356
9357C...Loopback point for minimum bias in photon physics.
9358 LOOP2=0
9359 140 LOOP2=LOOP2+1
9360 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
9361 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
9362 IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
9363 &NGEN(97,1)=NGEN(97,1)+MINT(143)
9364 MINT(1)=ISUB
9365 ISTSB=ISET(ISUB)
9366
9367C...Random choice of flavour for some SUSY processes.
9368 IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
9369C...~e_L ~nu_e or ~mu_L ~nu_mu.
9370 IF(ISUB.EQ.210) THEN
9371 KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
9372 KFPR(ISUB,2)=KFPR(ISUB,1)+1
9373C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
9374 ELSEIF(ISUB.EQ.213) THEN
9375 KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
9376 KFPR(ISUB,2)=KFPR(ISUB,1)
9377C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
9378 ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
9379 & ISUB.NE.257) THEN
9380 IF(ISUB.GE.258) THEN
9381 RKF=4D0
9382 ELSE
9383 RKF=5D0
9384 ENDIF
9385 IF(MOD(ISUB,2).EQ.0) THEN
9386 KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
9387 ELSE
9388 KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
9389 ENDIF
9390C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9391 ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
9392 IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
9393 KSU1=KSUSY1
9394 KSU2=KSUSY1
9395 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
9396 KSU1=KSUSY2
9397 KSU2=KSUSY2
9398 ELSEIF(PYR(0).LT.0.5D0) THEN
9399 KSU1=KSUSY1
9400 KSU2=KSUSY2
9401 ELSE
9402 KSU1=KSUSY2
9403 KSU2=KSUSY1
9404 ENDIF
9405 KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
9406 KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
9407C...~q ~q(bar); ~q = ~d, ~u, ~s, or ~c.
9408 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
9409 KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
9410 KFPR(ISUB,2)=KFPR(ISUB,1)
9411 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
9412 KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
9413 KFPR(ISUB,2)=KFPR(ISUB,1)
9414C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
9415 ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
9416 IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
9417 KSU1=KSUSY1
9418 KSU2=KSUSY1
9419 ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
9420 KSU1=KSUSY2
9421 KSU2=KSUSY2
9422 ELSEIF(PYR(0).LT.0.5D0) THEN
9423 KSU1=KSUSY1
9424 KSU2=KSUSY2
9425 ELSE
9426 KSU1=KSUSY2
9427 KSU2=KSUSY1
9428 ENDIF
9429 IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
9430 RKF=5D0
9431 ELSE
9432 RKF=4D0
9433 ENDIF
9434 KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
9435 ENDIF
9436 ENDIF
9437
9438C...Random choice of flavours for some UED processes
9439c...The production processes can generate a doublet pair,
9440c...a singlet pair, or a doublet + singlet.
9441 IF(ISUB.EQ.313)THEN
9442C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
9443 IF(PYR(0).LE.0.1)THEN
9444 KFPR(ISUB,1)=5100001
9445 ELSE
9446 KFPR(ISUB,1)=5100002
9447 ENDIF
9448 KFPR(ISUB,2)=KFPR(ISUB,1)
9449 ELSEIF(ISUB.EQ.314.OR.ISUB.EQ.315)THEN
9450C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
9451C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
9452 IF(PYR(0).LE.0.1)THEN
9453 KFPR(ISUB,1)=5100001
9454 ELSE
9455 KFPR(ISUB,1)=5100002
9456 ENDIF
9457 KFPR(ISUB,2)=-KFPR(ISUB,1)
9458 ELSEIF(ISUB.EQ.316)THEN
9459C...qi + qbarj -> q*_Di + q*_Sbarj
9460 IF(PYR(0).LE.0.5)THEN
9461 KFPR(ISUB,1)=5100001
9462c Changed from private pythia6410_ued code
9463c KFPR(ISUB,2)=-5010001
9464 KFPR(ISUB,2)=-6100002
9465 ELSE
9466 KFPR(ISUB,1)=5100002
9467c Changed from private pythia6410_ued code
9468c KFPR(ISUB,2)=-5010002
9469 KFPR(ISUB,2)=-6100001
9470 ENDIF
9471 ELSEIF(ISUB.EQ.317)THEN
9472C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
9473 IF(PYR(0).LE.0.5)THEN
9474 KFPR(ISUB,1)=5100001
9475 KFPR(ISUB,2)=-5100002
9476 ELSE
9477 KFPR(ISUB,1)=5100002
9478 KFPR(ISUB,2)=-5100001
9479 ENDIF
9480 ELSEIF(ISUB.EQ.318)THEN
9481C...qi + qj -> q*_Di + q*_Sj
9482 IF(PYR(0).LE.0.5)THEN
9483 KFPR(ISUB,1)=5100001
9484 KFPR(ISUB,2)=6100002
9485 ELSE
9486 KFPR(ISUB,1)=5100002
9487 KFPR(ISUB,2)=6100001
9488 ENDIF
9489 ENDIF
9490
9491C...Find resonances (explicit or implicit in cross-section).
9492 MINT(72)=0
9493 KFR1=0
9494 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
9495 KFR1=KFPR(ISUB,1)
9496 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
9497 & ISUB.EQ.171.OR.ISUB.EQ.176) THEN
9498 KFR1=23
9499 ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
9500 & ISUB.EQ.177) THEN
9501 KFR1=24
9502 ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
9503 KFR1=25
9504 IF(MSTP(46).EQ.5) THEN
9505 KFR1=89
9506 PMAS(89,1)=PARP(45)
9507 PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
9508 ENDIF
9509 ELSEIF(ISUB.EQ.481) THEN
9510 KFR1=9900001
9511 ENDIF
9512 CKMX=CKIN(2)
9513 IF(CKMX.LE.0D0) CKMX=VINT(1)
9514 KCR1=PYCOMP(KFR1)
9515 IF(KCR1.EQ.0) KFR1=0
9516 IF(KFR1.NE.0) THEN
9517 IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
9518 & CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
9519 ENDIF
9520 IF(KFR1.NE.0) THEN
9521 TAUR1=PMAS(KCR1,1)**2/VINT(2)
9522 GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
9523 MINT(72)=1
9524 MINT(73)=KFR1
9525 VINT(73)=TAUR1
9526 VINT(74)=GAMR1
9527 ENDIF
9528 KFR2=0
9529 KFR3=0
9530 IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
9531 $(ISUB.GE.361.AND.ISUB.LE.380))
9532 $THEN
9533 KFR2=23
9534 IF(ISUB.EQ.141) THEN
9535 KCR2=PYCOMP(KFR2)
9536 IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
9537 & CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
9538 KFR2=0
9539 ELSE
9540 TAUR2=PMAS(KCR2,1)**2/VINT(2)
9541 GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
9542 MINT(72)=2
9543 MINT(74)=KFR2
9544 VINT(75)=TAUR2
9545 VINT(76)=GAMR2
9546 ENDIF
9547C...3 resonances at work: rho, omega, a
9548 ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
9549 & .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
9550 MINT(72)=IRES
9551 IF(IRES.GE.1) THEN
9552 VINT(73)=XMAS(1)**2/VINT(2)
9553 VINT(74)=XMAS(1)*XWID(1)/VINT(2)
9554 TAUR1=VINT(73)
9555 GAMR1=VINT(74)
9556 KFR1=1
9557 ENDIF
9558 IF(IRES.GE.2) THEN
9559 VINT(75)=XMAS(2)**2/VINT(2)
9560 VINT(76)=XMAS(2)*XWID(2)/VINT(2)
9561 TAUR2=VINT(75)
9562 GAMR2=VINT(76)
9563 KFR2=2
9564 ENDIF
9565 IF(IRES.EQ.3) THEN
9566 VINT(77)=XMAS(3)**2/VINT(2)
9567 VINT(78)=XMAS(3)*XWID(3)/VINT(2)
9568 TAUR3=VINT(77)
9569 GAMR3=VINT(78)
9570 KFR3=3
9571 ENDIF
9572C...Charged current: rho+- and a+-
9573 ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
9574 MINT(72)=IRES
9575 IF(JRES.GE.1) THEN
9576 VINT(73)=YMAS(1)**2/VINT(2)
9577 VINT(74)=YMAS(1)*YWID(1)/VINT(2)
9578 KFR1=1
9579 TAUR1=VINT(73)
9580 GAMR1=VINT(74)
9581 ENDIF
9582 IF(JRES.GE.2) THEN
9583 VINT(75)=YMAS(2)**2/VINT(2)
9584 VINT(76)=YMAS(2)*YWID(2)/VINT(2)
9585 KFR2=2
9586 TAUR2=VINT(73)
9587 GAMR2=VINT(74)
9588 ENDIF
9589 KFR3=0
9590 ENDIF
9591 IF(ISUB.NE.141) THEN
9592 IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN
9593
9594 ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
9595 MINT(72)=2
9596 ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
9597 MINT(72)=2
9598 MINT(74)=KFR3
9599 VINT(75)=TAUR3
9600 VINT(76)=GAMR3
9601 ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
9602 MINT(72)=2
9603 MINT(73)=KFR2
9604 VINT(73)=TAUR2
9605 VINT(74)=GAMR2
9606 MINT(74)=KFR3
9607 VINT(75)=TAUR3
9608 VINT(76)=GAMR3
9609 ELSEIF(KFR1.NE.0) THEN
9610 MINT(72)=1
9611 ELSEIF(KFR2.NE.0) THEN
9612 MINT(72)=1
9613 MINT(73)=KFR2
9614 VINT(73)=TAUR2
9615 VINT(74)=GAMR2
9616 ELSEIF(KFR3.NE.0) THEN
9617 MINT(72)=1
9618 MINT(73)=KFR3
9619 VINT(73)=TAUR3
9620 VINT(74)=GAMR3
9621 ELSE
9622 MINT(72)=0
9623 ENDIF
9624 ELSE
9625 IF(KFR2.NE.0.AND.KFR1.NE.0) THEN
9626
9627 ELSEIF(KFR2.NE.0) THEN
9628 KFR1=KFR2
9629 TAUR1=TAUR2
9630 GAMR1=GAMR2
9631 MINT(72)=1
9632 MINT(73)=KFR1
9633 VINT(73)=TAUR1
9634 VINT(74)=GAMR1
9635 KFR2=0
9636 ELSE
9637 MINT(72)=0
9638 ENDIF
9639 ENDIF
9640 ENDIF
9641
9642C...Find product masses and minimum pT of process,
9643C...optionally with broadening according to a truncated Breit-Wigner.
9644 VINT(63)=0D0
9645 VINT(64)=0D0
9646 MINT(71)=0
9647 VINT(71)=CKIN(3)
9648 IF(MINT(82).GE.2) VINT(71)=0D0
9649 VINT(80)=1D0
9650 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
9651 NBW=0
9652 DO 160 I=1,2
9653 PMMN(I)=0D0
9654 IF(KFPR(ISUB,I).EQ.0) THEN
9655 ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
9656 & PARP(41)) THEN
9657 VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
9658 ELSE
9659 NBW=NBW+1
9660C...This prevents SUSY/t particles from becoming too light.
9661 KFLW=KFPR(ISUB,I)
9662 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
9663 KCW=PYCOMP(KFLW)
9664 PMMN(I)=PMAS(KCW,1)
9665 DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
9666 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
9667 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
9668 & PMAS(PYCOMP(KFDP(IDC,2)),1)
9669 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
9670 & PMAS(PYCOMP(KFDP(IDC,3)),1)
9671 PMMN(I)=MIN(PMMN(I),PMSUM)
9672 ENDIF
9673 150 CONTINUE
9674 ELSEIF(KFLW.EQ.6) THEN
9675 PMMN(I)=PMAS(24,1)+PMAS(5,1)
9676 ENDIF
9677 ENDIF
9678 160 CONTINUE
9679 IF(NBW.GE.1) THEN
9680 CKIN41=CKIN(41)
9681 CKIN43=CKIN(43)
9682 CKIN(41)=MAX(PMMN(1),CKIN(41))
9683 CKIN(43)=MAX(PMMN(2),CKIN(43))
9684 CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
9685 CKIN(41)=CKIN41
9686 CKIN(43)=CKIN43
9687 IF(MINT(51).EQ.1) THEN
9688 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9689 IF(MFAIL.EQ.1) THEN
9690 MSTI(61)=1
9691 RETURN
9692 ENDIF
9693 GOTO 100
9694 ENDIF
9695 VINT(63)=PQM3**2
9696 VINT(64)=PQM4**2
9697 ENDIF
9698 IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
9699 IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
9700 ENDIF
9701
9702C...Prepare for additional variable choices in 2 -> 3.
9703 IF(ISTSB.EQ.5) THEN
9704 VINT(201)=0D0
9705 IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
9706 VINT(206)=VINT(201)
9707 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
9708 VINT(204)=PMAS(23,1)
9709 IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
9710 & VINT(204)=PMAS(24,1)
9711 IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
9712 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
9713 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
9714 & VINT(204)=VINT(201)
9715 VINT(209)=VINT(204)
9716 IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
9717 ENDIF
9718
9719C...Select incoming VDM particle (rho/omega/phi/J/psi).
9720 IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
9721 &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
9722 VRN=PYR(0)*SIGT(0,0,5)
9723 IF(MINT(101).LE.1) THEN
9724 I1MN=0
9725 I1MX=0
9726 ELSE
9727 I1MN=1
9728 I1MX=MINT(101)
9729 ENDIF
9730 IF(MINT(102).LE.1) THEN
9731 I2MN=0
9732 I2MX=0
9733 ELSE
9734 I2MN=1
9735 I2MX=MINT(102)
9736 ENDIF
9737 DO 180 I1=I1MN,I1MX
9738 KFV1=110*I1+3
9739 DO 170 I2=I2MN,I2MX
9740 KFV2=110*I2+3
9741 VRN=VRN-SIGT(I1,I2,5)
9742 IF(VRN.LE.0D0) GOTO 190
9743 170 CONTINUE
9744 180 CONTINUE
9745 190 IF(MINT(101).GE.2) MINT(103)=KFV1
9746 IF(MINT(102).GE.2) MINT(104)=KFV2
9747 ENDIF
9748
9749 IF(ISTSB.EQ.0) THEN
9750C...Elastic scattering or single or double diffractive scattering.
9751
9752C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
9753 MINT(103)=MINT(11)
9754 MINT(104)=MINT(12)
9755 PMM(1)=VINT(3)
9756 PMM(2)=VINT(4)
9757 IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
9758 JJ=ISUB-90
9759 VRN=PYR(0)*SIGT(0,0,JJ)
9760 IF(MINT(101).LE.1) THEN
9761 I1MN=0
9762 I1MX=0
9763 ELSE
9764 I1MN=1
9765 I1MX=MINT(101)
9766 ENDIF
9767 IF(MINT(102).LE.1) THEN
9768 I2MN=0
9769 I2MX=0
9770 ELSE
9771 I2MN=1
9772 I2MX=MINT(102)
9773 ENDIF
9774 DO 210 I1=I1MN,I1MX
9775 KFV1=110*I1+3
9776 DO 200 I2=I2MN,I2MX
9777 KFV2=110*I2+3
9778 VRN=VRN-SIGT(I1,I2,JJ)
9779 IF(VRN.LE.0D0) GOTO 220
9780 200 CONTINUE
9781 210 CONTINUE
9782 220 IF(MINT(101).GE.2) THEN
9783 MINT(103)=KFV1
9784 PMM(1)=PYMASS(KFV1)
9785 ENDIF
9786 IF(MINT(102).GE.2) THEN
9787 MINT(104)=KFV2
9788 PMM(2)=PYMASS(KFV2)
9789 ENDIF
9790 ENDIF
9791 VINT(67)=PMM(1)
9792 VINT(68)=PMM(2)
9793
9794C...Select mass for GVMD states (rejecting previous assignment).
9795 Q0S=4D0*PARP(15)**2
9796 Q1S=4D0*VINT(154)**2
9797 LOOP3=0
9798 230 LOOP3=LOOP3+1
9799 DO 240 JT=1,2
9800 IF(MINT(106+JT).EQ.3) THEN
9801 PS=VINT(2+JT)**2
9802 PMM(JT)=SQRT((Q0S+PS)*(Q1S+PS)/
9803 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS)
9804 IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
9805 & PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
9806 ENDIF
9807 240 CONTINUE
9808 IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
9809 IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
9810 & GOTO 230
9811 GOTO 100
9812 ENDIF
9813
9814C...Side/sides of diffractive system.
9815 MINT(17)=0
9816 MINT(18)=0
9817 IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
9818 IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1
9819
9820C...Find masses of particles and minimal masses of diffractive states.
9821 DO 250 JT=1,2
9822 PDIF(JT)=PMM(JT)
9823 VINT(68+JT)=PDIF(JT)
9824 IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
9825 250 CONTINUE
9826 SH=VINT(2)
9827 SQM1=PMM(1)**2
9828 SQM2=PMM(2)**2
9829 SQM3=PDIF(1)**2
9830 SQM4=PDIF(2)**2
9831 SMRES1=(PMM(1)+PMRC)**2
9832 SMRES2=(PMM(2)+PMRC)**2
9833
9834C...Find elastic slope and lower limit diffractive slope.
9835 IHA=MAX(2,IABS(MINT(103))/110)
9836 IF(IHA.GE.5) IHA=1
9837 IHB=MAX(2,IABS(MINT(104))/110)
9838 IF(IHB.GE.5) IHB=1
9839 IF(ISUB.EQ.91) THEN
9840 BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
9841 ELSEIF(ISUB.EQ.92) THEN
9842 BMN=MAX(2D0,2D0*BHAD(IHB))
9843 ELSEIF(ISUB.EQ.93) THEN
9844 BMN=MAX(2D0,2D0*BHAD(IHA))
9845 ELSEIF(ISUB.EQ.94) THEN
9846 BMN=2D0*ALP*4D0
9847 ENDIF
9848
9849C...Determine maximum possible t range and coefficient of generation.
9850 SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
9851 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9852 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9853 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9854 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9855 & (SQM1*SQM4-SQM2*SQM3)/SH
9856 THL=-0.5D0*(THA+THB)
9857 THU=THC/THL
9858 THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0
9859
9860C...Select diffractive mass/masses according to dm^2/m^2.
9861 LOOP3=0
9862 260 LOOP3=LOOP3+1
9863 DO 270 JT=1,2
9864 IF(MINT(16+JT).EQ.0) THEN
9865 PDIF(2+JT)=PDIF(JT)
9866 ELSE
9867 PMMIN=PDIF(JT)
9868 PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
9869 PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
9870 ENDIF
9871 270 CONTINUE
9872 SQM3=PDIF(3)**2
9873 SQM4=PDIF(4)**2
9874
9875C..Additional mass factors, including resonance enhancement.
9876 IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
9877 IF(LOOP3.LT.100) GOTO 260
9878 GOTO 100
9879 ENDIF
9880 IF(ISUB.EQ.92) THEN
9881 FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
9882 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9883 ELSEIF(ISUB.EQ.93) THEN
9884 FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
9885 IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
9886 ELSEIF(ISUB.EQ.94) THEN
9887 FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
9888 & (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
9889 & (1D0+CRES*SMRES2/(SMRES2+SQM4))
9890 IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
9891 ENDIF
9892
9893C...Select t according to exp(Bmn*t) and correct to right slope.
9894 TH=THU+LOG(1D0+THRND*PYR(0))/BMN
9895 IF(ISUB.GE.92) THEN
9896 IF(ISUB.EQ.92) THEN
9897 BADD=2D0*ALP*LOG(SH/SQM3)
9898 IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
9899 ELSEIF(ISUB.EQ.93) THEN
9900 BADD=2D0*ALP*LOG(SH/SQM4)
9901 IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
9902 ELSEIF(ISUB.EQ.94) THEN
9903 BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
9904 ENDIF
9905 IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
9906 ENDIF
9907
9908C...Check whether m^2 and t choices are consistent.
9909 SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
9910 THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
9911 THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
9912 IF(THB.LE.1D-8) GOTO 260
9913 THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
9914 & (SQM1*SQM4-SQM2*SQM3)/SH
9915 THLM=-0.5D0*(THA+THB)
9916 THUM=THC/THLM
9917 IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260
9918
9919C...Information to output.
9920 VINT(21)=1D0
9921 VINT(22)=0D0
9922 VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
9923 VINT(45)=TH
9924 VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
9925 VINT(63)=PDIF(3)**2
9926 VINT(64)=PDIF(4)**2
9927 VINT(283)=PMM(1)**2/4D0
9928 VINT(284)=PMM(2)**2/4D0
9929
9930C...Note: in the following, by In is meant the integral over the
9931C...quantity multiplying coefficient cn.
9932C...Choose tau according to h1(tau)/tau, where
9933C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
9934C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
9935C...I1/I5*c5*1/(tau+tau_R') +
9936C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
9937C...I1/I7*c7*tau/(1.-tau), and
9938C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
9939 ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
9940 CALL PYKLIM(1)
9941 IF(MINT(51).NE.0) THEN
9942 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9943 IF(MFAIL.EQ.1) THEN
9944 MSTI(61)=1
9945 RETURN
9946 ENDIF
9947 GOTO 100
9948 ENDIF
9949 RTAU=PYR(0)
9950 MTAU=1
9951 IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
9952 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
9953 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
9954 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
9955 & MTAU=5
9956 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9957 & COEF(ISUB,5)) MTAU=6
9958 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
9959 & COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
9960C...Additional check to handle techni-processes with extra resonance
9961C....Only modify tau treatment
9962 IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
9963 & THEN
9964 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9965 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
9966 IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
9967 & +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
9968 & +COEFX(ISUB,1)) MTAU=9
9969 ENDIF
9970 CALL PYKMAP(1,MTAU,PYR(0))
9971
9972C...2 -> 3, 4 processes:
9973C...Choose tau' according to h4(tau,tau')/tau', where
9974C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
9975C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
9976 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
9977 CALL PYKLIM(4)
9978 IF(MINT(51).NE.0) THEN
9979 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
9980 IF(MFAIL.EQ.1) THEN
9981 MSTI(61)=1
9982 RETURN
9983 ENDIF
9984 GOTO 100
9985 ENDIF
9986 RTAUP=PYR(0)
9987 MTAUP=1
9988 IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
9989 IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
9990 CALL PYKMAP(4,MTAUP,PYR(0))
9991 ENDIF
9992
9993C...Choose y* according to h2(y*), where
9994C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
9995C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
9996C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
9997C...and c1 + c2 + c3 + c4 + c5 = 1.
9998 CALL PYKLIM(2)
9999 IF(MINT(51).NE.0) THEN
10000 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10001 IF(MFAIL.EQ.1) THEN
10002 MSTI(61)=1
10003 RETURN
10004 ENDIF
10005 GOTO 100
10006 ENDIF
10007 RYST=PYR(0)
10008 MYST=1
10009 IF(RYST.GT.COEF(ISUB,8)) MYST=2
10010 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
10011 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
10012 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
10013 & COEF(ISUB,11)) MYST=5
10014 CALL PYKMAP(2,MYST,PYR(0))
10015
10016C...2 -> 2 processes:
10017C...Choose cos(theta-hat) (cth) according to h3(cth), where
10018C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
10019C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
10020C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
10021C...and c0 + c1 + c2 + c3 + c4 = 1.
10022 CALL PYKLIM(3)
10023 IF(MINT(51).NE.0) THEN
10024 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10025 IF(MFAIL.EQ.1) THEN
10026 MSTI(61)=1
10027 RETURN
10028 ENDIF
10029 GOTO 100
10030 ENDIF
10031 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
10032 RCTH=PYR(0)
10033 MCTH=1
10034 IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
10035 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
10036 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
10037 IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
10038 & COEF(ISUB,16)) MCTH=5
10039 CALL PYKMAP(3,MCTH,PYR(0))
10040 ENDIF
10041
10042C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
10043 IF(ISTSB.EQ.5) THEN
10044 CALL PYKMAP(5,0,0D0)
10045 IF(MINT(51).NE.0) THEN
10046 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10047 IF(MFAIL.EQ.1) THEN
10048 MSTI(61)=1
10049 RETURN
10050 ENDIF
10051 GOTO 100
10052 ENDIF
10053 ENDIF
10054
10055C...DIS as f + gamma* -> f process: set dummy values.
10056 ELSEIF(ISTSB.EQ.8) THEN
10057 VINT(21)=0.9D0
10058 VINT(22)=0D0
10059 VINT(23)=0D0
10060 VINT(47)=0D0
10061 VINT(48)=0D0
10062
10063C...Low-pT or multiple interactions (first semihard interaction).
10064 ELSEIF(ISTSB.EQ.9) THEN
10065 IF(MINT(35).LE.1) CALL PYMULT(3)
10066 IF(MINT(35).GE.2) CALL PYMIGN(3)
10067 ISUB=MINT(1)
10068
10069C...Study user-defined process: kinematics plus weight.
10070 ELSEIF(ISTSB.EQ.11) THEN
10071 IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
10072 & PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
10073 MSTI(51)=0
10074 IF(NUP.LE.0) THEN
10075 MINT(51)=2
10076 MSTI(51)=1
10077 IF(MINT(82).EQ.1) THEN
10078 NGEN(0,1)=NGEN(0,1)-1
10079 NGEN(ISUB,1)=NGEN(ISUB,1)-1
10080 ENDIF
10081 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10082 RETURN
10083 ENDIF
10084
10085C...Extract cross section event weight.
10086 IF(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.4) THEN
10087 SIGS=1D-9*XWGTUP
10088 ELSE
10089 SIGS=1D-9*XSECUP(KFPR(ISUB,1))
10090 ENDIF
10091 IF(IABS(IDWTUP).GE.1.AND.IABS(IDWTUP).LE.3) THEN
10092 VINT(97)=SIGN(1D0,XWGTUP)
10093 ELSE
10094 VINT(97)=1D-9*XWGTUP
10095 ENDIF
10096
10097C...Construct 'trivial' kinematical variables needed.
10098 KFL1=IDUP(1)
10099 KFL2=IDUP(2)
10100 VINT(41)=PUP(4,1)/EBMUP(1)
10101 VINT(42)=PUP(4,2)/EBMUP(2)
10102 IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
10103 CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
10104 & '(listing follows):')
10105 CALL PYLIST(7)
10106 ENDIF
10107 VINT(21)=VINT(41)*VINT(42)
10108 VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
10109 VINT(44)=VINT(21)*VINT(2)
10110 VINT(43)=SQRT(MAX(0D0,VINT(44)))
10111 VINT(55)=SCALUP
10112 IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
10113 VINT(56)=VINT(55)**2
10114 VINT(57)=AQEDUP
10115 VINT(58)=AQCDUP
10116
10117C...Construct other kinematical variables needed (approximately).
10118 VINT(23)=0D0
10119 VINT(26)=VINT(21)
10120 VINT(45)=-0.5D0*VINT(44)
10121 VINT(46)=-0.5D0*VINT(44)
10122 VINT(49)=VINT(43)
10123 VINT(50)=VINT(44)
10124 VINT(51)=VINT(55)
10125 VINT(52)=VINT(56)
10126 VINT(53)=VINT(55)
10127 VINT(54)=VINT(56)
10128 VINT(25)=0D0
10129 VINT(48)=0D0
10130 IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
10131 & '(PYRAND:) unacceptable ISTUP code for incoming particles')
10132 DO 280 IUP=3,NUP
10133 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
10134 & '(PYRAND:) unacceptable ISTUP code for particles')
10135 IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
10136 & PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
10137 IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
10138 & PUP(2,IUP)**2)
10139 280 CONTINUE
10140 VINT(47)=SQRT(VINT(48))
10141 ENDIF
10142
10143C...Choose azimuthal angle.
10144 VINT(24)=0D0
10145 IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)
10146
10147C...Check against user cuts on kinematics at parton level.
10148 MINT(51)=0
10149 IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
10150 IF(MINT(51).NE.0) THEN
10151 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10152 IF(MFAIL.EQ.1) THEN
10153 MSTI(61)=1
10154 RETURN
10155 ENDIF
10156 GOTO 100
10157 ENDIF
10158 IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
10159 MCUT=0
10160 IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
10161 & CALL PYKCUT(MCUT)
10162 IF(MCUT.NE.0) THEN
10163 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10164 IF(MFAIL.EQ.1) THEN
10165 MSTI(61)=1
10166 RETURN
10167 ENDIF
10168 GOTO 100
10169 ENDIF
10170 ENDIF
10171
10172 IF(ISTSB.LE.10) THEN
10173C... If internal process, call PYSIGH
10174 CALL PYSIGH(NCHN,SIGS)
10175 ELSE
10176C... If external process, still have to set MI starting scale
10177 IF (MSTP(86).EQ.1) THEN
10178C... Limit phase space by xT2 of hard interaction
10179C... (gives undercounting of MI when ext proc != dijets)
10180 XT2GMX = VINT(25)
10181 ELSE
10182C... All accessible phase space allowed
10183C... (gives double counting of MI when ext proc = dijets)
10184 XT2GMX = (1D0-VINT(41))*(1D0-VINT(42))
10185 ENDIF
10186 VINT(62)=0.25D0*XT2GMX*VINT(2)
10187 VINT(61)=SQRT(MAX(0D0,VINT(62)))
10188 ENDIF
10189
10190 SIGSOR=SIGS
10191 SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)
10192
10193C...Multiply cross section by lepton -> photon flux factor.
10194 IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
10195 SIGS=WTGAGA*SIGS
10196 DO 290 ICHN=1,NCHN
10197 SIGH(ICHN)=WTGAGA*SIGH(ICHN)
10198 290 CONTINUE
10199 SIGLPT=WTGAGA*SIGLPT
10200 ENDIF
10201
10202C...Multiply cross-section by user-defined weights.
10203 IF(MSTP(173).EQ.1) THEN
10204 SIGS=PARP(173)*SIGS
10205 DO 300 ICHN=1,NCHN
10206 SIGH(ICHN)=PARP(173)*SIGH(ICHN)
10207 300 CONTINUE
10208 SIGLPT=PARP(173)*SIGLPT
10209 ENDIF
10210 WTXS=1D0
10211 SIGSWT=SIGS
10212 VINT(99)=1D0
10213 VINT(100)=1D0
10214 IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
10215 IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
10216 & MSUB(95).EQ.0) CALL PYEVWT(WTXS)
10217 SIGSWT=WTXS*SIGS
10218 VINT(99)=WTXS
10219 IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
10220 ENDIF
10221
10222C...Calculations for Monte Carlo estimate of all cross-sections.
10223 IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
10224 IF(MSTP(142).LE.1) THEN
10225 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10226 ELSE
10227 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
10228 ENDIF
10229 ELSEIF(MINT(82).EQ.1) THEN
10230 XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
10231 ENDIF
10232 IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
10233 &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT
10234
10235C...Multiple interactions: store results of cross-section calculation.
10236 IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
10237 VINT(153)=SIGSOR
10238 IF(MINT(35).LE.1) CALL PYMULT(4)
10239 IF(MINT(35).GE.2) CALL PYMIGN(4)
10240 ENDIF
10241
10242C...Ratio of actual to maximum cross section.
10243 IF(ISTSB.NE.11) THEN
10244 VIOL=SIGSWT/XSEC(ISUB,1)
10245 IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
10246 ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
10247 VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
10248 ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
10249 VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
10250 ELSE
10251 VIOL=1D0
10252 ENDIF
10253
10254C...Check that weight not negative.
10255 IF(MSTP(123).LE.0) THEN
10256 IF(VIOL.LT.-1D-3) THEN
10257 WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
10258 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10259 & VINT(22),VINT(23),VINT(26)
10260 CALL PYSTOP(2)
10261 ENDIF
10262 ELSE
10263 IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
10264 VINT(109)=VIOL
10265 IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
10266 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
10267 & VINT(22),VINT(23),VINT(26)
10268 ENDIF
10269 ENDIF
10270
10271C...Weighting using estimate of maximum of differential cross-section.
10272 RATND=1D0
10273 IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
10274 IF(VIOL.LT.PYR(0)) THEN
10275 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10276 IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
10277 GOTO 100
10278 ENDIF
10279 ELSEIF(MFAIL.EQ.0) THEN
10280 RATND=SIGLPT/XSEC(95,1)
10281 VIOL=VIOL/RATND
10282 IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
10283 IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
10284 & (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
10285 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10286 ISUB=0
10287 GOTO 100
10288 ENDIF
10289 IF(VIOL.LT.PYR(0)) THEN
10290 GOTO 140
10291 ENDIF
10292 ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
10293 IF(VIOL.LT.PYR(0)) THEN
10294 MSTI(61)=1
10295 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10296 RETURN
10297 ENDIF
10298 ELSE
10299 RATND=SIGLPT/XSEC(95,1)
10300 IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
10301 MSTI(61)=1
10302 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10303 RETURN
10304 ENDIF
10305 VIOL=VIOL/RATND
10306 IF(VIOL.LT.PYR(0)) THEN
10307 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10308 GOTO 100
10309 ENDIF
10310 ENDIF
10311
10312C...Check for possible violation of estimated maximum of differential
10313C...cross-section used in weighting.
10314 IF(MSTP(123).LE.0) THEN
10315 IF(VIOL.GT.1D0) THEN
10316 WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
10317 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10318 & VINT(22),VINT(23),VINT(26)
10319 CALL PYSTOP(2)
10320 ENDIF
10321 ELSEIF(MSTP(123).EQ.1) THEN
10322 IF(VIOL.GT.VINT(108)) THEN
10323 VINT(108)=VIOL
10324 IF(VIOL.GT.1.0001D0) THEN
10325 MINT(10)=1
10326 WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10327 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10328 & VINT(22),VINT(23),VINT(26)
10329 ENDIF
10330 ENDIF
10331 ELSEIF(VIOL.GT.VINT(108)) THEN
10332 VINT(108)=VIOL
10333 IF(VIOL.GT.1D0) THEN
10334 MINT(10)=1
10335 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
10336 IF(ISTSB.EQ.11.AND.(IABS(IDWTUP).EQ.1.OR.IABS(IDWTUP).EQ.2))
10337 & THEN
10338 XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
10339 IF(KFPR(ISUB,1).LE.9) THEN
10340 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
10341 & XMAXUP(KFPR(ISUB,1))
10342 ELSEIF(KFPR(ISUB,1).LE.99) THEN
10343 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
10344 & XMAXUP(KFPR(ISUB,1))
10345 ELSE
10346 IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
10347 & XMAXUP(KFPR(ISUB,1))
10348 ENDIF
10349 ENDIF
10350 IF(ISTSB.NE.11.OR.IABS(IDWTUP).EQ.1) THEN
10351 XDIF=XSEC(ISUB,1)*(VIOL-1D0)
10352 XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
10353 IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
10354 & XSEC(0,1)=XSEC(0,1)+XDIF
10355 IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
10356 & VINT(22),VINT(23),VINT(26)
10357 IF(ISUB.LE.9) THEN
10358 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
10359 ELSEIF(ISUB.LE.99) THEN
10360 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
10361 ELSE
10362 IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
10363 ENDIF
10364 ENDIF
10365 VINT(108)=1D0
10366 ENDIF
10367 ENDIF
10368
10369C...Multiple interactions: choose impact parameter (if not already done).
10370 IF(MINT(39).EQ.0) VINT(148)=1D0
10371 IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
10372 &MSTP(82).GE.3) THEN
10373 IF(MINT(35).LE.1) CALL PYMULT(5)
10374 IF(MINT(35).GE.2) CALL PYMIGN(5)
10375 IF(VINT(150).LT.PYR(0)) THEN
10376 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10377 IF(MFAIL.EQ.1) THEN
10378 MSTI(61)=1
10379 RETURN
10380 ENDIF
10381 GOTO 100
10382 ENDIF
10383 ENDIF
10384 IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
10385 IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
10386 IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
10387 IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
10388 ENDIF
10389 IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1
10390
10391C...Choose flavour of reacting partons (and subprocess).
10392 IF(ISTSB.GE.11) GOTO 320
10393 RSIGS=SIGS*PYR(0)
10394 QT2=VINT(48)
10395 RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
10396 &(VINT(1)/PARP(89))**PARP(90))**2))**2)
10397 IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
10398 &PYR(0).GT.RQQBAR)) THEN
10399 DO 310 ICHN=1,NCHN
10400 KFL1=ISIG(ICHN,1)
10401 KFL2=ISIG(ICHN,2)
10402 MINT(2)=ISIG(ICHN,3)
10403 RSIGS=RSIGS-SIGH(ICHN)
10404 IF(RSIGS.LE.0D0) GOTO 320
10405 310 CONTINUE
10406
10407C...Multiple interactions: choose qqbar preferentially at small pT.
10408 ELSEIF(ISUB.EQ.96) THEN
10409 MINT(105)=MINT(103)
10410 MINT(109)=MINT(107)
10411 CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
10412 MINT(105)=MINT(104)
10413 MINT(109)=MINT(108)
10414 CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
10415 MINT(1)=11
10416 MINT(2)=1
10417 IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2
10418
10419C...Low-pT: choose string drawing configuration.
10420 ELSE
10421 KFL1=21
10422 KFL2=21
10423 RSIGS=6D0*PYR(0)
10424 MINT(2)=1
10425 IF(RSIGS.GT.1D0) MINT(2)=2
10426 IF(RSIGS.GT.2D0) MINT(2)=3
10427 ENDIF
10428
10429C...Reassign QCD process. Partons before initial state radiation.
10430 320 IF(MINT(2).GT.10) THEN
10431 MINT(1)=MINT(2)/10
10432 MINT(2)=MOD(MINT(2),10)
10433 ENDIF
10434 IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
10435 &NGEN(MINT(1),2)+1
10436 MINT(15)=KFL1
10437 MINT(16)=KFL2
10438 MINT(13)=MINT(15)
10439 MINT(14)=MINT(16)
10440 VINT(141)=VINT(41)
10441 VINT(142)=VINT(42)
10442 VINT(151)=0D0
10443 VINT(152)=0D0
10444
10445C...Calculate x value of photon for parton inside photon inside e.
10446 DO 350 JT=1,2
10447 MINT(18+JT)=0
10448 VINT(154+JT)=0D0
10449 MSPLI=0
10450 IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
10451 IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
10452 IF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
10453 IF(MSPLI.EQ.2) THEN
10454 KFLH=MINT(14+JT)
10455 XHRD=VINT(140+JT)
10456 Q2HRD=VINT(54)
10457 MINT(105)=MINT(102+JT)
10458 MINT(109)=MINT(106+JT)
10459 VINT(120)=VINT(2+JT)
10460C.... ALICE
10461C.... Store side in MINT(124)
10462 MINT(124) = JT
10463C....
10464 IF(MSTP(57).LE.1) THEN
10465 CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
10466 ELSE
10467 CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
10468 ENDIF
10469 WTMX=4D0*XPQ(KFLH)
10470 IF(MSTP(13).EQ.2) THEN
10471 Q2PMS=Q2HRD/PMAS(11,1)**2
10472 WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
10473 ENDIF
10474 330 XE=XHRD**PYR(0)
10475 XG=MIN(1D0-1D-10,XHRD/XE)
10476 IF(MSTP(57).LE.1) THEN
10477 CALL PYPDFU(22,XG,Q2HRD,XPQ)
10478 ELSE
10479 CALL PYPDFL(22,XG,Q2HRD,XPQ)
10480 ENDIF
10481 WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
10482 IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
10483 IF(WT.LT.PYR(0)*WTMX) GOTO 330
10484 MINT(18+JT)=1
10485 VINT(154+JT)=XE
10486 DO 340 KFLS=-25,25
10487 XSFX(JT,KFLS)=XPQ(KFLS)
10488 340 CONTINUE
10489 ENDIF
10490 350 CONTINUE
10491
10492C...Pick scale where photon is resolved.
10493 Q0S=PARP(15)**2
10494 Q1S=VINT(154)**2
10495 VINT(283)=0D0
10496 IF(MINT(107).EQ.3) THEN
10497 IF(MSTP(66).EQ.1) THEN
10498 VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
10499 ELSEIF(MSTP(66).EQ.2) THEN
10500 PS=VINT(3)**2
10501 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10502 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10503 Q2INT=SQRT(Q0S*Q2EFF)
10504 VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10505 ELSEIF(MSTP(66).EQ.3) THEN
10506 VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
10507 ELSEIF(MSTP(66).GE.4) THEN
10508 PS=0.25D0*VINT(3)**2
10509 VINT(283)=(Q0S+PS)*(Q1S+PS)/
10510 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10511 ENDIF
10512 ENDIF
10513 VINT(284)=0D0
10514 IF(MINT(108).EQ.3) THEN
10515 IF(MSTP(66).EQ.1) THEN
10516 VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
10517 ELSEIF(MSTP(66).EQ.2) THEN
10518 PS=VINT(4)**2
10519 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
10520 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
10521 Q2INT=SQRT(Q0S*Q2EFF)
10522 VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
10523 ELSEIF(MSTP(66).EQ.3) THEN
10524 VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
10525 ELSEIF(MSTP(66).GE.4) THEN
10526 PS=0.25D0*VINT(4)**2
10527 VINT(284)=(Q0S+PS)*(Q1S+PS)/
10528 & (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
10529 ENDIF
10530 ENDIF
10531 IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
10532
10533C...Format statements for differential cross-section maximum violations.
10534 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
10535 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10536 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
10537 &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
10538 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
10539 &'in event',1X,I7)
10540 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
10541 &'in event',1X,I7,'D0'/1X,'Execution stopped!')
10542 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
10543 &'in event',1X,I7)
10544 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
10545 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
10546 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
10547 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
10548 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
10549 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)
10550
10551 RETURN
10552 END
10553
10554C*********************************************************************
10555
10556C...PYSCAT
10557C...Finds outgoing flavours and event type; sets up the kinematics
10558C...and colour flow of the hard scattering
10559
10560 SUBROUTINE PYSCAT
10561
10562C...Double precision and integer declarations
10563 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
10564 IMPLICIT INTEGER(I-N)
10565 INTEGER PYK,PYCHGE,PYCOMP
10566C...Parameter statement to help give large particle numbers.
10567 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
10568 &KEXCIT=4000000,KDIMEN=5000000)
10569C...Parameter statement for maximum size of showers.
10570 PARAMETER (MAXNUR=1000)
10571
10572C...User process event common block.
10573 INTEGER MAXNUP
10574 PARAMETER (MAXNUP=500)
10575 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
10576 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
10577 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
10578 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
10579 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
10580 SAVE /HEPEUP/
10581
10582C...Commonblocks.
10583 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
10584 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
10585 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
10586 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
10587 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
10588 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
10589 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
10590 COMMON/PYINT1/MINT(400),VINT(400)
10591 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
10592 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
10593 COMMON/PYINT4/MWID(500),WIDS(500,5)
10594 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
10595 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
10596 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
10597 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
10598 COMMON/PYPUED/IUED(0:99),RUED(0:99)
10599 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,
10600 &/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYSSMT/,
10601 &/PYTCSM/,/PYPUED/
10602C...Local arrays and saved variables
10603 DIMENSION WDTP(0:400),WDTE(0:400,0:5),PMQ(2),Z(2),CTHE(2),
10604 &PHI(2),KUPPO(100),VINTSV(41:66),ILAB(100)
10605 INTEGER IOKFLA(6),IIFLAV
10606C...UED related declarations:
10607C...equivalences between ordered particles (451->475)
10608C...and UED particle code (5 000 000 + id)
10609 DIMENSION IUEDEQ(475),MUED(2)
10610 DATA (IUEDEQ(I),I=451,475)/
10611 & 6100001,6100002,6100003,6100004,6100005,6100006,
10612 & 5100001,5100002,5100003,5100004,5100005,5100006,
10613 & 6100011,6100013,6100015,
10614 & 5100012,5100011,5100014,5100013,5100016,5100015,
10615 & 5100021,5100022,5100023,5100024/
10616 SAVE VINTSV
10617
10618C...Read out process
10619 ISUB=MINT(1)
10620 ISUBSV=ISUB
10621
10622C...Restore information for low-pT processes
10623 IF(ISUB.EQ.95.AND.MINT(57).GE.1) THEN
10624 DO 100 J=41,66
10625 100 VINT(J)=VINTSV(J)
10626 ENDIF
10627
10628C...Convert H' or A process into equivalent H one
10629 IHIGG=1
10630 KFHIGG=25
10631 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
10632 &ISUB.LE.190)) THEN
10633 IHIGG=2
10634 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
10635 KFHIGG=33+IHIGG
10636 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
10637 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
10638 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
10639 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
10640 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
10641 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
10642 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
10643 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
10644 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
10645 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
10646 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
10647 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
10648 ENDIF
10649
10650 IF(ISUB.EQ.401.OR.ISUB.EQ.402) KFHIGG=KFPR(ISUB,1)
10651
10652C...Convert bottomonium process into equivalent charmonium ones.
10653 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
10654
10655C...Choice of subprocess, number of documentation lines
10656 IDOC=6+ISET(ISUB)
10657 IF(ISUB.EQ.95) IDOC=8
10658 IF(ISET(ISUB).EQ.5) IDOC=9
10659 IF(ISET(ISUB).EQ.11) IDOC=4+NUP
10660 MINT(3)=IDOC-6
10661 IF(IDOC.GE.9.AND.ISET(ISUB).LE.4) IDOC=IDOC+2
10662 MINT(4)=IDOC
10663 IPU1=MINT(84)+1
10664 IPU2=MINT(84)+2
10665 IPU3=MINT(84)+3
10666 IPU4=MINT(84)+4
10667 IPU5=MINT(84)+5
10668 IPU6=MINT(84)+6
10669
10670C...Reset K, P and V vectors. Store incoming particles
10671 DO 120 JT=1,MSTP(126)+100
10672 I=MINT(83)+JT
10673 IF(I.GT.MSTU(4)) GOTO 120
10674 DO 110 J=1,5
10675 K(I,J)=0
10676 P(I,J)=0D0
10677 V(I,J)=0D0
10678 110 CONTINUE
10679 120 CONTINUE
10680 DO 140 JT=1,2
10681 I=MINT(83)+JT
10682 K(I,1)=21
10683 K(I,2)=MINT(10+JT)
10684 DO 130 J=1,5
10685 P(I,J)=VINT(285+5*JT+J)
10686 130 CONTINUE
10687 140 CONTINUE
10688 MINT(6)=2
10689 KFRES=0
10690
10691C...Store incoming partons in their CM-frame. Save pdf value.
10692 SH=VINT(44)
10693 SHR=SQRT(SH)
10694 SHP=VINT(26)*VINT(2)
10695 SHPR=SQRT(SHP)
10696 SHUSER=SHR
10697 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) SHUSER=SHPR
10698 DO 150 JT=1,2
10699 I=MINT(84)+JT
10700 K(I,1)=14
10701 K(I,2)=MINT(14+JT)
10702 K(I,3)=MINT(83)+2+JT
10703 P(I,3)=0.5D0*SHUSER*(-1D0)**(JT-1)
10704 P(I,4)=0.5D0*SHUSER
10705 IF(MINT(14+JT).GE.-40.AND.MINT(14+JT).LE.40) THEN
10706 VINT(38+JT)=XSFX(JT,MINT(14+JT))
10707 ELSE
10708 VINT(38+JT)=1D0
10709 ENDIF
10710 150 CONTINUE
10711
10712C...Copy incoming partons to documentation lines
10713 DO 170 JT=1,2
10714 I1=MINT(83)+4+JT
10715 I2=MINT(84)+JT
10716 K(I1,1)=21
10717 K(I1,2)=K(I2,2)
10718 K(I1,3)=I1-2
10719 DO 160 J=1,5
10720 P(I1,J)=P(I2,J)
10721 160 CONTINUE
10722 170 CONTINUE
10723
10724C...Choose new quark/lepton flavour for relevant annihilation graphs
10725 IF(ISUB.EQ.12.OR.ISUB.EQ.53.OR.ISUB.EQ.54.OR.ISUB.EQ.58.OR.
10726 &ISUB.EQ.314.OR.ISUB.EQ.319.OR.ISUB.EQ.316.OR.
10727 &(ISUB.GE.135.AND.ISUB.LE.140).OR.ISUB.EQ.382.OR.ISUB.EQ.385) THEN
10728 IGLGA=21
10729 IF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) IGLGA=22
10730 CALL PYWIDT(IGLGA,SH,WDTP,WDTE)
10731 180 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
10732 DO 190 I=1,MDCY(IGLGA,3)
10733 KFLF=KFDP(I+MDCY(IGLGA,2)-1,1)
10734 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
10735 IF(RKFL.LE.0D0) GOTO 200
10736 190 CONTINUE
10737 200 CONTINUE
10738 IF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319
10739 & .OR.ISUB.EQ.316).AND.MINT(2).LE.2) THEN
10740 IF(KFLF.GE.4) GOTO 180
10741 ELSEIF((ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10742 & OR.ISUB.EQ.316).AND.MINT(2).LE.4) THEN
10743 KFLF=4
10744 MINT(2)=MINT(2)-2
10745 ELSEIF(ISUB.EQ.53.OR.ISUB.EQ.385.OR.ISUB.EQ.314.OR.ISUB.EQ.319.
10746 & OR.ISUB.EQ.316) THEN
10747 KFLF=5
10748 MINT(2)=MINT(2)-4
10749 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.1.AND.IABS(MINT(15)).LE.2
10750 & .AND.IABS(KFLF).GE.3) THEN
10751 FACQQB=VINT(58)**2*4D0/9D0*(VINT(45)**2+VINT(46)**2)/
10752 & VINT(44)**2
10753 FACCIB=VINT(46)**2/RTCM(41)**4
10754 IF(FACQQB/(FACQQB+FACCIB).LT.PYR(0)) GOTO 180
10755 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.2) THEN
10756 KFLF=5
10757 MINT(2)=1
10758 ELSEIF(ISUB.EQ.382.AND.ITCM(5).EQ.5.AND.MINT(2).EQ.1) THEN
10759 IF(KFLF.EQ.5) GOTO 180
10760 ELSEIF(ISUB.EQ.54.OR.ISUB.EQ.135.OR.ISUB.EQ.136) THEN
10761 IF((KCHG(PYCOMP(KFLF),1)/2D0)**2.LT.PYR(0)) GOTO 180
10762 ELSEIF(ISUB.EQ.58.OR.(ISUB.GE.137.AND.ISUB.LE.140)) THEN
10763 IF((KCHG(PYCOMP(KFLF),1)/3D0)**2.LT.PYR(0)) GOTO 180
10764 ENDIF
10765 ENDIF
10766
10767C...Final state flavours and colour flow: default values
10768 JS=1
10769 MINT(21)=MINT(15)
10770 MINT(22)=MINT(16)
10771 MINT(23)=0
10772 MINT(24)=0
10773 KCC=20
10774 KCS=ISIGN(1,MINT(15))
10775
10776 IF(ISET(ISUB).EQ.11) THEN
10777C...User-defined processes: find products
10778 MINT(3)=0
10779 DO 210 IUP=3,NUP
10780 IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) THEN
10781 ELSEIF(NUP.EQ.5.AND.IUP.GE.4.AND.MOTHUP(1,4).EQ.3) THEN
10782 MINT(21+IUP)=IDUP(IUP)
10783 ELSEIF(ISTUP(IUP).EQ.1.AND.(ISTUP(MOTHUP(1,IUP)).EQ.2.OR.
10784 & ISTUP(MOTHUP(1,IUP)).EQ.3).AND.IDUP(MOTHUP(1,IUP)).NE.0) THEN
10785 ELSEIF(IDUP(IUP).EQ.0) THEN
10786 ELSE
10787 MINT(3)=MINT(3)+1
10788 IF(MINT(3).LE.6) MINT(20+MINT(3))=IDUP(IUP)
10789 ENDIF
10790 210 CONTINUE
10791
10792 ELSEIF(ISUB.LE.10) THEN
10793 IF(ISUB.EQ.1) THEN
10794C...f + fbar -> gamma*/Z0
10795 KFRES=23
10796
10797 ELSEIF(ISUB.EQ.2) THEN
10798C...f + fbar' -> W+/-
10799 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10800 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10801 KFRES=ISIGN(24,KCH1+KCH2)
10802
10803 ELSEIF(ISUB.EQ.3) THEN
10804C...f + fbar -> h0 (or H0, or A0)
10805 KFRES=KFHIGG
10806
10807 ELSEIF(ISUB.EQ.4) THEN
10808C...gamma + W+/- -> W+/-
10809
10810 ELSEIF(ISUB.EQ.5) THEN
10811C...Z0 + Z0 -> h0
10812 XH=SH/SHP
10813 MINT(21)=MINT(15)
10814 MINT(22)=MINT(16)
10815 PMQ(1)=PYMASS(MINT(21))
10816 PMQ(2)=PYMASS(MINT(22))
10817 220 JT=INT(1.5D0+PYR(0))
10818 ZMIN=2D0*PMQ(JT)/SHPR
10819 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10820 & (SHPR*(SHPR-PMQ(3-JT)))
10821 ZMAX=MIN(1D0-XH,ZMAX)
10822 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10823 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10824 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 220
10825 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10826 IF(SQC1.LT.1D-8) GOTO 220
10827 C1=SQRT(SQC1)
10828 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10829 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10830 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10831 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10832 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10833 IF(SQC1.LT.1D-8) GOTO 220
10834 C1=SQRT(SQC1)
10835 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10836 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10837 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10838 PHIR=PARU(2)*PYR(0)
10839 CPHI=COS(PHIR)
10840 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10841 & SQRT(1D0-CTHE(2)**2)*CPHI
10842 Z1=2D0-Z(JT)
10843 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10844 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10845 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10846 & PMQ(3-JT)**2/SHP))
10847 ZMIN=2D0*PMQ(3-JT)/SHPR
10848 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10849 ZMAX=MIN(1D0-XH,ZMAX)
10850 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 220
10851 KCC=22
10852 KFRES=25
10853
10854 ELSEIF(ISUB.EQ.6) THEN
10855C...Z0 + W+/- -> W+/-
10856
10857 ELSEIF(ISUB.EQ.7) THEN
10858C...W+ + W- -> Z0
10859
10860 ELSEIF(ISUB.EQ.8) THEN
10861C...W+ + W- -> h0
10862 XH=SH/SHP
10863 230 DO 260 JT=1,2
10864 I=MINT(14+JT)
10865 IA=IABS(I)
10866 IF(IA.LE.10) THEN
10867 RVCKM=VINT(180+I)*PYR(0)
10868 DO 240 J=1,MSTP(1)
10869 IB=2*J-1+MOD(IA,2)
10870 IPM=(5-ISIGN(1,I))/2
10871 IDC=J+MDCY(IA,2)+2
10872 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 240
10873 MINT(20+JT)=ISIGN(IB,I)
10874 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10875 IF(RVCKM.LE.0D0) GOTO 250
10876 240 CONTINUE
10877 ELSE
10878 IB=2*((IA+1)/2)-1+MOD(IA,2)
10879 MINT(20+JT)=ISIGN(IB,I)
10880 ENDIF
10881 250 PMQ(JT)=PYMASS(MINT(20+JT))
10882 260 CONTINUE
10883 JT=INT(1.5D0+PYR(0))
10884 ZMIN=2D0*PMQ(JT)/SHPR
10885 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
10886 & (SHPR*(SHPR-PMQ(3-JT)))
10887 ZMAX=MIN(1D0-XH,ZMAX)
10888 IF(ZMIN.GE.ZMAX) GOTO 230
10889 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
10890 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
10891 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 230
10892 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
10893 IF(SQC1.LT.1D-8) GOTO 230
10894 C1=SQRT(SQC1)
10895 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
10896 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10897 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
10898 Z(3-JT)=1D0-XH/(1D0-Z(JT))
10899 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
10900 IF(SQC1.LT.1D-8) GOTO 230
10901 C1=SQRT(SQC1)
10902 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
10903 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
10904 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
10905 PHIR=PARU(2)*PYR(0)
10906 CPHI=COS(PHIR)
10907 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
10908 & SQRT(1D0-CTHE(2)**2)*CPHI
10909 Z1=2D0-Z(JT)
10910 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
10911 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
10912 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
10913 & PMQ(3-JT)**2/SHP))
10914 ZMIN=2D0*PMQ(3-JT)/SHPR
10915 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
10916 ZMAX=MIN(1D0-XH,ZMAX)
10917 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 230
10918 KCC=22
10919 KFRES=25
10920
10921 ELSEIF(ISUB.EQ.10) THEN
10922C...f + f' -> f + f' (gamma/Z/W exchange); th = (p(f)-p(f))**2
10923 IF(MINT(2).EQ.1) THEN
10924 KCC=22
10925 ELSE
10926C...W exchange: need to mix flavours according to CKM matrix
10927 DO 280 JT=1,2
10928 I=MINT(14+JT)
10929 IA=IABS(I)
10930 IF(IA.LE.10) THEN
10931 RVCKM=VINT(180+I)*PYR(0)
10932 DO 270 J=1,MSTP(1)
10933 IB=2*J-1+MOD(IA,2)
10934 IPM=(5-ISIGN(1,I))/2
10935 IDC=J+MDCY(IA,2)+2
10936 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 270
10937 MINT(20+JT)=ISIGN(IB,I)
10938 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
10939 IF(RVCKM.LE.0D0) GOTO 280
10940 270 CONTINUE
10941 ELSE
10942 IB=2*((IA+1)/2)-1+MOD(IA,2)
10943 MINT(20+JT)=ISIGN(IB,I)
10944 ENDIF
10945 280 CONTINUE
10946 KCC=22
10947 ENDIF
10948 ENDIF
10949
10950 ELSEIF(ISUB.LE.20) THEN
10951 IF(ISUB.EQ.11) THEN
10952C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
10953 KCC=MINT(2)
10954 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
10955
10956 ELSEIF(ISUB.EQ.12) THEN
10957C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
10958 MINT(21)=ISIGN(KFLF,MINT(15))
10959 MINT(22)=-MINT(21)
10960 KCC=4
10961
10962 ELSEIF(ISUB.EQ.13) THEN
10963C...f + fbar -> g + g; th arbitrary
10964 MINT(21)=21
10965 MINT(22)=21
10966 KCC=MINT(2)+4
10967
10968 ELSEIF(ISUB.EQ.14) THEN
10969C...f + fbar -> g + gamma; th arbitrary
10970 IF(PYR(0).GT.0.5D0) JS=2
10971 MINT(20+JS)=21
10972 MINT(23-JS)=22
10973 KCC=17+JS
10974
10975 ELSEIF(ISUB.EQ.15) THEN
10976C...f + fbar -> g + Z0; th arbitrary
10977 IF(PYR(0).GT.0.5D0) JS=2
10978 MINT(20+JS)=21
10979 MINT(23-JS)=23
10980 KCC=17+JS
10981
10982 ELSEIF(ISUB.EQ.16) THEN
10983C...f + fbar' -> g + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
10984 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
10985 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
10986 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
10987 MINT(20+JS)=21
10988 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
10989 KCC=17+JS
10990
10991 ELSEIF(ISUB.EQ.17) THEN
10992C...f + fbar -> g + h0; th arbitrary
10993 IF(PYR(0).GT.0.5D0) JS=2
10994 MINT(20+JS)=21
10995 MINT(23-JS)=25
10996 KCC=17+JS
10997
10998 ELSEIF(ISUB.EQ.18) THEN
10999C...f + fbar -> gamma + gamma; th arbitrary
11000 MINT(21)=22
11001 MINT(22)=22
11002
11003 ELSEIF(ISUB.EQ.19) THEN
11004C...f + fbar -> gamma + Z0; th arbitrary
11005 IF(PYR(0).GT.0.5D0) JS=2
11006 MINT(20+JS)=22
11007 MINT(23-JS)=23
11008
11009 ELSEIF(ISUB.EQ.20) THEN
11010C...f + fbar' -> gamma + W+/-; th = (p(f)-p(W-))**2 or
11011C...(p(fbar')-p(W+))**2
11012 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11013 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11014 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
11015 MINT(20+JS)=22
11016 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
11017 ENDIF
11018
11019 ELSEIF(ISUB.LE.30) THEN
11020 IF(ISUB.EQ.21) THEN
11021C...f + fbar -> gamma + h0; th arbitrary
11022 IF(PYR(0).GT.0.5D0) JS=2
11023 MINT(20+JS)=22
11024 MINT(23-JS)=25
11025
11026 ELSEIF(ISUB.EQ.22) THEN
11027C...f + fbar -> Z0 + Z0; th arbitrary
11028 MINT(21)=23
11029 MINT(22)=23
11030
11031 ELSEIF(ISUB.EQ.23) THEN
11032C...f + fbar' -> Z0 + W+/-; th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
11033 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11034 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11035 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
11036 MINT(20+JS)=23
11037 MINT(23-JS)=ISIGN(24,KCH1+KCH2)
11038
11039 ELSEIF(ISUB.EQ.24) THEN
11040C...f + fbar -> Z0 + h0 (or H0, or A0); th arbitrary
11041 IF(PYR(0).GT.0.5D0) JS=2
11042 MINT(20+JS)=23
11043 MINT(23-JS)=KFHIGG
11044
11045 ELSEIF(ISUB.EQ.25) THEN
11046C...f + fbar -> W+ + W-; th = (p(f)-p(W-))**2
11047 MINT(21)=-ISIGN(24,MINT(15))
11048 MINT(22)=-MINT(21)
11049
11050 ELSEIF(ISUB.EQ.26) THEN
11051C...f + fbar' -> W+/- + h0 (or H0, or A0);
11052C...th = (p(f)-p(W-))**2 or (p(fbar')-p(W+))**2
11053 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11054 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11055 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
11056 MINT(20+JS)=ISIGN(24,KCH1+KCH2)
11057 MINT(23-JS)=KFHIGG
11058
11059 ELSEIF(ISUB.EQ.27) THEN
11060C...f + fbar -> h0 + h0
11061
11062 ELSEIF(ISUB.EQ.28) THEN
11063C...f + g -> f + g; th = (p(f)-p(f))**2
11064 IF(MINT(15).EQ.21) JS=2
11065 KCC=MINT(2)+6
11066 IF(MINT(15).EQ.21) KCC=KCC+2
11067 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
11068 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
11069
11070 ELSEIF(ISUB.EQ.29) THEN
11071C...f + g -> f + gamma; th = (p(f)-p(f))**2
11072 IF(MINT(15).EQ.21) JS=2
11073 MINT(23-JS)=22
11074 KCC=15+JS
11075 KCS=ISIGN(1,MINT(14+JS))
11076
11077 ELSEIF(ISUB.EQ.30) THEN
11078C...f + g -> f + Z0; th = (p(f)-p(f))**2
11079 IF(MINT(15).EQ.21) JS=2
11080 MINT(23-JS)=23
11081 KCC=15+JS
11082 KCS=ISIGN(1,MINT(14+JS))
11083 ENDIF
11084
11085 ELSEIF(ISUB.LE.40) THEN
11086 IF(ISUB.EQ.31) THEN
11087C...f + g -> f' + W+/-; th = (p(f)-p(f'))**2; choose flavour f'
11088 IF(MINT(15).EQ.21) JS=2
11089 I=MINT(14+JS)
11090 IA=IABS(I)
11091 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11092 RVCKM=VINT(180+I)*PYR(0)
11093 DO 290 J=1,MSTP(1)
11094 IB=2*J-1+MOD(IA,2)
11095 IPM=(5-ISIGN(1,I))/2
11096 IDC=J+MDCY(IA,2)+2
11097 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 290
11098 MINT(20+JS)=ISIGN(IB,I)
11099 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11100 IF(RVCKM.LE.0D0) GOTO 300
11101 290 CONTINUE
11102 300 KCC=15+JS
11103 KCS=ISIGN(1,MINT(14+JS))
11104
11105 ELSEIF(ISUB.EQ.32) THEN
11106C...f + g -> f + h0; th = (p(f)-p(f))**2
11107 IF(MINT(15).EQ.21) JS=2
11108 MINT(23-JS)=25
11109 KCC=15+JS
11110 KCS=ISIGN(1,MINT(14+JS))
11111
11112 ELSEIF(ISUB.EQ.33) THEN
11113C...f + gamma -> f + g; th=(p(f)-p(f))**2
11114 IF(MINT(15).EQ.22) JS=2
11115 MINT(23-JS)=21
11116 KCC=24+JS
11117 KCS=ISIGN(1,MINT(14+JS))
11118
11119 ELSEIF(ISUB.EQ.34) THEN
11120C...f + gamma -> f + gamma; th=(p(f)-p(f))**2
11121 IF(MINT(15).EQ.22) JS=2
11122 KCC=22
11123 KCS=ISIGN(1,MINT(14+JS))
11124
11125 ELSEIF(ISUB.EQ.35) THEN
11126C...f + gamma -> f + Z0; th=(p(f)-p(f))**2
11127 IF(MINT(15).EQ.22) JS=2
11128 MINT(23-JS)=23
11129 KCC=22
11130
11131 ELSEIF(ISUB.EQ.36) THEN
11132C...f + gamma -> f' + W+/-; th=(p(f)-p(f'))**2
11133 IF(MINT(15).EQ.22) JS=2
11134 I=MINT(14+JS)
11135 IA=IABS(I)
11136 MINT(23-JS)=ISIGN(24,KCHG(IA,1)*I)
11137 IF(IA.LE.10) THEN
11138 RVCKM=VINT(180+I)*PYR(0)
11139 DO 310 J=1,MSTP(1)
11140 IB=2*J-1+MOD(IA,2)
11141 IPM=(5-ISIGN(1,I))/2
11142 IDC=J+MDCY(IA,2)+2
11143 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 310
11144 MINT(20+JS)=ISIGN(IB,I)
11145 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11146 IF(RVCKM.LE.0D0) GOTO 320
11147 310 CONTINUE
11148 ELSE
11149 IB=2*((IA+1)/2)-1+MOD(IA,2)
11150 MINT(20+JS)=ISIGN(IB,I)
11151 ENDIF
11152 320 KCC=22
11153
11154 ELSEIF(ISUB.EQ.37) THEN
11155C...f + gamma -> f + h0
11156
11157 ELSEIF(ISUB.EQ.38) THEN
11158C...f + Z0 -> f + g
11159
11160 ELSEIF(ISUB.EQ.39) THEN
11161C...f + Z0 -> f + gamma
11162
11163 ELSEIF(ISUB.EQ.40) THEN
11164C...f + Z0 -> f + Z0
11165 ENDIF
11166
11167 ELSEIF(ISUB.LE.50) THEN
11168 IF(ISUB.EQ.41) THEN
11169C...f + Z0 -> f' + W+/-
11170
11171 ELSEIF(ISUB.EQ.42) THEN
11172C...f + Z0 -> f + h0
11173
11174 ELSEIF(ISUB.EQ.43) THEN
11175C...f + W+/- -> f' + g
11176
11177 ELSEIF(ISUB.EQ.44) THEN
11178C...f + W+/- -> f' + gamma
11179
11180 ELSEIF(ISUB.EQ.45) THEN
11181C...f + W+/- -> f' + Z0
11182
11183 ELSEIF(ISUB.EQ.46) THEN
11184C...f + W+/- -> f' + W+/-
11185
11186 ELSEIF(ISUB.EQ.47) THEN
11187C...f + W+/- -> f' + h0
11188
11189 ELSEIF(ISUB.EQ.48) THEN
11190C...f + h0 -> f + g
11191
11192 ELSEIF(ISUB.EQ.49) THEN
11193C...f + h0 -> f + gamma
11194
11195 ELSEIF(ISUB.EQ.50) THEN
11196C...f + h0 -> f + Z0
11197 ENDIF
11198
11199 ELSEIF(ISUB.LE.60) THEN
11200 IF(ISUB.EQ.51) THEN
11201C...f + h0 -> f' + W+/-
11202
11203 ELSEIF(ISUB.EQ.52) THEN
11204C...f + h0 -> f + h0
11205
11206 ELSEIF(ISUB.EQ.53) THEN
11207C...g + g -> f + fbar; th arbitrary
11208 KCS=(-1)**INT(1.5D0+PYR(0))
11209 MINT(21)=ISIGN(KFLF,KCS)
11210 MINT(22)=-MINT(21)
11211 KCC=MINT(2)+10
11212
11213 ELSEIF(ISUB.EQ.54) THEN
11214C...g + gamma -> f + fbar; th arbitrary
11215 KCS=(-1)**INT(1.5D0+PYR(0))
11216 MINT(21)=ISIGN(KFLF,KCS)
11217 MINT(22)=-MINT(21)
11218 KCC=27
11219 IF(MINT(16).EQ.21) KCC=28
11220
11221 ELSEIF(ISUB.EQ.55) THEN
11222C...g + Z0 -> f + fbar
11223
11224 ELSEIF(ISUB.EQ.56) THEN
11225C...g + W+/- -> f + fbar'
11226
11227 ELSEIF(ISUB.EQ.57) THEN
11228C...g + h0 -> f + fbar
11229
11230 ELSEIF(ISUB.EQ.58) THEN
11231C...gamma + gamma -> f + fbar; th arbitrary
11232 KCS=(-1)**INT(1.5D0+PYR(0))
11233 MINT(21)=ISIGN(KFLF,KCS)
11234 MINT(22)=-MINT(21)
11235 KCC=21
11236
11237 ELSEIF(ISUB.EQ.59) THEN
11238C...gamma + Z0 -> f + fbar
11239
11240 ELSEIF(ISUB.EQ.60) THEN
11241C...gamma + W+/- -> f + fbar'
11242 ENDIF
11243
11244 ELSEIF(ISUB.LE.70) THEN
11245 IF(ISUB.EQ.61) THEN
11246C...gamma + h0 -> f + fbar
11247
11248 ELSEIF(ISUB.EQ.62) THEN
11249C...Z0 + Z0 -> f + fbar
11250
11251 ELSEIF(ISUB.EQ.63) THEN
11252C...Z0 + W+/- -> f + fbar'
11253
11254 ELSEIF(ISUB.EQ.64) THEN
11255C...Z0 + h0 -> f + fbar
11256
11257 ELSEIF(ISUB.EQ.65) THEN
11258C...W+ + W- -> f + fbar
11259
11260 ELSEIF(ISUB.EQ.66) THEN
11261C...W+/- + h0 -> f + fbar'
11262
11263 ELSEIF(ISUB.EQ.67) THEN
11264C...h0 + h0 -> f + fbar
11265
11266 ELSEIF(ISUB.EQ.68) THEN
11267C...g + g -> g + g; th arbitrary
11268 KCC=MINT(2)+12
11269 KCS=(-1)**INT(1.5D0+PYR(0))
11270
11271 ELSEIF(ISUB.EQ.69) THEN
11272C...gamma + gamma -> W+ + W-; th arbitrary
11273 MINT(21)=24
11274 MINT(22)=-24
11275 KCC=21
11276
11277 ELSEIF(ISUB.EQ.70) THEN
11278C...gamma + W+/- -> Z0 + W+/-; th=(p(W)-p(W))**2
11279 IF(MINT(15).EQ.22) MINT(21)=23
11280 IF(MINT(16).EQ.22) MINT(22)=23
11281 KCC=21
11282 ENDIF
11283
11284 ELSEIF(ISUB.LE.80) THEN
11285 IF(ISUB.EQ.71.OR.ISUB.EQ.72) THEN
11286C...Z0 + Z0 -> Z0 + Z0; Z0 + Z0 -> W+ + W-
11287 XH=SH/SHP
11288 MINT(21)=MINT(15)
11289 MINT(22)=MINT(16)
11290 PMQ(1)=PYMASS(MINT(21))
11291 PMQ(2)=PYMASS(MINT(22))
11292 330 JT=INT(1.5D0+PYR(0))
11293 ZMIN=2D0*PMQ(JT)/SHPR
11294 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11295 & (SHPR*(SHPR-PMQ(3-JT)))
11296 ZMAX=MIN(1D0-XH,ZMAX)
11297 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11298 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11299 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 330
11300 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11301 IF(SQC1.LT.1D-8) GOTO 330
11302 C1=SQRT(SQC1)
11303 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11304 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11305 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11306 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11307 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11308 IF(SQC1.LT.1D-8) GOTO 330
11309 C1=SQRT(SQC1)
11310 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11311 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11312 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11313 PHIR=PARU(2)*PYR(0)
11314 CPHI=COS(PHIR)
11315 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11316 & SQRT(1D0-CTHE(2)**2)*CPHI
11317 Z1=2D0-Z(JT)
11318 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11319 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11320 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11321 & PMQ(3-JT)**2/SHP))
11322 ZMIN=2D0*PMQ(3-JT)/SHPR
11323 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11324 ZMAX=MIN(1D0-XH,ZMAX)
11325 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 330
11326 KCC=22
11327
11328 ELSEIF(ISUB.EQ.73) THEN
11329C...Z0 + W+/- -> Z0 + W+/-
11330 JS=MINT(2)
11331 XH=SH/SHP
11332 340 JT=3-MINT(2)
11333 I=MINT(14+JT)
11334 IA=IABS(I)
11335 IF(IA.LE.10) THEN
11336 RVCKM=VINT(180+I)*PYR(0)
11337 DO 350 J=1,MSTP(1)
11338 IB=2*J-1+MOD(IA,2)
11339 IPM=(5-ISIGN(1,I))/2
11340 IDC=J+MDCY(IA,2)+2
11341 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 350
11342 MINT(20+JT)=ISIGN(IB,I)
11343 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11344 IF(RVCKM.LE.0D0) GOTO 360
11345 350 CONTINUE
11346 ELSE
11347 IB=2*((IA+1)/2)-1+MOD(IA,2)
11348 MINT(20+JT)=ISIGN(IB,I)
11349 ENDIF
11350 360 PMQ(JT)=PYMASS(MINT(20+JT))
11351 MINT(23-JT)=MINT(17-JT)
11352 PMQ(3-JT)=PYMASS(MINT(23-JT))
11353 JT=INT(1.5D0+PYR(0))
11354 ZMIN=2D0*PMQ(JT)/SHPR
11355 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11356 & (SHPR*(SHPR-PMQ(3-JT)))
11357 ZMAX=MIN(1D0-XH,ZMAX)
11358 IF(ZMIN.GE.ZMAX) GOTO 340
11359 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11360 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11361 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 340
11362 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11363 IF(SQC1.LT.1D-8) GOTO 340
11364 C1=SQRT(SQC1)
11365 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11366 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11367 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11368 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11369 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11370 IF(SQC1.LT.1D-8) GOTO 340
11371 C1=SQRT(SQC1)
11372 C2=1D0+2D0*(PMAS(23,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11373 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11374 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11375 PHIR=PARU(2)*PYR(0)
11376 CPHI=COS(PHIR)
11377 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11378 & SQRT(1D0-CTHE(2)**2)*CPHI
11379 Z1=2D0-Z(JT)
11380 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11381 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11382 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11383 & PMQ(3-JT)**2/SHP))
11384 ZMIN=2D0*PMQ(3-JT)/SHPR
11385 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11386 ZMAX=MIN(1D0-XH,ZMAX)
11387 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 340
11388 KCC=22
11389
11390 ELSEIF(ISUB.EQ.74) THEN
11391C...Z0 + h0 -> Z0 + h0
11392
11393 ELSEIF(ISUB.EQ.75) THEN
11394C...W+ + W- -> gamma + gamma
11395
11396 ELSEIF(ISUB.EQ.76.OR.ISUB.EQ.77) THEN
11397C...W+ + W- -> Z0 + Z0; W+ + W- -> W+ + W-
11398 XH=SH/SHP
11399 370 DO 400 JT=1,2
11400 I=MINT(14+JT)
11401 IA=IABS(I)
11402 IF(IA.LE.10) THEN
11403 RVCKM=VINT(180+I)*PYR(0)
11404 DO 380 J=1,MSTP(1)
11405 IB=2*J-1+MOD(IA,2)
11406 IPM=(5-ISIGN(1,I))/2
11407 IDC=J+MDCY(IA,2)+2
11408 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 380
11409 MINT(20+JT)=ISIGN(IB,I)
11410 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11411 IF(RVCKM.LE.0D0) GOTO 390
11412 380 CONTINUE
11413 ELSE
11414 IB=2*((IA+1)/2)-1+MOD(IA,2)
11415 MINT(20+JT)=ISIGN(IB,I)
11416 ENDIF
11417 390 PMQ(JT)=PYMASS(MINT(20+JT))
11418 400 CONTINUE
11419 JT=INT(1.5D0+PYR(0))
11420 ZMIN=2D0*PMQ(JT)/SHPR
11421 ZMAX=1D0-PMQ(3-JT)/SHPR-(SH-PMQ(JT)**2)/
11422 & (SHPR*(SHPR-PMQ(3-JT)))
11423 ZMAX=MIN(1D0-XH,ZMAX)
11424 IF(ZMIN.GE.ZMAX) GOTO 370
11425 Z(JT)=ZMIN+(ZMAX-ZMIN)*PYR(0)
11426 IF(-1D0+(1D0+XH)/(1D0-Z(JT))-XH/(1D0-Z(JT))**2.LT.
11427 & (1D0-XH)**2/(4D0*XH)*PYR(0)) GOTO 370
11428 SQC1=1D0-4D0*PMQ(JT)**2/(Z(JT)**2*SHP)
11429 IF(SQC1.LT.1D-8) GOTO 370
11430 C1=SQRT(SQC1)
11431 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(JT)**2)/(Z(JT)*SHP)
11432 CTHE(JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11433 CTHE(JT)=MIN(1D0,MAX(-1D0,CTHE(JT)))
11434 Z(3-JT)=1D0-XH/(1D0-Z(JT))
11435 SQC1=1D0-4D0*PMQ(3-JT)**2/(Z(3-JT)**2*SHP)
11436 IF(SQC1.LT.1D-8) GOTO 370
11437 C1=SQRT(SQC1)
11438 C2=1D0+2D0*(PMAS(24,1)**2-PMQ(3-JT)**2)/(Z(3-JT)*SHP)
11439 CTHE(3-JT)=(C2-(C2**2-C1**2)/(C2+(2D0*PYR(0)-1D0)*C1))/C1
11440 CTHE(3-JT)=MIN(1D0,MAX(-1D0,CTHE(3-JT)))
11441 PHIR=PARU(2)*PYR(0)
11442 CPHI=COS(PHIR)
11443 ANG=CTHE(1)*CTHE(2)-SQRT(1D0-CTHE(1)**2)*
11444 & SQRT(1D0-CTHE(2)**2)*CPHI
11445 Z1=2D0-Z(JT)
11446 Z2=ANG*SQRT(Z(JT)**2-4D0*PMQ(JT)**2/SHP)
11447 Z3=1D0-Z(JT)-XH+(PMQ(1)**2+PMQ(2)**2)/SHP
11448 Z(3-JT)=2D0/(Z1**2-Z2**2)*(Z1*Z3+Z2*SQRT(Z3**2-(Z1**2-Z2**2)*
11449 & PMQ(3-JT)**2/SHP))
11450 ZMIN=2D0*PMQ(3-JT)/SHPR
11451 ZMAX=1D0-PMQ(JT)/SHPR-(SH-PMQ(3-JT)**2)/(SHPR*(SHPR-PMQ(JT)))
11452 ZMAX=MIN(1D0-XH,ZMAX)
11453 IF(Z(3-JT).LT.ZMIN.OR.Z(3-JT).GT.ZMAX) GOTO 370
11454 KCC=22
11455
11456 ELSEIF(ISUB.EQ.78) THEN
11457C...W+/- + h0 -> W+/- + h0
11458
11459 ELSEIF(ISUB.EQ.79) THEN
11460C...h0 + h0 -> h0 + h0
11461
11462 ELSEIF(ISUB.EQ.80) THEN
11463C...q + gamma -> q' + pi+/-; th=(p(q)-p(q'))**2
11464 IF(MINT(15).EQ.22) JS=2
11465 I=MINT(14+JS)
11466 IA=IABS(I)
11467 MINT(23-JS)=ISIGN(211,KCHG(IA,1)*I)
11468 IB=3-IA
11469 MINT(20+JS)=ISIGN(IB,I)
11470 KCC=22
11471 ENDIF
11472
11473 ELSEIF(ISUB.LE.90) THEN
11474 IF(ISUB.EQ.81) THEN
11475C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2
11476 MINT(21)=ISIGN(MINT(55),MINT(15))
11477 MINT(22)=-MINT(21)
11478 KCC=4
11479
11480 ELSEIF(ISUB.EQ.82) THEN
11481C...g + g -> Q + Qbar; th arbitrary
11482 KCS=(-1)**INT(1.5D0+PYR(0))
11483 MINT(21)=ISIGN(MINT(55),KCS)
11484 MINT(22)=-MINT(21)
11485 KCC=MINT(2)+10
11486
11487 ELSEIF(ISUB.EQ.83) THEN
11488C...f + q -> f' + Q; th = (p(f) - p(f'))**2
11489 KFOLD=MINT(16)
11490 IF(MINT(2).EQ.2) KFOLD=MINT(15)
11491 KFAOLD=IABS(KFOLD)
11492 IF(KFAOLD.GT.10) THEN
11493 KFANEW=KFAOLD+2*MOD(KFAOLD,2)-1
11494 ELSE
11495 RCKM=VINT(180+KFOLD)*PYR(0)
11496 IPM=(5-ISIGN(1,KFOLD))/2
11497 KFANEW=-MOD(KFAOLD+1,2)
11498 410 KFANEW=KFANEW+2
11499 IDC=MDCY(KFAOLD,2)+(KFANEW+1)/2+2
11500 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.IPM) THEN
11501 IF(MOD(KFAOLD,2).EQ.0) RCKM=RCKM-
11502 & VCKM(KFAOLD/2,(KFANEW+1)/2)
11503 IF(MOD(KFAOLD,2).EQ.1) RCKM=RCKM-
11504 & VCKM(KFANEW/2,(KFAOLD+1)/2)
11505 ENDIF
11506 IF(KFANEW.LE.6.AND.RCKM.GT.0D0) GOTO 410
11507 ENDIF
11508 IF(MINT(2).EQ.1) THEN
11509 MINT(21)=ISIGN(MINT(55),MINT(15))
11510 MINT(22)=ISIGN(KFANEW,MINT(16))
11511 ELSE
11512 MINT(21)=ISIGN(KFANEW,MINT(15))
11513 MINT(22)=ISIGN(MINT(55),MINT(16))
11514 JS=2
11515 ENDIF
11516 KCC=22
11517
11518 ELSEIF(ISUB.EQ.84) THEN
11519C...g + gamma -> Q + Qbar; th arbitary
11520 KCS=(-1)**INT(1.5D0+PYR(0))
11521 MINT(21)=ISIGN(MINT(55),KCS)
11522 MINT(22)=-MINT(21)
11523 KCC=27
11524 IF(MINT(16).EQ.21) KCC=28
11525
11526 ELSEIF(ISUB.EQ.85) THEN
11527C...gamma + gamma -> F + Fbar; th arbitary
11528 KCS=(-1)**INT(1.5D0+PYR(0))
11529 MINT(21)=ISIGN(MINT(56),KCS)
11530 MINT(22)=-MINT(21)
11531 KCC=21
11532
11533 ELSEIF(ISUB.GE.86.AND.ISUB.LE.89) THEN
11534C...g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g
11535 MINT(21)=KFPR(ISUB,1)
11536 MINT(22)=KFPR(ISUB,2)
11537 KCC=24
11538 KCS=(-1)**INT(1.5D0+PYR(0))
11539 ENDIF
11540
11541 ELSEIF(ISUB.LE.100) THEN
11542 IF(ISUB.EQ.95) THEN
11543C...Low-pT ( = energyless g + g -> g + g)
11544 KCC=MINT(2)+12
11545 KCS=(-1)**INT(1.5D0+PYR(0))
11546
11547 ELSEIF(ISUB.EQ.96) THEN
11548C...Multiple interactions (should be reassigned to QCD process)
11549 ENDIF
11550
11551 ELSEIF(ISUB.LE.110) THEN
11552 IF(ISUB.EQ.101) THEN
11553C...g + g -> gamma*/Z0
11554 KCC=21
11555 KFRES=22
11556
11557 ELSEIF(ISUB.EQ.102) THEN
11558C...g + g -> h0 (or H0, or A0)
11559 KCC=21
11560 KFRES=KFHIGG
11561
11562 ELSEIF(ISUB.EQ.103) THEN
11563C...gamma + gamma -> h0 (or H0, or A0)
11564 KCC=21
11565 KFRES=KFHIGG
11566
11567 ELSEIF(ISUB.EQ.104.OR.ISUB.EQ.105) THEN
11568C...g + g -> chi_0c or chi_2c.
11569 KCC=21
11570 KFRES=KFPR(ISUB,1)
11571
11572 ELSEIF(ISUB.EQ.106) THEN
11573C...g + g -> J/Psi + gamma
11574 MINT(21)=KFPR(ISUB,1)
11575 MINT(22)=KFPR(ISUB,2)
11576 KCC=21
11577
11578 ELSEIF(ISUB.EQ.107) THEN
11579C...g + gamma -> J/Psi + g
11580 MINT(21)=KFPR(ISUB,1)
11581 MINT(22)=KFPR(ISUB,2)
11582 KCC=22
11583 IF(MINT(16).EQ.22) KCC=33
11584
11585 ELSEIF(ISUB.EQ.108) THEN
11586C...gamma + gamma -> J/Psi + gamma
11587 MINT(21)=KFPR(ISUB,1)
11588 MINT(22)=KFPR(ISUB,2)
11589
11590 ELSEIF(ISUB.EQ.110) THEN
11591C...f + fbar -> gamma + h0; th arbitrary
11592 IF(PYR(0).GT.0.5D0) JS=2
11593 MINT(20+JS)=22
11594 MINT(23-JS)=KFHIGG
11595 ENDIF
11596
11597 ELSEIF(ISUB.LE.120) THEN
11598 IF(ISUB.EQ.111) THEN
11599C...f + fbar -> g + h0; th arbitrary
11600 IF(PYR(0).GT.0.5D0) JS=2
11601 MINT(20+JS)=21
11602 MINT(23-JS)=KFHIGG
11603 KCC=17+JS
11604
11605 ELSEIF(ISUB.EQ.112) THEN
11606C...f + g -> f + h0; th = (p(f) - p(f))**2
11607 IF(MINT(15).EQ.21) JS=2
11608 MINT(23-JS)=KFHIGG
11609 KCC=15+JS
11610 KCS=ISIGN(1,MINT(14+JS))
11611
11612 ELSEIF(ISUB.EQ.113) THEN
11613C...g + g -> g + h0; th arbitrary
11614 IF(PYR(0).GT.0.5D0) JS=2
11615 MINT(23-JS)=KFHIGG
11616 KCC=22+JS
11617 KCS=(-1)**INT(1.5D0+PYR(0))
11618
11619 ELSEIF(ISUB.EQ.114) THEN
11620C...g + g -> gamma + gamma; th arbitrary
11621 IF(PYR(0).GT.0.5D0) JS=2
11622 MINT(21)=22
11623 MINT(22)=22
11624 KCC=21
11625
11626 ELSEIF(ISUB.EQ.115) THEN
11627C...g + g -> g + gamma; th arbitrary
11628 IF(PYR(0).GT.0.5D0) JS=2
11629 MINT(23-JS)=22
11630 KCC=22+JS
11631 KCS=(-1)**INT(1.5D0+PYR(0))
11632
11633 ELSEIF(ISUB.EQ.116) THEN
11634C...g + g -> gamma + Z0
11635
11636 ELSEIF(ISUB.EQ.117) THEN
11637C...g + g -> Z0 + Z0
11638
11639 ELSEIF(ISUB.EQ.118) THEN
11640C...g + g -> W+ + W-
11641 ENDIF
11642
11643 ELSEIF(ISUB.LE.140) THEN
11644 IF(ISUB.EQ.121) THEN
11645C...g + g -> Q + Qbar + h0
11646 KCS=(-1)**INT(1.5D0+PYR(0))
11647 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
11648 MINT(22)=-MINT(21)
11649 KCC=11+INT(0.5D0+PYR(0))
11650 KFRES=KFHIGG
11651
11652 ELSEIF(ISUB.EQ.122) THEN
11653C...q + qbar -> Q + Qbar + h0
11654 MINT(21)=ISIGN(KFPR(ISUBSV,2),MINT(15))
11655 MINT(22)=-MINT(21)
11656 KCC=4
11657 KFRES=KFHIGG
11658
11659 ELSEIF(ISUB.EQ.123) THEN
11660C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
11661C...inner process)
11662 KCC=22
11663 KFRES=KFHIGG
11664
11665 ELSEIF(ISUB.EQ.124) THEN
11666C...f + f' -> f" + f"' + h0 (or H0, or A) (W+ + W- -> h0 as
11667C...inner process)
11668 DO 430 JT=1,2
11669 I=MINT(14+JT)
11670 IA=IABS(I)
11671 IF(IA.LE.10) THEN
11672 RVCKM=VINT(180+I)*PYR(0)
11673 DO 420 J=1,MSTP(1)
11674 IB=2*J-1+MOD(IA,2)
11675 IPM=(5-ISIGN(1,I))/2
11676 IDC=J+MDCY(IA,2)+2
11677 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 420
11678 MINT(20+JT)=ISIGN(IB,I)
11679 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
11680 IF(RVCKM.LE.0D0) GOTO 430
11681 420 CONTINUE
11682 ELSE
11683 IB=2*((IA+1)/2)-1+MOD(IA,2)
11684 MINT(20+JT)=ISIGN(IB,I)
11685 ENDIF
11686 430 CONTINUE
11687 KCC=22
11688 KFRES=KFHIGG
11689
11690 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
11691C...f + gamma*_(T,L) -> f + g; th=(p(f)-p(f))**2
11692 IF(MINT(15).EQ.22) JS=2
11693 MINT(23-JS)=21
11694 KCC=24+JS
11695 KCS=ISIGN(1,MINT(14+JS))
11696
11697 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
11698C...f + gamma*_(T,L) -> f + gamma; th=(p(f)-p(f))**2
11699 IF(MINT(15).EQ.22) JS=2
11700 KCC=22
11701 KCS=ISIGN(1,MINT(14+JS))
11702
11703 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
11704C...g + gamma*_(T,L) -> f + fbar; th arbitrary
11705 KCS=(-1)**INT(1.5D0+PYR(0))
11706 MINT(21)=ISIGN(KFLF,KCS)
11707 MINT(22)=-MINT(21)
11708 KCC=27
11709 IF(MINT(16).EQ.21) KCC=28
11710
11711 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
11712C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar; th arbitrary
11713 KCS=(-1)**INT(1.5D0+PYR(0))
11714 MINT(21)=ISIGN(KFLF,KCS)
11715 MINT(22)=-MINT(21)
11716 KCC=21
11717
11718 ENDIF
11719
11720 ELSEIF(ISUB.LE.160) THEN
11721 IF(ISUB.EQ.141) THEN
11722C...f + fbar -> gamma*/Z0/Z'0
11723 KFRES=32
11724
11725 ELSEIF(ISUB.EQ.142) THEN
11726C...f + fbar' -> W'+/-
11727 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11728 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11729 KFRES=ISIGN(34,KCH1+KCH2)
11730
11731 ELSEIF(ISUB.EQ.143) THEN
11732C...f + fbar' -> H+/-
11733 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11734 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11735 KFRES=ISIGN(37,KCH1+KCH2)
11736
11737 ELSEIF(ISUB.EQ.144) THEN
11738C...f + fbar' -> R
11739 KFRES=ISIGN(41,MINT(15)+MINT(16))
11740
11741 ELSEIF(ISUB.EQ.145) THEN
11742C...q + l -> LQ (leptoquark)
11743 IF(IABS(MINT(16)).LE.8) JS=2
11744 KFRES=ISIGN(42,MINT(14+JS))
11745 KCC=28+JS
11746 KCS=ISIGN(1,MINT(14+JS))
11747
11748 ELSEIF(ISUB.EQ.146) THEN
11749C...e + gamma -> e* (excited lepton)
11750 IF(MINT(15).EQ.22) JS=2
11751 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11752 KCC=22
11753
11754 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
11755C...q + g -> q* (excited quark)
11756 IF(MINT(15).EQ.21) JS=2
11757 KFRES=ISIGN(KFPR(ISUB,1),MINT(14+JS))
11758 KCC=30+JS
11759 KCS=ISIGN(1,MINT(14+JS))
11760
11761 ELSEIF(ISUB.EQ.149) THEN
11762C...g + g -> eta_tc
11763 KFRES=KTECHN+331
11764 KCC=23
11765 KCS=(-1)**INT(1.5D0+PYR(0))
11766 ENDIF
11767
11768 ELSEIF(ISUB.LE.200) THEN
11769 IF(ISUB.EQ.161) THEN
11770C...f + g -> f' + H+/-; th = (p(f)-p(f'))**2
11771 IF(MINT(15).EQ.21) JS=2
11772 I=MINT(14+JS)
11773 IA=IABS(I)
11774 MINT(23-JS)=ISIGN(37,KCHG(IA,1)*I)
11775 IB=IA+MOD(IA,2)-MOD(IA+1,2)
11776 MINT(20+JS)=ISIGN(IB,I)
11777 KCC=15+JS
11778 KCS=ISIGN(1,MINT(14+JS))
11779
11780 ELSEIF(ISUB.EQ.162) THEN
11781C...q + g -> LQ + lbar; LQ=leptoquark; th=(p(q)-p(LQ))^2
11782 IF(MINT(15).EQ.21) JS=2
11783 MINT(20+JS)=ISIGN(42,MINT(14+JS))
11784 KFLQL=KFDP(MDCY(42,2),2)
11785 MINT(23-JS)=-ISIGN(KFLQL,MINT(14+JS))
11786 KCC=15+JS
11787 KCS=ISIGN(1,MINT(14+JS))
11788
11789 ELSEIF(ISUB.EQ.163) THEN
11790C...g + g -> LQ + LQbar; LQ=leptoquark; th arbitrary
11791 KCS=(-1)**INT(1.5D0+PYR(0))
11792 MINT(21)=ISIGN(42,KCS)
11793 MINT(22)=-MINT(21)
11794 KCC=MINT(2)+10
11795
11796 ELSEIF(ISUB.EQ.164) THEN
11797C...q + qbar -> LQ + LQbar; LQ=leptoquark; th=(p(q)-p(LQ))**2
11798 MINT(21)=ISIGN(42,MINT(15))
11799 MINT(22)=-MINT(21)
11800 KCC=4
11801
11802 ELSEIF(ISUB.EQ.165) THEN
11803C...q + qbar -> l- + l+; th=(p(q)-p(l-))**2
11804 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11805 MINT(22)=-MINT(21)
11806
11807 ELSEIF(ISUB.EQ.166) THEN
11808C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11809 IF(MOD(MINT(15),2).EQ.0) THEN
11810 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11811 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11812 ELSE
11813 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11814 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11815 ENDIF
11816
11817 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
11818C...q + q' -> q" + q* (excited quark)
11819 KFQSTR=KFPR(ISUB,2)
11820 KFQEXC=MOD(KFQSTR,KEXCIT)
11821 JS=MINT(2)
11822 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11823 IF(IABS(MINT(15)).NE.KFQEXC.AND.IABS(MINT(16)).NE.KFQEXC)
11824 & MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11825 KCC=22
11826 JS=3-JS
11827
11828 ELSEIF(ISUB.EQ.169) THEN
11829C...q + qbar -> e + e* (excited lepton)
11830 KFQSTR=KFPR(ISUB,2)
11831 KFQEXC=MOD(KFQSTR,KEXCIT)
11832 JS=MINT(2)
11833 MINT(20+JS)=ISIGN(KFQSTR,MINT(14+JS))
11834 MINT(23-JS)=ISIGN(KFQEXC,MINT(17-JS))
11835 JS=3-JS
11836
11837 ELSEIF(ISUB.EQ.191) THEN
11838C...f + fbar -> rho_tc0.
11839 KFRES=KTECHN+113
11840
11841 ELSEIF(ISUB.EQ.192) THEN
11842C...f + fbar' -> rho_tc+/-
11843 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11844 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11845 KFRES=ISIGN(KTECHN+213,KCH1+KCH2)
11846
11847 ELSEIF(ISUB.EQ.193) THEN
11848C...f + fbar -> omega_tc0.
11849 KFRES=KTECHN+223
11850
11851 ELSEIF(ISUB.EQ.194) THEN
11852C...f + fbar -> f' + fbar' via mixture of s-channel
11853C...rho_tc and omega_tc; th=(p(f)-p(f'))**2
11854 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11855 MINT(22)=-MINT(21)
11856
11857 ELSEIF(ISUB.EQ.195) THEN
11858C...f + fbar' -> f'' + fbar''' via s-channel
11859C...rho_tc+ th=(p(f)-p(f'))**2
11860C...q + qbar' -> l + nu; th=(p(u)-p(nu))**2 or (p(ubar)-p(nubar))**2
11861 IF(MOD(MINT(15),2).EQ.0) THEN
11862 MINT(21)=ISIGN(KFPR(ISUB,1)+1,MINT(15))
11863 MINT(22)=ISIGN(KFPR(ISUB,1),MINT(16))
11864 ELSE
11865 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
11866 MINT(22)=ISIGN(KFPR(ISUB,1)+1,MINT(16))
11867 ENDIF
11868 ENDIF
11869
11870CMRENNA++
11871 ELSEIF(ISUB.LE.215) THEN
11872 IF(ISUB.EQ.201) THEN
11873C...f + fbar -> ~e_L + ~e_Lbar
11874 MINT(21)=ISIGN(KSUSY1+11,KCS)
11875 MINT(22)=-MINT(21)
11876
11877 ELSEIF(ISUB.EQ.202) THEN
11878C...f + fbar -> ~e_R + ~e_Rbar
11879 MINT(21)=ISIGN(KSUSY2+11,KCS)
11880 MINT(22)=-MINT(21)
11881
11882 ELSEIF(ISUB.EQ.203) THEN
11883C...f + fbar -> ~e_L + ~e_Rbar
11884 IF(MINT(15).LT.0) JS=2
11885 IF(MINT(2).EQ.1) THEN
11886 MINT(20+JS)=KFPR(ISUB,1)
11887 MINT(23-JS)=-KFPR(ISUB,2)
11888 ELSE
11889 MINT(20+JS)=-KFPR(ISUB,1)
11890 MINT(23-JS)=KFPR(ISUB,2)
11891 ENDIF
11892
11893 ELSEIF(ISUB.EQ.204) THEN
11894C...f + fbar -> ~mu_L + ~mu_Lbar
11895 MINT(21)=ISIGN(KSUSY1+13,KCS)
11896 MINT(22)=-MINT(21)
11897
11898 ELSEIF(ISUB.EQ.205) THEN
11899C...f + fbar -> ~mu_R + ~mu_Rbar
11900 MINT(21)=ISIGN(KSUSY2+13,KCS)
11901 MINT(22)=-MINT(21)
11902
11903 ELSEIF(ISUB.EQ.206) THEN
11904C...f + fbar -> ~mu_L + ~mu_Rbar
11905 IF(MINT(15).LT.0) JS=2
11906 IF(MINT(2).EQ.1) THEN
11907 MINT(20+JS)=KFPR(ISUB,1)
11908 MINT(23-JS)=-KFPR(ISUB,2)
11909 ELSE
11910 MINT(20+JS)=-KFPR(ISUB,1)
11911 MINT(23-JS)=KFPR(ISUB,2)
11912 ENDIF
11913
11914 ELSEIF(ISUB.EQ.207) THEN
11915C...f + fbar -> ~tau_1 + ~tau_1bar
11916 MINT(21)=ISIGN(KSUSY1+15,KCS)
11917 MINT(22)=-MINT(21)
11918
11919 ELSEIF(ISUB.EQ.208) THEN
11920C...f + fbar -> ~tau_2 + ~tau_2bar
11921 MINT(21)=ISIGN(KSUSY2+15,KCS)
11922 MINT(22)=-MINT(21)
11923
11924 ELSEIF(ISUB.EQ.209) THEN
11925C...f + fbar -> ~tau_1 + ~tau_2bar
11926 IF(MINT(15).LT.0) JS=2
11927 IF(MINT(2).EQ.1) THEN
11928 MINT(20+JS)=KFPR(ISUB,1)
11929 MINT(23-JS)=-KFPR(ISUB,2)
11930 ELSE
11931 MINT(20+JS)=-KFPR(ISUB,1)
11932 MINT(23-JS)=KFPR(ISUB,2)
11933 ENDIF
11934
11935 ELSEIF(ISUB.EQ.210) THEN
11936C...q + qbar' -> ~l_L + ~nulbar; th arbitrary
11937 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11938 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11939 MINT(21)=-ISIGN(KFPR(ISUB,1),KCH1+KCH2)
11940 MINT(22)=ISIGN(KFPR(ISUB,2),KCH1+KCH2)
11941
11942 ELSEIF(ISUB.EQ.211) THEN
11943C...q + qbar'-> ~tau_1 + ~nutaubar; th arbitrary
11944 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11945 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11946 MINT(21)=-ISIGN(KSUSY1+15,KCH1+KCH2)
11947 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11948
11949 ELSEIF(ISUB.EQ.212) THEN
11950C...q + qbar'-> ~tau_2 + ~nutaubar; th arbitrary
11951 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
11952 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
11953 MINT(21)=-ISIGN(KSUSY2+15,KCH1+KCH2)
11954 MINT(22)=ISIGN(KSUSY1+16,KCH1+KCH2)
11955
11956 ELSEIF(ISUB.EQ.213) THEN
11957C...f + fbar -> ~nul + ~nulbar
11958 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
11959 MINT(22)=-MINT(21)
11960
11961 ELSEIF(ISUB.EQ.214) THEN
11962C...f + fbar -> ~nutau + ~nutaubar
11963 MINT(21)=ISIGN(KSUSY1+16,KCS)
11964 MINT(22)=-MINT(21)
11965 ENDIF
11966
11967 ELSEIF(ISUB.LE.225) THEN
11968 IF(ISUB.EQ.216) THEN
11969C...f + fbar -> ~chi01 + ~chi01
11970 MINT(21)=KSUSY1+22
11971 MINT(22)=KSUSY1+22
11972
11973 ELSEIF(ISUB.EQ.217) THEN
11974C...f + fbar -> ~chi02 + ~chi02
11975 MINT(21)=KSUSY1+23
11976 MINT(22)=KSUSY1+23
11977
11978 ELSEIF(ISUB.EQ.218 ) THEN
11979C...f + fbar -> ~chi03 + ~chi03
11980 MINT(21)=KSUSY1+25
11981 MINT(22)=KSUSY1+25
11982
11983 ELSEIF(ISUB.EQ.219 ) THEN
11984C...f + fbar -> ~chi04 + ~chi04
11985 MINT(21)=KSUSY1+35
11986 MINT(22)=KSUSY1+35
11987
11988 ELSEIF(ISUB.EQ.220 ) THEN
11989C...f + fbar -> ~chi01 + ~chi02
11990 IF(MINT(15).LT.0) JS=2
11991C IF(PYR(0).GT.0.5D0) JS=2
11992 MINT(20+JS)=KSUSY1+22
11993 MINT(23-JS)=KSUSY1+23
11994
11995 ELSEIF(ISUB.EQ.221 ) THEN
11996C...f + fbar -> ~chi01 + ~chi03
11997 IF(MINT(15).LT.0) JS=2
11998C IF(PYR(0).GT.0.5D0) JS=2
11999 MINT(20+JS)=KSUSY1+22
12000 MINT(23-JS)=KSUSY1+25
12001
12002 ELSEIF(ISUB.EQ.222) THEN
12003C...f + fbar -> ~chi01 + ~chi04
12004 IF(MINT(15).LT.0) JS=2
12005C IF(PYR(0).GT.0.5D0) JS=2
12006 MINT(20+JS)=KSUSY1+22
12007 MINT(23-JS)=KSUSY1+35
12008
12009 ELSEIF(ISUB.EQ.223) THEN
12010C...f + fbar -> ~chi02 + ~chi03
12011 IF(MINT(15).LT.0) JS=2
12012C IF(PYR(0).GT.0.5D0) JS=2
12013 MINT(20+JS)=KSUSY1+23
12014 MINT(23-JS)=KSUSY1+25
12015
12016 ELSEIF(ISUB.EQ.224) THEN
12017C...f + fbar -> ~chi02 + ~chi04
12018 IF(MINT(15).LT.0) JS=2
12019C IF(PYR(0).GT.0.5D0) JS=2
12020 MINT(20+JS)=KSUSY1+23
12021 MINT(23-JS)=KSUSY1+35
12022
12023 ELSEIF(ISUB.EQ.225) THEN
12024C...f + fbar -> ~chi03 + ~chi04
12025 IF(MINT(15).LT.0) JS=2
12026C IF(PYR(0).GT.0.5D0) JS=2
12027 MINT(20+JS)=KSUSY1+25
12028 MINT(23-JS)=KSUSY1+35
12029 ENDIF
12030
12031 ELSEIF(ISUB.LE.236) THEN
12032 IF(ISUB.EQ.226) THEN
12033C...f + fbar -> ~chi+-1 + ~chi-+1
12034C...th=(p(q)-p(chi+))**2 or (p(qbar)-p(chi-))**2
12035 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12036 MINT(21)=ISIGN(KSUSY1+24,KCH1)
12037 MINT(22)=-MINT(21)
12038
12039 ELSEIF(ISUB.EQ.227) THEN
12040C...f + fbar -> ~chi+-2 + ~chi-+2
12041 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12042 MINT(21)=ISIGN(KSUSY1+37,KCH1)
12043 MINT(22)=-MINT(21)
12044
12045 ELSEIF(ISUB.EQ.228) THEN
12046C...f + fbar -> ~chi+-1 + ~chi-+2
12047C...th=(p(q)-p(chi1+))**2 or th=(p(qbar)-p(chi1-))**2
12048C...js=1 if pyr<.5, js=2 if pyr>.5
12049C...if 15=q, 16=qbar and js=1, chi1+ + chi2-, th=(q-chi1+)**2
12050C...if 15=qbar, 16=q and js=1, chi2- + chi1+, th=(q-chi1+)**2
12051C...if 15=q, 16=qbar and js=2, chi1- + chi2+, th=(qbar-chi1-)**2
12052C...if 15=qbar, 16=q and js=2, chi2+ + chi1-, th=(q-chi1-)**2
12053 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12054 KCH2=INT(1-KCH1)/2
12055 IF(MINT(2).EQ.1) THEN
12056 MINT(21)= ISIGN(KSUSY1+24,KCH1)
12057 MINT(22)= -ISIGN(KSUSY1+37,KCH1)
12058c IF(KCH2.EQ.0) JS=2
12059 ELSE
12060 MINT(21)= ISIGN(KSUSY1+37,KCH1)
12061 MINT(22)= -ISIGN(KSUSY1+24,KCH1)
12062 JS=2
12063c IF(KCH2.EQ.1) JS=2
12064 ENDIF
12065
12066 ELSEIF(ISUB.EQ.229) THEN
12067C...q + qbar' -> ~chi01 + ~chi+-1
12068C...th=(p(u)-p(chi+))**2 or (p(ubar)-p(chi-))**2
12069 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12070 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12071C...CHECK THIS
12072 IF(MOD(MINT(15),2).EQ.0) JS=2
12073 MINT(20+JS)=KSUSY1+22
12074 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12075
12076 ELSEIF(ISUB.EQ.230) THEN
12077C...q + qbar' -> ~chi02 + ~chi+-1
12078 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12079 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12080 IF(MOD(MINT(15),2).EQ.0) JS=2
12081 MINT(20+JS)=KSUSY1+23
12082 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12083
12084 ELSEIF(ISUB.EQ.231) THEN
12085C...q + qbar' -> ~chi03 + ~chi+-1
12086 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12087 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12088 IF(MOD(MINT(15),2).EQ.0) JS=2
12089 MINT(20+JS)=KSUSY1+25
12090 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12091
12092 ELSEIF(ISUB.EQ.232) THEN
12093C...q + qbar' -> ~chi04 + ~chi+-1
12094 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12095 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12096 IF(MOD(MINT(15),2).EQ.0) JS=2
12097 MINT(20+JS)=KSUSY1+35
12098 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12099
12100 ELSEIF(ISUB.EQ.233) THEN
12101C...q + qbar' -> ~chi01 + ~chi+-2
12102 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12103 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12104 IF(MOD(MINT(15),2).EQ.0) JS=2
12105 MINT(20+JS)=KSUSY1+22
12106 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12107
12108 ELSEIF(ISUB.EQ.234) THEN
12109C...q + qbar' -> ~chi02 + ~chi+-2
12110 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12111 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12112 IF(MOD(MINT(15),2).EQ.0) JS=2
12113 MINT(20+JS)=KSUSY1+23
12114 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12115
12116 ELSEIF(ISUB.EQ.235) THEN
12117C...q + qbar' -> ~chi03 + ~chi+-2
12118 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12119 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12120 IF(MOD(MINT(15),2).EQ.0) JS=2
12121 MINT(20+JS)=KSUSY1+25
12122 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12123
12124 ELSEIF(ISUB.EQ.236) THEN
12125C...q + qbar' -> ~chi04 + ~chi+-2
12126 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12127 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12128 IF(MOD(MINT(15),2).EQ.0) JS=2
12129 MINT(20+JS)=KSUSY1+35
12130 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12131 ENDIF
12132
12133 ELSEIF(ISUB.LE.245) THEN
12134 IF(ISUB.EQ.237) THEN
12135C...q + qbar -> ~chi01 + ~g
12136C...th arbitrary
12137 IF(PYR(0).GT.0.5D0) JS=2
12138 MINT(20+JS)=KSUSY1+21
12139 MINT(23-JS)=KSUSY1+22
12140 KCC=17+JS
12141
12142 ELSEIF(ISUB.EQ.238) THEN
12143C...q + qbar -> ~chi02 + ~g
12144C...th arbitrary
12145 IF(PYR(0).GT.0.5D0) JS=2
12146 MINT(20+JS)=KSUSY1+21
12147 MINT(23-JS)=KSUSY1+23
12148 KCC=17+JS
12149
12150 ELSEIF(ISUB.EQ.239) THEN
12151C...q + qbar -> ~chi03 + ~g
12152C...th arbitrary
12153 IF(PYR(0).GT.0.5D0) JS=2
12154 MINT(20+JS)=KSUSY1+21
12155 MINT(23-JS)=KSUSY1+25
12156 KCC=17+JS
12157
12158 ELSEIF(ISUB.EQ.240) THEN
12159C...q + qbar -> ~chi04 + ~g
12160C...th arbitrary
12161 IF(PYR(0).GT.0.5D0) JS=2
12162 MINT(20+JS)=KSUSY1+21
12163 MINT(23-JS)=KSUSY1+35
12164 KCC=17+JS
12165
12166 ELSEIF(ISUB.EQ.241) THEN
12167C...q + qbar' -> ~chi+-1 + ~g
12168C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12169C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12170C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12171C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12172C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12173 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12174 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12175 JS=1
12176 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12177 MINT(20+JS)=KSUSY1+21
12178 MINT(23-JS)=ISIGN(KSUSY1+24,KCH1+KCH2)
12179 KCC=17+JS
12180
12181 ELSEIF(ISUB.EQ.242) THEN
12182C...q + qbar' -> ~chi+-2 + ~g
12183C...if 15=u, 16=dbar, then (kch1+kch2)>0, js=1, chi+
12184C...if 15=d, 16=ubar, then (kch1+kch2)<0, js=2, chi-
12185C...if 15=ubar, 16=d, then (kch1+kch2)<0, js=1, chi-
12186C...if 15=dbar, 16=u, then (kch1+kch2)>0, js=2, chi+
12187C...th=(p(q)-p(chi+))**2 or (p(qbar')-p(chi-))**2
12188 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12189 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12190 JS=1
12191 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12192 MINT(20+JS)=KSUSY1+21
12193 MINT(23-JS)=ISIGN(KSUSY1+37,KCH1+KCH2)
12194 KCC=17+JS
12195
12196 ELSEIF(ISUB.EQ.243) THEN
12197C...q + qbar -> ~g + ~g ; th arbitrary
12198 MINT(21)=KSUSY1+21
12199 MINT(22)=KSUSY1+21
12200 KCC=MINT(2)+4
12201
12202 ELSEIF(ISUB.EQ.244) THEN
12203C...g + g -> ~g + ~g ; th arbitrary
12204 KCC=MINT(2)+12
12205 KCS=(-1)**INT(1.5D0+PYR(0))
12206 MINT(21)=KSUSY1+21
12207 MINT(22)=KSUSY1+21
12208 ENDIF
12209
12210 ELSEIF(ISUB.LE.260) THEN
12211 IF(ISUB.EQ.246) THEN
12212C...qj + g -> ~qj_L + ~chi01
12213 IF(MINT(15).EQ.21) JS=2
12214 I=MINT(14+JS)
12215 IA=IABS(I)
12216 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12217 MINT(23-JS)=KSUSY1+22
12218 KCC=15+JS
12219 KCS=ISIGN(1,MINT(14+JS))
12220
12221 ELSEIF(ISUB.EQ.247) THEN
12222C...qj + g -> ~qj_R + ~chi01
12223 IF(MINT(15).EQ.21) JS=2
12224 I=MINT(14+JS)
12225 IA=IABS(I)
12226 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12227 MINT(23-JS)=KSUSY1+22
12228 KCC=15+JS
12229 KCS=ISIGN(1,MINT(14+JS))
12230
12231 ELSEIF(ISUB.EQ.248) THEN
12232C...qj + g -> ~qj_L + ~chi02
12233 IF(MINT(15).EQ.21) JS=2
12234 I=MINT(14+JS)
12235 IA=IABS(I)
12236 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12237 MINT(23-JS)=KSUSY1+23
12238 KCC=15+JS
12239 KCS=ISIGN(1,MINT(14+JS))
12240
12241 ELSEIF(ISUB.EQ.249) THEN
12242C...qj + g -> ~qj_R + ~chi02
12243 IF(MINT(15).EQ.21) JS=2
12244 I=MINT(14+JS)
12245 IA=IABS(I)
12246 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12247 MINT(23-JS)=KSUSY1+23
12248 KCC=15+JS
12249 KCS=ISIGN(1,MINT(14+JS))
12250
12251 ELSEIF(ISUB.EQ.250) THEN
12252C...qj + g -> ~qj_L + ~chi03
12253 IF(MINT(15).EQ.21) JS=2
12254 I=MINT(14+JS)
12255 IA=IABS(I)
12256 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12257 MINT(23-JS)=KSUSY1+25
12258 KCC=15+JS
12259 KCS=ISIGN(1,MINT(14+JS))
12260
12261 ELSEIF(ISUB.EQ.251) THEN
12262C...qj + g -> ~qj_R + ~chi03
12263 IF(MINT(15).EQ.21) JS=2
12264 I=MINT(14+JS)
12265 IA=IABS(I)
12266 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12267 MINT(23-JS)=KSUSY1+25
12268 KCC=15+JS
12269 KCS=ISIGN(1,MINT(14+JS))
12270
12271 ELSEIF(ISUB.EQ.252) THEN
12272C...qj + g -> ~qj_L + ~chi04
12273 IF(MINT(15).EQ.21) JS=2
12274 I=MINT(14+JS)
12275 IA=IABS(I)
12276 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12277 MINT(23-JS)=KSUSY1+35
12278 KCC=15+JS
12279 KCS=ISIGN(1,MINT(14+JS))
12280
12281 ELSEIF(ISUB.EQ.253) THEN
12282C...qj + g -> ~qj_R + ~chi04
12283 IF(MINT(15).EQ.21) JS=2
12284 I=MINT(14+JS)
12285 IA=IABS(I)
12286 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12287 MINT(23-JS)=KSUSY1+35
12288 KCC=15+JS
12289 KCS=ISIGN(1,MINT(14+JS))
12290
12291 ELSEIF(ISUB.EQ.254) THEN
12292C...qj + g -> ~qk_L + ~chi+-1
12293 IF(MINT(15).EQ.21) JS=2
12294 I=MINT(14+JS)
12295 IA=IABS(I)
12296 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12297 IB=-IA+INT((IA+1)/2)*4-1
12298 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12299 KCC=15+JS
12300 KCS=ISIGN(1,MINT(14+JS))
12301
12302 ELSEIF(ISUB.EQ.255) THEN
12303C...qj + g -> ~qk_L + ~chi+-1
12304 IF(MINT(15).EQ.21) JS=2
12305 I=MINT(14+JS)
12306 IA=IABS(I)
12307 MINT(23-JS)=ISIGN(KSUSY1+24,KCHG(IA,1)*I)
12308 IB=-IA+INT((IA+1)/2)*4-1
12309 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12310 KCC=15+JS
12311 KCS=ISIGN(1,MINT(14+JS))
12312
12313 ELSEIF(ISUB.EQ.256) THEN
12314C...qj + g -> ~qk_L + ~chi+-2
12315 IF(MINT(15).EQ.21) JS=2
12316 I=MINT(14+JS)
12317 IA=IABS(I)
12318 IB=-IA+INT((IA+1)/2)*4-1
12319 MINT(20+JS)=ISIGN(KSUSY1+IB,I)
12320 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12321 KCC=15+JS
12322 KCS=ISIGN(1,MINT(14+JS))
12323
12324 ELSEIF(ISUB.EQ.257) THEN
12325C...qj + g -> ~qk_R + ~chi+-2
12326 IF(MINT(15).EQ.21) JS=2
12327 I=MINT(14+JS)
12328 IA=IABS(I)
12329 IB=-IA+INT((IA+1)/2)*4-1
12330 MINT(20+JS)=ISIGN(KSUSY2+IB,I)
12331 MINT(23-JS)=ISIGN(KSUSY1+37,KCHG(IA,1)*I)
12332 KCC=15+JS
12333 KCS=ISIGN(1,MINT(14+JS))
12334
12335 ELSEIF(ISUB.EQ.258) THEN
12336C...qj + g -> ~qj_L + ~g
12337 IF(MINT(15).EQ.21) JS=2
12338 I=MINT(14+JS)
12339 IA=IABS(I)
12340 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12341 MINT(23-JS)=KSUSY1+21
12342 KCC=MINT(2)+6
12343 IF(JS.EQ.2) KCC=KCC+2
12344 KCS=ISIGN(1,I)
12345
12346 ELSEIF(ISUB.EQ.259) THEN
12347C...qj + g -> ~qj_R + ~g
12348 IF(MINT(15).EQ.21) JS=2
12349 I=MINT(14+JS)
12350 IA=IABS(I)
12351 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12352 MINT(23-JS)=KSUSY1+21
12353 KCC=MINT(2)+6
12354 IF(JS.EQ.2) KCC=KCC+2
12355 KCS=ISIGN(1,I)
12356 ENDIF
12357
12358 ELSEIF(ISUB.LE.270) THEN
12359 IF(ISUB.EQ.261) THEN
12360C...f + fbar -> ~t_1 + ~t_1bar; th = (p(q)-p(sq))**2
12361 ISGN=1
12362 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12363 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12364 MINT(22)=-MINT(21)
12365C...Correct color combination
12366 IF(MINT(43).EQ.4) KCC=4
12367
12368 ELSEIF(ISUB.EQ.262) THEN
12369C...f + fbar -> ~t_2 + ~t_2bar; th = (p(q)-p(sq))**2
12370 ISGN=1
12371 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12372 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12373 MINT(22)=-MINT(21)
12374C...Correct color combination
12375 IF(MINT(43).EQ.4) KCC=4
12376
12377 ELSEIF(ISUB.EQ.263) THEN
12378C...f + fbar -> ~t_1 + ~t_2bar; th = (p(q)-p(sq))**2
12379 IF((KCS.GT.0.AND.MINT(2).EQ.1).OR.
12380 & (KCS.LT.0.AND.MINT(2).EQ.2)) THEN
12381 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12382 MINT(22)=-ISIGN(KFPR(ISUB,2),KCS)
12383 ELSE
12384 JS=2
12385 MINT(21)=ISIGN(KFPR(ISUB,2),KCS)
12386 MINT(22)=-ISIGN(KFPR(ISUB,1),KCS)
12387 ENDIF
12388C...Correct color combination
12389 IF(MINT(43).EQ.4) KCC=4
12390
12391 ELSEIF(ISUB.EQ.264) THEN
12392C...g + g -> ~t_1 + ~t_1bar; th arbitrary
12393 KCS=(-1)**INT(1.5D0+PYR(0))
12394 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12395 MINT(22)=-MINT(21)
12396 KCC=MINT(2)+10
12397
12398 ELSEIF(ISUB.EQ.265) THEN
12399C...g + g -> ~t_2 + ~t_2bar; th arbitrary
12400 KCS=(-1)**INT(1.5D0+PYR(0))
12401 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12402 MINT(22)=-MINT(21)
12403 KCC=MINT(2)+10
12404 ENDIF
12405
12406 ELSEIF(ISUB.LE.301) THEN
12407 IF(ISUB.EQ.271.OR.ISUB.EQ.281.OR.ISUB.EQ.291) THEN
12408C...qi + qj -> ~qi_L + ~qj_L
12409 KCC=MINT(2)
12410 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12411 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12412 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12413
12414 ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.282.OR.ISUB.EQ.292) THEN
12415C...qi + qj -> ~qi_R + ~qj_R
12416 KCC=MINT(2)
12417 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12418 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12419 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12420
12421 ELSEIF(ISUB.EQ.273.OR.ISUB.EQ.283.OR.ISUB.EQ.293) THEN
12422C...qi + qj -> ~qi_L + ~qj_R
12423 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12424 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12425 KCC=MINT(2)
12426 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12427
12428 ELSEIF(ISUB.EQ.274.OR.ISUB.EQ.284) THEN
12429C...qi + qjbar -> ~qi_L + ~qj_Lbar; th = (p(f)-p(sf'))**2
12430 MINT(21)=ISIGN(KSUSY1+IABS(MINT(15)),MINT(15))
12431 MINT(22)=ISIGN(KSUSY1+IABS(MINT(16)),MINT(16))
12432 KCC=MINT(2)
12433 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12434
12435 ELSEIF(ISUB.EQ.275.OR.ISUB.EQ.285) THEN
12436C...qi + qjbar -> ~qi_R + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12437 MINT(21)=ISIGN(KSUSY2+IABS(MINT(15)),MINT(15))
12438 MINT(22)=ISIGN(KSUSY2+IABS(MINT(16)),MINT(16))
12439 KCC=MINT(2)
12440 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12441
12442 ELSEIF(ISUB.EQ.276.OR.ISUB.EQ.286.OR.ISUB.EQ.296) THEN
12443C...qi + qjbar -> ~qi_L + ~qj_Rbar ; th = (p(f)-p(sf'))**2
12444 MINT(21)=ISIGN(KFPR(ISUB,1),MINT(15))
12445 MINT(22)=ISIGN(KFPR(ISUB,2),MINT(16))
12446 KCC=MINT(2)
12447 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12448
12449 ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.287) THEN
12450C...f + fbar -> ~qi_L + ~qi_Lbar ; th = (p(q)-p(sq))**2
12451 ISGN=1
12452 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12453 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12454 MINT(22)=-MINT(21)
12455 IF(MINT(43).EQ.4) KCC=4
12456
12457 ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.288) THEN
12458C...f + fbar -> ~qi_R + ~qi_Rbar; th = (p(q)-p(sq))**2
12459 ISGN=1
12460 IF(MINT(43).EQ.1.AND.PYR(0).GT.0.5D0) ISGN=-1
12461 MINT(21)=ISGN*ISIGN(KFPR(ISUB,1),KCS)
12462 MINT(22)=-MINT(21)
12463 IF(MINT(43).EQ.4) KCC=4
12464
12465 ELSEIF(ISUB.EQ.279.OR.ISUB.EQ.289) THEN
12466C...g + g -> ~qi_L + ~qi_Lbar ; th arbitrary
12467C...pure LL + RR
12468 KCS=(-1)**INT(1.5D0+PYR(0))
12469 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12470 MINT(22)=-MINT(21)
12471 KCC=MINT(2)+10
12472
12473 ELSEIF(ISUB.EQ.280.OR.ISUB.EQ.290) THEN
12474C...g + g -> ~qi_R + ~qi_Rbar ; th arbitrary
12475 KCS=(-1)**INT(1.5D0+PYR(0))
12476 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12477 MINT(22)=-MINT(21)
12478 KCC=MINT(2)+10
12479
12480 ELSEIF(ISUB.EQ.294) THEN
12481C...qj + g -> ~qj_L + ~g
12482 IF(MINT(15).EQ.21) JS=2
12483 I=MINT(14+JS)
12484 IA=IABS(I)
12485 MINT(20+JS)=ISIGN(KSUSY1+IA,I)
12486 MINT(23-JS)=KSUSY1+21
12487 KCC=MINT(2)+6
12488 IF(JS.EQ.2) KCC=KCC+2
12489 KCS=ISIGN(1,I)
12490
12491 ELSEIF(ISUB.EQ.295) THEN
12492C...qj + g -> ~qj_R + ~g
12493 IF(MINT(15).EQ.21) JS=2
12494 I=MINT(14+JS)
12495 IA=IABS(I)
12496 MINT(20+JS)=ISIGN(KSUSY2+IA,I)
12497 MINT(23-JS)=KSUSY1+21
12498 KCC=MINT(2)+6
12499 IF(JS.EQ.2) KCC=KCC+2
12500 KCS=ISIGN(1,I)
12501
12502 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
12503C...q + qbar' -> H+ + H0
12504 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12505 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12506 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12507 MINT(20+JS)=ISIGN(37,KCH1+KCH2)
12508 MINT(23-JS)=KFPR(ISUB,2)
12509 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
12510C...f + fbar -> A0 + H0; th arbitrary
12511 IF(PYR(0).GT.0.5D0) JS=2
12512 MINT(20+JS)=KFPR(ISUB,1)
12513 MINT(23-JS)=KFPR(ISUB,2)
12514 ELSEIF(ISUB.EQ.301) THEN
12515C...f + fbar -> H+ H-
12516 MINT(21)=ISIGN(KFPR(ISUB,1),KCS)
12517 MINT(22)=-MINT(21)
12518 ENDIF
12519CMRENNA--
12520 ELSEIF(ISUB.LE.330) THEN
12521 IF(ISUB.EQ.311)THEN
12522C...g + g -> g* + g* (UED)
12523 KCC=MINT(2)+12
12524 KCS=(-1)**INT(1.5D0+PYR(0))
12525 MUED(1)=472
12526 MUED(2)=472
12527 MINT(21)=IUEDEQ(472)
12528 MINT(22)=IUEDEQ(472)
12529 ELSEIF(ISUB.EQ.312)THEN
12530C...q + g -> q*_D + g*, q*_S + g*
12531C...The two channels have the same cross section
12532 KKFLMI=450
12533 IF(PYR(0).GT.0.5)KKFLMI=456
12534 IF(MINT(15).EQ.21) JS=2
12535 KCC=MINT(2)+6
12536 IF(MINT(15).EQ.21)KCC=KCC+2
12537 IF(MINT(15).NE.21)THEN
12538 KCS=ISIGN(1,MINT(15))
12539 MUED(2)=472
12540 MUED(1)=KCS*(KKFLMI+IABS(MINT(15)))
12541 MINT(22)=IUEDEQ(472)
12542 MINT(21)=KCS*IUEDEQ(KKFLMI+IABS(MINT(15)))
12543 ENDIF
12544 IF(MINT(16).NE.21)THEN
12545 KCS=ISIGN(1,MINT(16))
12546 MUED(2)=KCS*(KKFLMI+IABS(MINT(16)))
12547 MUED(1)=472
12548 MINT(22)=KCS*IUEDEQ(KKFLMI+IABS(MINT(16)))
12549 MINT(21)=IUEDEQ(472)
12550 ENDIF
12551 ELSEIF(ISUB.EQ.313)THEN
12552C...q + q' -> q*_D + q*_D',q*_S+q*_S'
12553C...The two channels have the same cross section
12554 KKFLMI=450
12555 IF(PYR(0).GT.0.5)KKFLMI=456
12556 KCC=MINT(2)
12557 IF(MINT(15).EQ.MINT(16))THEN
12558 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12559 MUED(2)=MINT(21)
12560 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12561 MINT(22)=MINT(21)
12562 ELSE
12563 MUED(1)=SIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12564 MUED(2)=SIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12565 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12566 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12567 ENDIF
12568 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12569 ELSEIF(ISUB.EQ.314)THEN
12570C...g + g -> q*_D + q*_D_bar, q*_S + q*_S_bar
12571C...The two channels have the same cross section
12572 KKFLMI=450
12573 IF(PYR(0).GT.0.5)KKFLMI=456
12574 KCS=(-1)**INT(1.5D0+PYR(0))
12575 XFLAOUT=PYR(0)
12576 IF(XFLAOUT.LE.0.2)THEN
12577 MUED(1)=ISIGN(1,KCS)*(KKFLMI+1)
12578 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+1)
12579 ELSEIF(XFLAOUT.LE.0.4)THEN
12580 MUED(1)=ISIGN(1,KCS)*(KKFLMI+2)
12581 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+2)
12582 ELSEIF(XFLAOUT.LE.0.6)THEN
12583 MUED(1)=ISIGN(1,KCS)*(KKFLMI+3)
12584 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+3)
12585 ELSEIF(XFLAOUT.LE.0.8)THEN
12586 MUED(1)=ISIGN(1,KCS)*(KKFLMI+4)
12587 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+4)
12588 ELSE
12589 MUED(1)=ISIGN(1,KCS)*(KKFLMI+5)
12590 MINT(21)=ISIGN(1,KCS)*IUEDEQ(KKFLMI+5)
12591 ENDIF
12592 MINT(22)=-MINT(21)
12593 MUED(2)=-MUED(1)
12594 KCC=MINT(2)+10
12595 ELSEIF(ISUB.EQ.315)THEN
12596C...q + qbar -> q*_D + q*_D_bar, q*_S + q*_S_bar
12597C...The two channels have the same cross section
12598 KKFLMI=450
12599 IF(PYR(0).GT.0.5)KKFLMI=456
12600 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12601 MUED(2)=-MINT(21)
12602 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12603 MINT(22)=-MINT(21)
12604 KCC=4
12605 ELSEIF(ISUB.EQ.316)THEN
12606C...q + qbar' -> q*_D + q*_S_bar'
12607 MUED(1)=ISIGN(1,MINT(15))*(456+IABS(MINT(15)))
12608 MUED(2)=ISIGN(1,MINT(16))*(450+IABS(MINT(16)))
12609 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12610 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12611 KCC=MINT(2)+2
12612 ELSEIF(ISUB.EQ.317)THEN
12613C...q + qbar' -> q*_D + q*_D_bar', q*_S + q*_S_bar
12614C...The two channels have the same cross section
12615 KKFLMI=450
12616 IF(PYR(0).GT.0.5)KKFLMI=456
12617 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IABS(MINT(15)))
12618 MUED(2)=ISIGN(1,MINT(16))*(KKFLMI+IABS(MINT(16)))
12619 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IABS(MINT(15)))
12620 MINT(22)=ISIGN(1,MINT(16))*IUEDEQ(KKFLMI+IABS(MINT(16)))
12621 KCC=MINT(2)+2
12622 ELSEIF(ISUB.EQ.318)THEN
12623C...q + q' -> q*_D + q*_S'
12624 KCC=MINT(2)
12625 MUED(1)=SIGN(1,MINT(15))*(456+IABS(MINT(15)))
12626 MUED(2)=SIGN(1,MINT(16))*(450+IABS(MINT(16)))
12627 MINT(21)=SIGN(1,MINT(15))*IUEDEQ(456+IABS(MINT(15)))
12628 MINT(22)=SIGN(1,MINT(16))*IUEDEQ(450+IABS(MINT(16)))
12629 ELSEIF(ISUB.EQ.319)THEN
12630C...q + qbar -> q*_D' + q*_D_bar', q*_S' + q*_S_bar'
12631C...The two channels have the same cross section
12632 KKFLMI=450
12633 IF(PYR(0).GT.0.5)KKFLMI=456
12634 XFLAOUT=PYR(0)
12635 IIFLAV=0
12636C...N.B. NFLAVOURS=IUED(3)
12637C DO I=1,NFLAVOURS
12638 DO 433 I=1,IUED(3)
12639 IF(I.NE.IABS(MINT(15)))THEN
12640 IIFLAV=IIFLAV+1
12641 IOKFLA(IIFLAV)=I
12642 ENDIF
12643 433 CONTINUE
12644 FLASTEP=1./(IUED(3)-1)
12645 DO I=1,IUED(3)-1
12646 FLAVV=FLASTEP*I
12647 IF(XFLAOUT.LE.FLAVV)THEN
12648 MUED(1)=ISIGN(1,MINT(15))*(KKFLMI+IOKFLA(I))
12649 MINT(21)=ISIGN(1,MINT(15))*IUEDEQ(KKFLMI+IOKFLA(I))
12650 GOTO 435
12651 ENDIF
12652 ENDDO
12653 435 CONTINUE
12654 IF(IABS(MUED(1)).LT.451.AND.IABS(MUED(1)).GT.462)THEN
12655 WRITE(MSTU(11),*) 'IN PYSCAT: KK FLAVORS PROBLEM !!!'
12656 CALL PYSTOP(5000000)
12657 ENDIF
12658 MINT(22)=-MINT(21)
12659 KCC=4
12660 ENDIF
12661
12662 ELSEIF(ISUB.LE.360) THEN
12663
12664 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
12665C...l + l -> H_L++/--, H_R++/--
12666 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12667 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12668 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12669
12670 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
12671C...l + gamma -> l' + H++/--; th=(p(l)-p(H))**2
12672 IF(MINT(15).EQ.22) JS=2
12673 MINT(20+JS)=ISIGN(KFPR(ISUB,1),-MINT(14+JS))
12674 MINT(23-JS)=ISIGN(KFPR(ISUB,2),-MINT(14+JS))
12675 KCC=22
12676
12677 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
12678C...f + fbar -> H++ + H--; th = (p(f)-p(H--))**2
12679 MINT(21)=-ISIGN(KFPR(ISUB,1),MINT(15))
12680 MINT(22)=-MINT(21)
12681
12682 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
12683C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/--
12684C...as inner process).
12685 DO 450 JT=1,2
12686 I=MINT(14+JT)
12687 IA=IABS(I)
12688 IF(IA.LE.10) THEN
12689 RVCKM=VINT(180+I)*PYR(0)
12690 DO 440 J=1,MSTP(1)
12691 IB=2*J-1+MOD(IA,2)
12692 IPM=(5-ISIGN(1,I))/2
12693 IDC=J+MDCY(IA,2)+2
12694 IF(MDME(IDC,1).NE.1.AND.MDME(IDC,1).NE.IPM) GOTO 440
12695 MINT(20+JT)=ISIGN(IB,I)
12696 RVCKM=RVCKM-VCKM((IA+1)/2,(IB+1)/2)
12697 IF(RVCKM.LE.0D0) GOTO 450
12698 440 CONTINUE
12699 ELSE
12700 IB=2*((IA+1)/2)-1+MOD(IA,2)
12701 MINT(20+JT)=ISIGN(IB,I)
12702 ENDIF
12703 450 CONTINUE
12704 KCC=22
12705 KFRES=ISIGN(KFPR(ISUB,1),MINT(15))
12706 IF(MOD(MINT(15),2).EQ.1) KFRES=-KFRES
12707
12708 ELSEIF(ISUB.EQ.353) THEN
12709C...f + fbar -> Z_R0
12710 KFRES=KFPR(ISUB,1)
12711
12712 ELSEIF(ISUB.EQ.354) THEN
12713C...f + fbar' -> W+/-
12714 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12715 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12716 KFRES=ISIGN(KFPR(ISUB,1),KCH1+KCH2)
12717
12718 ENDIF
12719
12720 ELSEIF(ISUB.LE.380) THEN
12721
12722 IF(ISUB.LE.363.OR.ISUB.EQ.368) THEN
12723C...f + fbar -> charged+ charged- technicolor
12724 KSW=(-1)**INT(1.5D0+PYR(0))
12725 MINT(21)=ISIGN(KFPR(ISUB,1),KSW)
12726 MINT(22)=-ISIGN(KFPR(ISUB,2),KSW)
12727
12728 ELSEIF(ISUB.LE.367.OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
12729C...f + fbar -> neutral neutral technicolor
12730 MINT(21)=KFPR(ISUB,1)
12731 MINT(22)=KFPR(ISUB,2)
12732
12733 ELSEIF(ISUB.EQ.374.OR.ISUB.EQ.375.OR.ISUB.EQ.378) THEN
12734C...f + fbar' -> neutral charged technicolor
12735 IN=1
12736 IC=2
12737 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12738 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12739 IF(MINT(15)*(KCH1+KCH2).LT.0) JS=2
12740 MINT(23-JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12741 MINT(20+JS)=KFPR(ISUB,IN)
12742
12743 ELSEIF(ISUB.GE.370.AND.ISUB.LE.377) THEN
12744C...f + fbar' -> charged neutral technicolor
12745 IN=2
12746 IC=1
12747 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12748 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12749 IF(MINT(15)*(KCH1+KCH2).GT.0) JS=2
12750 MINT(20+JS)=ISIGN(KFPR(ISUB,IC),KCH1+KCH2)
12751 MINT(23-JS)=KFPR(ISUB,IN)
12752 ENDIF
12753
12754 ELSEIF(ISUB.LE.400) THEN
12755 IF(ISUB.EQ.381) THEN
12756C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2, TC extensions
12757 KCC=MINT(2)
12758 IF(MINT(15)*MINT(16).LT.0) KCC=KCC+2
12759
12760 ELSEIF(ISUB.EQ.382) THEN
12761C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2, TC extensions
12762 MINT(21)=ISIGN(KFLF,MINT(15))
12763 MINT(22)=-MINT(21)
12764 KCC=4
12765
12766 ELSEIF(ISUB.EQ.383) THEN
12767C...f + fbar -> g + g; th arbitrary, TC extensions
12768 MINT(21)=21
12769 MINT(22)=21
12770 KCC=MINT(2)+4
12771
12772 ELSEIF(ISUB.EQ.384) THEN
12773C...f + g -> f + g; th = (p(f)-p(f))**2, TC extensions
12774 IF(MINT(15).EQ.21) JS=2
12775 KCC=MINT(2)+6
12776 IF(MINT(15).EQ.21) KCC=KCC+2
12777 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12778 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12779
12780 ELSEIF(ISUB.EQ.385) THEN
12781C...g + g -> f + fbar; th arbitrary, TC extensions
12782 KCS=(-1)**INT(1.5D0+PYR(0))
12783 MINT(21)=ISIGN(KFLF,KCS)
12784 MINT(22)=-MINT(21)
12785 KCC=MINT(2)+10
12786
12787 ELSEIF(ISUB.EQ.386) THEN
12788C...g + g -> g + g; th arbitrary, TC extensions
12789 KCC=MINT(2)+12
12790 KCS=(-1)**INT(1.5D0+PYR(0))
12791
12792 ELSEIF(ISUB.EQ.387) THEN
12793C...q + qbar -> Q + Qbar; th = (p(q)-p(Q))**2, TC extensions
12794 MINT(21)=ISIGN(MINT(55),MINT(15))
12795 MINT(22)=-MINT(21)
12796 KCC=4
12797
12798 ELSEIF(ISUB.EQ.388) THEN
12799C...g + g -> Q + Qbar; th arbitrary, TC extensions
12800 KCS=(-1)**INT(1.5D0+PYR(0))
12801 MINT(21)=ISIGN(MINT(55),KCS)
12802 MINT(22)=-MINT(21)
12803 KCC=MINT(2)+10
12804
12805 ELSEIF(ISUB.EQ.391) THEN
12806C...f + fbar -> G*.
12807 KFRES=KFPR(ISUB,1)
12808
12809 ELSEIF(ISUB.EQ.392) THEN
12810C...g + g -> G*.
12811 KCC=21
12812 KFRES=KFPR(ISUB,1)
12813
12814 ELSEIF(ISUB.EQ.393) THEN
12815C...q + qbar -> g + G*; th arbitrary.
12816 IF(PYR(0).GT.0.5D0) JS=2
12817 MINT(20+JS)=KFPR(ISUB,1)
12818 MINT(23-JS)=KFPR(ISUB,2)
12819 KCC=17+JS
12820
12821 ELSEIF(ISUB.EQ.394) THEN
12822C...q + g -> q + G*; th = (p(f) - p(f))**2
12823 IF(MINT(15).EQ.21) JS=2
12824 MINT(23-JS)=KFPR(ISUB,2)
12825 KCC=15+JS
12826 KCS=ISIGN(1,MINT(14+JS))
12827
12828 ELSEIF(ISUB.EQ.395) THEN
12829C...g + g -> G* + g; th arbitrary.
12830 IF(PYR(0).GT.0.5D0) JS=2
12831 MINT(23-JS)=KFPR(ISUB,2)
12832 KCC=22+JS
12833 ENDIF
12834
12835 ELSEIF(ISUB.LE.420) THEN
12836 IF(ISUB.EQ.401) THEN
12837C...g + g -> t + b + H+/-
12838 KCS=(-1)**INT(1.5D0+PYR(0))
12839 MINT(21)=ISIGN(KFPR(ISUBSV,2),KCS)
12840 MINT(22)=ISIGN(5,-KCS)
12841 KCC=11+INT(0.5D0+PYR(0))
12842 KFRES=ISIGN(KFHIGG,-KCS)
12843
12844 ELSEIF(ISUB.EQ.402) THEN
12845C...q + qbar -> t + b + H+/-
12846 KFL=(-1)**INT(1.5D0+PYR(0))
12847 MINT(21)=ISIGN(INT(6.+.5*KFL),KCS)
12848 MINT(22)=ISIGN(INT(6.-.5*KFL),-KCS)
12849 KCC=4
12850 KFRES=ISIGN(KFHIGG,-KFL*KCS)
12851 ENDIF
12852
12853C...QUARKONIA+++
12854C...Additional code by Stefan Wolf
12855 ELSEIF(ISUB.LE.430) THEN
12856 IF(ISUB.GE.421.AND.ISUB.LE.424) THEN
12857C...g + g -> QQ~[n] + g
12858C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12859C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12860C...KCC and KCS copied from ISUB.EQ.86-89 (for ISUB.EQ.421)
12861C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12862C...or from ISUB.EQ.68 (for ISUB.NE.421)
12863C...[g + g -> g + g; th arbitrary]
12864 MINT(21)=KFPR(ISUBSV,1)
12865 MINT(22)=KFPR(ISUBSV,2)
12866 IF(ISUB.EQ.421) THEN
12867 KCC=24
12868 KCS=(-1)**INT(1.5D0+PYR(0))
12869 ELSE
12870 KCC=MINT(2)+12
12871 KCS=(-1)**INT(1.5D0+PYR(0))
12872 ENDIF
12873
12874 ELSEIF(ISUB.GE.425.AND.ISUB.LE.427) THEN
12875C...q + g -> q + QQ~[n]
12876C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12877C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12878C...KCC copied from ISUB.EQ.28
12879C...[f + g -> f + g; th = (p(f)-p(f))**2; (q + g -> q + g only)]
12880 IF(MINT(15).EQ.21) JS=2
12881 MINT(23-JS)=KFPR(ISUBSV,2)
12882 KCC=MINT(2)+6
12883 IF(MINT(15).EQ.21) KCC=KCC+2
12884 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
12885 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
12886
12887 ELSEIF(ISUB.GE.428.AND.ISUB.LE.430) THEN
12888C...q + q~ -> g + QQ~[n]
12889C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12890C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12891C...KCC copied from ISUB.EQ.13
12892C...[f + fbar -> g + g; th arbitrary; (q + qbar -> g + g only)]
12893 IF(PYR(0).GT.0.5) JS=2
12894 MINT(20+JS)=21
12895 MINT(23-JS)=KFPR(ISUBSV,2)
12896 KCC=MINT(2)+4
12897 ENDIF
12898
12899 ELSEIF(ISUB.LE.440) THEN
12900 IF(ISUB.GE.431.AND.ISUB.LE.433) THEN
12901C...g + g -> QQ~[n] + g
12902C...MINT(21), MINT(22) copied from ISUB.EQ.86-89
12903C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12904C...KCC and KCS copied from ISUB.EQ.86-89
12905C...[g + g -> (J/Psi, chi_0c, chi_1c or chi_2c) + g]
12906 MINT(21)=KFPR(ISUBSV,1)
12907 MINT(22)=KFPR(ISUBSV,2)
12908 KCC=24
12909 KCS=(-1)**INT(1.5D0+PYR(0))
12910
12911 ELSEIF(ISUB.GE.434.AND.ISUB.LE.436) THEN
12912C...q + g -> q + QQ~[n]
12913C...MINT(21), MINT(22) "copied" from ISUB.EQ.112
12914C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12915C...KCC and KCS copied from ISUB.EQ.112
12916C...[f + g -> f + h0; th = (p(f)-p(f))**2; (q + g -> q + h0 only)]
12917 IF(MINT(15).EQ.21) JS=2
12918 MINT(23-JS)=KFPR(ISUBSV,2)
12919 KCC=15+JS
12920 KCS=ISIGN(1,MINT(14+JS))
12921
12922 ELSEIF(ISUB.GE.437.AND.ISUB.LE.439) THEN
12923C...q + q~ -> g + QQ~[n]
12924C...MINT(21), MINT(22) "copied" from ISUB.EQ.111
12925C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12926C...KCC copied from ISUB.EQ.111
12927C...[f + fbar -> g + h0; th arbitrary; (q + qbar -> g + h0 only)]
12928 IF(PYR(0).GT.0.5) JS=2
12929 MINT(20+JS)=21
12930 MINT(23-JS)=KFPR(ISUBSV,2)
12931 KCC=17+JS
12932C...QUARKONIA---
12933 ENDIF
12934 ELSEIF(ISUB.LE.500) THEN
12935 IF(ISUB.EQ.481.OR.ISUB.EQ.482) THEN
12936 KFRES=9900001
12937 KCRES=PYCOMP(KFRES)
12938 MCOL=KCHG(KCRES,2)
12939 MCHG=KCHG(KCRES,1)
12940 IF(KCRES.EQ.0)
12941 $ CALL PYERRM(21,"No resonance for Generic 2-> 2 Process")
12942 IDCY=MDCY(KCRES,2)
12943 IF(IDCY.EQ.0)
12944 $ CALL PYERRM(21,"No decays for resonance in Generic 2->2")
12945 KCI1=PYCOMP(MINT(15))
12946 KCI2=PYCOMP(MINT(16))
12947 ICOL1=ISIGN(KCHG(KCI1,2),MINT(15))
12948 ICOL2=ISIGN(KCHG(KCI2,2),MINT(16))
12949 KFF1=KFPR(ISUB,1)
12950 KFF2=KFPR(ISUB,2)
12951 KCF1=PYCOMP(KFF1)
12952 KCF2=PYCOMP(KFF2)
12953 JCOL1=SIGN(KCHG(KCF1,2),KFF1)
12954 IF(JCOL1.EQ.-2) JCOL1=2
12955 JCOL2=SIGN(KCHG(KCF2,2),KFF2)
12956 IF(JCOL2.EQ.-2) JCOL2=2
12957 KCH1=KCHG(IABS(MINT(15)),1)*ISIGN(1,MINT(15))
12958 KCH2=KCHG(IABS(MINT(16)),1)*ISIGN(1,MINT(16))
12959 KCHW=KCH1+KCH2
12960 KREL=1
12961 IF(MCHG.NE.0.AND.KCHW.EQ.-MCHG) KREL=-1
12962 IF(KCHG(KCF1,3).NE.0) KFF1=KFF1*KREL
12963 IF(KCHG(KCF2,3).NE.0) KFF2=KFF2*KREL
12964 IF(JCOL1.EQ.1.OR.JCOL1.EQ.-1) JCOL1=JCOL1*KREL
12965 IF(JCOL2.EQ.1.OR.JCOL2.EQ.-1) JCOL2=JCOL2*KREL
12966 IF((ICOL1.EQ.1.AND.ICOL2.EQ.-1).OR.
12967 $ (ICOL2.EQ.1.AND.ICOL1.EQ.-1)) THEN
12968 IF(PYR(0).GT.0.5D0) JS=2
12969 MINT(20+JS)=KFF1
12970 MINT(23-JS)=KFF2
12971 IF(JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN
12972
12973 ELSEIF(JCOL1.EQ.0.AND.JCOL2.EQ.2) THEN
12974 KCC=17+JS
12975 MINT(20+JS)=KFF2
12976 MINT(23-JS)=KFF1
12977 ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.0) THEN
12978 KCC=17+JS
12979 MINT(20+JS)=KFF1
12980 MINT(23-JS)=KFF2
12981 ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2.AND.MCOL.EQ.0) THEN
12982
12983 ELSEIF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
12984 KCC=MINT(2)+4
12985 ELSEIF((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR.
12986 $ (JCOL1.EQ.-1.AND.JCOL2.EQ.1)) THEN
12987 IF(ICOL1.EQ.JCOL1) THEN
12988 JS=1
12989 MINT(21)=KFF1
12990 MINT(22)=KFF2
12991 ELSE
12992 JS=2
12993 MINT(21)=KFF2
12994 MINT(22)=KFF1
12995 ENDIF
12996 IF(MCOL.EQ.0) THEN
12997
12998 ELSE
12999 KCC=4
13000 ENDIF
13001 ENDIF
13002 ELSEIF((ICOL1.EQ.2.AND.(ICOL2.EQ.1.OR.ICOL2.EQ.-1)).OR.
13003 $ (ICOL2.EQ.2.AND.(ICOL1.EQ.1.OR.ICOL1.EQ.-1))) THEN
13004 IF((JCOL1.EQ.2.AND.ABS(JCOL2).EQ.1).OR.
13005 $ (JCOL2.EQ.2.AND.ABS(JCOL1).EQ.1)) THEN
13006 IF(MINT(15).EQ.21) JS=2
13007 KCC=MINT(2)+6
13008 IF(MINT(15).EQ.21) KCC=KCC+2
13009 IF(MINT(15).NE.21) KCS=ISIGN(1,MINT(15))
13010 IF(MINT(16).NE.21) KCS=ISIGN(1,MINT(16))
13011 IF(JCOL1.EQ.2) THEN
13012 MINT(20+JS)=KFF2
13013 MINT(23-JS)=KFF1
13014 ELSE
13015 MINT(20+JS)=KFF1
13016 MINT(23-JS)=KFF2
13017 ENDIF
13018 ELSEIF((ABS(JCOL1).EQ.1.AND.JCOL2.EQ.0).OR.
13019 $ (ABS(JCOL2).EQ.1.AND.JCOL1.EQ.0)) THEN
13020 IF(MINT(15).EQ.21) JS=2
13021 KCC=15+JS
13022 KCS=ISIGN(1,MINT(14+JS))
13023 IF(JCOL1.EQ.0) THEN
13024 MINT(23-JS)=KFF1
13025 MINT(20+JS)=KFF2
13026 ELSE
13027 MINT(23-JS)=KFF2
13028 MINT(20+JS)=KFF1
13029 ENDIF
13030 ENDIF
13031 ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13032 $ JCOL1.EQ.0.AND.JCOL2.EQ.0) THEN
13033 IF(PYR(0).GT.0.5D0) JS=2
13034 KCC=21
13035 MINT(20+JS)=KFF1
13036 MINT(23-JS)=KFF2
13037 ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13038 $ ((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR.
13039 $ ((JCOL2.EQ.0.AND.JCOL1.EQ.2)))) THEN
13040 IF(PYR(0).GT.0.5D0) JS=2
13041 KCC=22+JS
13042 KCS=(-1)**INT(1.5D0+PYR(0))
13043 IF(JCOL1.EQ.0) THEN
13044 MINT(23-JS)=KFF1
13045 MINT(20+JS)=KFF2
13046 ELSE
13047 MINT(23-JS)=KFF2
13048 MINT(20+JS)=KFF1
13049 ENDIF
13050 ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13051 $ ((JCOL1.EQ.1.AND.JCOL2.EQ.-1).OR.
13052 $ ((JCOL2.EQ.1.AND.JCOL1.EQ.-1)))) THEN
13053C....two choices, 0 or 2 depending upon mother properties
13054 IF(MCOL.EQ.2) THEN
13055 KCS=(-1)**INT(1.5D0+PYR(0))
13056 KCC=MINT(2)+10
13057 IF(JCOL1.EQ.1) THEN
13058 MINT(21)=KFF1*KCS
13059 MINT(22)=KFF2*KCS
13060 ELSE
13061 MINT(22)=KFF1*KCS
13062 MINT(21)=KFF2*KCS
13063 ENDIF
13064c MINT(20+JS)=KFF1*KCS
13065c MINT(23-JS)=KFF2*KCS
13066 ELSEIF(MCOL.EQ.0) THEN
13067 KCC=21
13068 MINT(20+JS)=KFF1*KCS
13069 MINT(23-JS)=KFF2*KCS
13070 ENDIF
13071
13072 ELSEIF(ICOL1.EQ.2.AND.ICOL2.EQ.2.AND.
13073 $ JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
13074C....two choices, 0 or 2 depending upon mother properties
13075 IF(MCOL.EQ.0) THEN
13076 KCC=21
13077 IF(PYR(0).GT.0.5D0) JS=2
13078 MINT(20+JS)=KFF1
13079 MINT(23-JS)=KFF2
13080 ELSEIF(MCOL.EQ.2) THEN
13081 IF(PYR(0).GT.0.5D0) JS=2
13082 KCC=MINT(2)+12
13083 KCS=(-1)**INT(1.5D0+PYR(0))
13084 MINT(20+JS)=KFF1
13085 MINT(23-JS)=KFF2
13086 ENDIF
13087 ELSEIF((ICOL1.EQ.1.AND.ICOL2.EQ.1).OR.
13088 $ (ICOL1.EQ.-1.AND.ICOL2.EQ.-1)) THEN
13089 KCC=MINT(2)
13090 IF(PYR(0).GT.0.5D0) JS=2
13091 MINT(20+JS)=KFF1
13092 MINT(23-JS)=KFF2
13093 ELSEIF(ICOL1.EQ.0.AND.ICOL2.EQ.0.AND.MCOL.EQ.0) THEN
13094 KCC=20
13095 IF(PYR(0).GT.0.5D0) JS=2
13096 MINT(20+JS)=KFF1
13097 MINT(23-JS)=KFF2
13098 ELSE
13099 CALL PYERRM(21,"PYSCAT: No recognized Generic Process")
13100 ENDIF
13101 IF(ISUBSV.EQ.482) KFRES=0
13102 ENDIF
13103 ENDIF
13104
13105 IF(ISET(ISUB).EQ.11) THEN
13106C...Store documentation for user-defined processes
13107 BEZUP=(PUP(3,1)+PUP(3,2))/(PUP(4,1)+PUP(4,2))
13108 KUPPO(1)=MINT(83)+5
13109 KUPPO(2)=MINT(83)+6
13110 I=MINT(83)+6
13111 DO 470 IUP=3,NUP
13112 KUPPO(IUP)=0
13113 IF(MSTP(128).GE.2.AND.MOTHUP(1,IUP).GE.3) THEN
13114 IDOC=IDOC-1
13115 MINT(4)=MINT(4)-1
13116 GOTO 470
13117 ENDIF
13118 I=I+1
13119 KUPPO(IUP)=I
13120 K(I,1)=21
13121 K(I,2)=IDUP(IUP)
13122 IF(IDUP(IUP).EQ.0) K(I,2)=90
13123 K(I,3)=0
13124 IF(MOTHUP(1,IUP).GE.3) K(I,3)=KUPPO(MOTHUP(1,IUP))
13125 K(I,4)=0
13126 K(I,5)=0
13127 DO 460 J=1,5
13128 P(I,J)=PUP(J,IUP)
13129 460 CONTINUE
13130 V(I,5)=VTIMUP(IUP)
13131 470 CONTINUE
13132 CALL PYROBO(MINT(83)+7,MINT(83)+4+NUP,0D0,VINT(24),0D0,0D0,
13133 & -BEZUP)
13134
13135C...Store final state partons for user-defined processes
13136 N=IPU2
13137 DO 490 IUP=3,NUP
13138 N=N+1
13139 K(N,1)=1
13140 IF(ISTUP(IUP).EQ.2.OR.ISTUP(IUP).EQ.3) K(N,1)=11
13141 K(N,2)=IDUP(IUP)
13142 IF(IDUP(IUP).EQ.0) K(N,2)=90
13143 IF(MSTP(128).LE.0.OR.MOTHUP(1,IUP).EQ.0) THEN
13144 K(N,3)=KUPPO(IUP)
13145 ELSE
13146 K(N,3)=MINT(84)+MOTHUP(1,IUP)
13147 ENDIF
13148 K(N,4)=0
13149 K(N,5)=0
13150C...Search for daughters of intermediate colourless particles.
13151 IF(K(N,1).EQ.11.AND.KCHG(PYCOMP(K(N,2)),2).EQ.0) THEN
13152 DO 475 IUPDAU=IUP+1,NUP
13153 IF(MOTHUP(1,IUPDAU).EQ.IUP.AND.K(N,4).EQ.0) K(N,4)=
13154 & N+IUPDAU-IUP
13155 IF(MOTHUP(1,IUPDAU).EQ.IUP) K(N,5)=N+IUPDAU-IUP
13156 475 CONTINUE
13157 ENDIF
13158 DO 480 J=1,5
13159 P(N,J)=PUP(J,IUP)
13160 480 CONTINUE
13161 V(N,5)=VTIMUP(IUP)
13162 490 CONTINUE
13163 CALL PYROBO(IPU3,N,0D0,VINT(24),0D0,0D0,-BEZUP)
13164
13165C...Arrange colour flow for user-defined processes
13166 NLBL=0
13167 DO 540 IUP1=1,NUP
13168 I1=MINT(84)+IUP1
13169 IF(KCHG(PYCOMP(K(I1,2)),2).EQ.0) GOTO 540
13170 IF(K(I1,1).EQ.1) K(I1,1)=3
13171 IF(K(I1,1).EQ.11) K(I1,1)=14
13172C...Find a not yet considered colour/anticolour line.
13173 DO 530 ISDE1=1,2
13174 IF(ICOLUP(ISDE1,IUP1).EQ.0) GOTO 530
13175 NMAT=0
13176 DO 500 ILBL=1,NLBL
13177 IF(ICOLUP(ISDE1,IUP1).EQ.ILAB(ILBL)) NMAT=1
13178 500 CONTINUE
13179 IF(NMAT.EQ.0) THEN
13180 NLBL=NLBL+1
13181 ILAB(NLBL)=ICOLUP(ISDE1,IUP1)
13182C...Find all others belonging to same line.
13183 I3=I1
13184 I4=0
13185 DO 520 IUP2=IUP1+1,NUP
13186 I2=MINT(84)+IUP2
13187 DO 510 ISDE2=1,2
13188 IF(ICOLUP(ISDE2,IUP2).EQ.ICOLUP(ISDE1,IUP1)) THEN
13189 IF(ISDE2.EQ.ISDE1) THEN
13190 K(I3,3+ISDE2)=K(I3,3+ISDE2)+I2
13191 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I3
13192 I3=I2
13193 ELSEIF(I4.NE.0) THEN
13194 K(I4,3+ISDE2)=K(I4,3+ISDE2)+I2
13195 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I4
13196 I4=I2
13197 ELSEIF(IUP2.LE.2) THEN
13198 K(I1,3+ISDE1)=K(I1,3+ISDE1)+I2
13199 K(I2,3+ISDE2)=K(I2,3+ISDE2)+I1
13200 I4=I2
13201 ELSE
13202 K(I1,3+ISDE1)=K(I1,3+ISDE1)+MSTU(5)*I2
13203 K(I2,3+ISDE2)=K(I2,3+ISDE2)+MSTU(5)*I1
13204 I4=I2
13205 ENDIF
13206 ENDIF
13207 510 CONTINUE
13208 520 CONTINUE
13209 ENDIF
13210 530 CONTINUE
13211 540 CONTINUE
13212
13213 ELSEIF(IDOC.EQ.7) THEN
13214C...Resonance not decaying; store kinematics
13215 I=MINT(83)+7
13216 K(IPU3,1)=1
13217 K(IPU3,2)=KFRES
13218 K(IPU3,3)=I
13219 P(IPU3,4)=SHUSER
13220 P(IPU3,5)=SHUSER
13221 K(I,1)=21
13222 K(I,2)=KFRES
13223 P(I,4)=SHUSER
13224 P(I,5)=SHUSER
13225 N=IPU3
13226 MINT(21)=KFRES
13227 MINT(22)=0
13228
13229C...Special cases: colour flow in coloured resonances
13230 KCRES=PYCOMP(KFRES)
13231 IF(KCHG(KCRES,2).NE.0) THEN
13232 K(IPU3,1)=3
13233 DO 550 J=1,2
13234 JC=J
13235 IF(KCS.EQ.-1) JC=3-J
13236 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13237 & MINT(84)+ICOL(KCC,1,JC)
13238 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13239 & MINT(84)+ICOL(KCC,2,JC)
13240 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
13241 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13242 550 CONTINUE
13243 ELSE
13244 K(IPU1,4)=IPU2
13245 K(IPU1,5)=IPU2
13246 K(IPU2,4)=IPU1
13247 K(IPU2,5)=IPU1
13248 ENDIF
13249
13250 ELSEIF(IDOC.EQ.8) THEN
13251C...2 -> 2 processes: store outgoing partons in their CM-frame
13252 DO 560 JT=1,2
13253 I=MINT(84)+2+JT
13254 KCA=PYCOMP(MINT(20+JT))
13255 K(I,1)=1
13256 IF(KCHG(KCA,2).NE.0) K(I,1)=3
13257 K(I,2)=MINT(20+JT)
13258 K(I,3)=MINT(83)+IDOC+JT-2
13259 KFAA=IABS(K(I,2))
13260 IF(KFPR(ISUBSV,1+MOD(JS+JT,2)).NE.0) THEN
13261 P(I,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13262 ELSE
13263 P(I,5)=PYMASS(K(I,2))
13264 ENDIF
13265 IF((KFAA.EQ.6.OR.KFAA.EQ.7.OR.KFAA.EQ.8).AND.
13266 & P(I,5).LT.PARP(42)) P(I,5)=PYMASS(K(I,2))
13267 560 CONTINUE
13268 IF(P(IPU3,5)+P(IPU4,5).GE.SHR) THEN
13269 KFA1=IABS(MINT(21))
13270 KFA2=IABS(MINT(22))
13271 IF((KFA1.GT.3.AND.KFA1.NE.21).OR.(KFA2.GT.3.AND.KFA2.NE.21))
13272 & THEN
13273 MINT(51)=1
13274 RETURN
13275 ENDIF
13276 P(IPU3,5)=0D0
13277 P(IPU4,5)=0D0
13278 ENDIF
13279 P(IPU3,4)=0.5D0*(SHR+(P(IPU3,5)**2-P(IPU4,5)**2)/SHR)
13280 P(IPU3,3)=SQRT(MAX(0D0,P(IPU3,4)**2-P(IPU3,5)**2))
13281 P(IPU4,4)=SHR-P(IPU3,4)
13282 P(IPU4,3)=-P(IPU3,3)
13283 N=IPU4
13284 MINT(7)=MINT(83)+7
13285 MINT(8)=MINT(83)+8
13286
13287C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
13288 CALL PYROBO(IPU3,IPU4,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
13289
13290 ELSEIF(IDOC.EQ.9) THEN
13291C...2 -> 3 processes: store outgoing partons in their CM frame
13292 DO 570 JT=1,2
13293 I=MINT(84)+2+JT
13294 KCA=PYCOMP(MINT(20+JT))
13295 K(I,1)=1
13296 IF(KCHG(KCA,2).NE.0) K(I,1)=3
13297 K(I,2)=MINT(20+JT)
13298 K(I,3)=MINT(83)+IDOC+JT-3
13299 JTA=JT
13300C...t and b in opposide order in event list as compared to
13301C...matrix element?
13302 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) JTA=3-JT
13303 IF(IABS(K(I,2)).LE.22) THEN
13304 P(I,5)=PYMASS(K(I,2))
13305 ELSE
13306 P(I,5)=SQRT(VINT(63+MOD(JS+JTA,2)))
13307 ENDIF
13308 PT=SQRT(MAX(0D0,VINT(197+5*JTA)-P(I,5)**2+VINT(196+5*JTA)**2))
13309 P(I,1)=PT*COS(VINT(198+5*JTA))
13310 P(I,2)=PT*SIN(VINT(198+5*JTA))
13311 570 CONTINUE
13312 K(IPU5,1)=1
13313 K(IPU5,2)=KFRES
13314 K(IPU5,3)=MINT(83)+IDOC
13315 P(IPU5,5)=SHR
13316 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13317 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13318 PMS1=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
13319 PMS2=P(IPU4,5)**2+P(IPU4,1)**2+P(IPU4,2)**2
13320 PMS3=P(IPU5,5)**2+P(IPU5,1)**2+P(IPU5,2)**2
13321 PMT3=SQRT(PMS3)
13322 P(IPU5,3)=PMT3*SINH(VINT(211))
13323 P(IPU5,4)=PMT3*COSH(VINT(211))
13324 PMS12=(SHPR-P(IPU5,4))**2-P(IPU5,3)**2
13325 SQL12=(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2
13326 IF(SQL12.LE.0D0) THEN
13327 MINT(51)=1
13328 RETURN
13329 ENDIF
13330 P(IPU3,3)=(-P(IPU5,3)*(PMS12+PMS1-PMS2)+
13331 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13332 P(IPU4,3)=-P(IPU3,3)-P(IPU5,3)
13333 IF(ISUB.EQ.402.AND.IABS(MINT(21)).EQ.5) THEN
13334C...t and b in opposide order in event list as compared to
13335C...matrix element
13336 P(IPU4,3)=(-P(IPU5,3)*(PMS12+PMS2-PMS1)+
13337 & VINT(213)*(SHPR-P(IPU5,4))*SQRT(SQL12))/(2D0*PMS12)
13338 P(IPU3,3)=-P(IPU4,3)-P(IPU5,3)
13339 END IF
13340 P(IPU3,4)=SQRT(PMS1+P(IPU3,3)**2)
13341 P(IPU4,4)=SQRT(PMS2+P(IPU4,3)**2)
13342 MINT(23)=KFRES
13343 N=IPU5
13344 MINT(7)=MINT(83)+7
13345 MINT(8)=MINT(83)+8
13346
13347 ELSEIF(IDOC.EQ.11) THEN
13348C...Z0 + Z0 -> h0, W+ + W- -> h0: store Higgs and outgoing partons
13349 PHI(1)=PARU(2)*PYR(0)
13350 PHI(2)=PHI(1)-PHIR
13351 DO 580 JT=1,2
13352 I=MINT(84)+2+JT
13353 K(I,1)=1
13354 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13355 K(I,2)=MINT(20+JT)
13356 K(I,3)=MINT(83)+IDOC+JT-2
13357 P(I,5)=PYMASS(K(I,2))
13358 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) THEN
13359 MINT(51)=1
13360 RETURN
13361 ENDIF
13362 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13363 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13364 P(I,1)=PTABS*COS(PHI(JT))
13365 P(I,2)=PTABS*SIN(PHI(JT))
13366 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13367 P(I,4)=0.5D0*SHPR*Z(JT)
13368 IZW=MINT(83)+6+JT
13369 K(IZW,1)=21
13370 K(IZW,2)=23
13371 IF(ISUB.EQ.8) K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT)))
13372 K(IZW,3)=IZW-2
13373 P(IZW,1)=-P(I,1)
13374 P(IZW,2)=-P(I,2)
13375 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13376 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13377 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13378 580 CONTINUE
13379 I=MINT(83)+9
13380 K(IPU5,1)=1
13381 K(IPU5,2)=KFRES
13382 K(IPU5,3)=I
13383 P(IPU5,5)=SHR
13384 P(IPU5,1)=-P(IPU3,1)-P(IPU4,1)
13385 P(IPU5,2)=-P(IPU3,2)-P(IPU4,2)
13386 P(IPU5,3)=-P(IPU3,3)-P(IPU4,3)
13387 P(IPU5,4)=SHPR-P(IPU3,4)-P(IPU4,4)
13388 K(I,1)=21
13389 K(I,2)=KFRES
13390 DO 590 J=1,5
13391 P(I,J)=P(IPU5,J)
13392 590 CONTINUE
13393 N=IPU5
13394 MINT(23)=KFRES
13395
13396 ELSEIF(IDOC.EQ.12) THEN
13397C...Z0 and W+/- scattering: store bosons and outgoing partons
13398 PHI(1)=PARU(2)*PYR(0)
13399 PHI(2)=PHI(1)-PHIR
13400 JTRAN=INT(1.5D0+PYR(0))
13401 DO 600 JT=1,2
13402 I=MINT(84)+2+JT
13403 K(I,1)=1
13404 IF(KCHG(PYCOMP(MINT(20+JT)),2).NE.0) K(I,1)=3
13405 K(I,2)=MINT(20+JT)
13406 K(I,3)=MINT(83)+IDOC+JT-2
13407 P(I,5)=PYMASS(K(I,2))
13408 IF(0.5D0*SHPR*Z(JT).LE.P(I,5)) P(I,5)=0D0
13409 PABS=SQRT(MAX(0D0,(0.5D0*SHPR*Z(JT))**2-P(I,5)**2))
13410 PTABS=PABS*SQRT(MAX(0D0,1D0-CTHE(JT)**2))
13411 P(I,1)=PTABS*COS(PHI(JT))
13412 P(I,2)=PTABS*SIN(PHI(JT))
13413 P(I,3)=PABS*CTHE(JT)*(-1)**(JT+1)
13414 P(I,4)=0.5D0*SHPR*Z(JT)
13415 IZW=MINT(83)+6+JT
13416 K(IZW,1)=21
13417 IF(MINT(14+JT).EQ.MINT(20+JT)) THEN
13418 K(IZW,2)=23
13419 ELSE
13420 K(IZW,2)=ISIGN(24,PYCHGE(MINT(14+JT))-PYCHGE(MINT(20+JT)))
13421 ENDIF
13422 K(IZW,3)=IZW-2
13423 P(IZW,1)=-P(I,1)
13424 P(IZW,2)=-P(I,2)
13425 P(IZW,3)=(0.5D0*SHPR-PABS*CTHE(JT))*(-1)**(JT+1)
13426 P(IZW,4)=0.5D0*SHPR*(1D0-Z(JT))
13427 P(IZW,5)=-SQRT(MAX(0D0,P(IZW,3)**2+PTABS**2-P(IZW,4)**2))
13428 IPU=MINT(84)+4+JT
13429 K(IPU,1)=3
13430 K(IPU,2)=KFPR(ISUB,JT)
13431 IF(ISUB.EQ.72.AND.JT.EQ.JTRAN) K(IPU,2)=-K(IPU,2)
13432 IF(ISUB.EQ.73.OR.ISUB.EQ.77) K(IPU,2)=K(IZW,2)
13433 K(IPU,3)=MINT(83)+8+JT
13434 IF(IABS(K(IPU,2)).LE.10.OR.K(IPU,2).EQ.21) THEN
13435 P(IPU,5)=PYMASS(K(IPU,2))
13436 ELSE
13437 P(IPU,5)=SQRT(VINT(63+MOD(JS+JT,2)))
13438 ENDIF
13439 MINT(22+JT)=K(IPU,2)
13440 600 CONTINUE
13441C...Find rotation and boost for hard scattering subsystem
13442 I1=MINT(83)+7
13443 I2=MINT(83)+8
13444 BEXCM=(P(I1,1)+P(I2,1))/(P(I1,4)+P(I2,4))
13445 BEYCM=(P(I1,2)+P(I2,2))/(P(I1,4)+P(I2,4))
13446 BEZCM=(P(I1,3)+P(I2,3))/(P(I1,4)+P(I2,4))
13447 GAMCM=(P(I1,4)+P(I2,4))/SHR
13448 BEPCM=BEXCM*P(I1,1)+BEYCM*P(I1,2)+BEZCM*P(I1,3)
13449 PX=P(I1,1)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEXCM
13450 PY=P(I1,2)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEYCM
13451 PZ=P(I1,3)+GAMCM*(GAMCM/(1D0+GAMCM)*BEPCM-P(I1,4))*BEZCM
13452 THECM=PYANGL(PZ,SQRT(PX**2+PY**2))
13453 PHICM=PYANGL(PX,PY)
13454C...Store hard scattering subsystem. Rotate and boost it
13455 SQLAM=(SH-P(IPU5,5)**2-P(IPU6,5)**2)**2-4D0*P(IPU5,5)**2*
13456 & P(IPU6,5)**2
13457 PABS=SQRT(MAX(0D0,SQLAM/(4D0*SH)))
13458 CTHWZ=VINT(23)
13459 STHWZ=SQRT(MAX(0D0,1D0-CTHWZ**2))
13460 PHIWZ=VINT(24)-PHICM
13461 P(IPU5,1)=PABS*STHWZ*COS(PHIWZ)
13462 P(IPU5,2)=PABS*STHWZ*SIN(PHIWZ)
13463 P(IPU5,3)=PABS*CTHWZ
13464 P(IPU5,4)=SQRT(PABS**2+P(IPU5,5)**2)
13465 P(IPU6,1)=-P(IPU5,1)
13466 P(IPU6,2)=-P(IPU5,2)
13467 P(IPU6,3)=-P(IPU5,3)
13468 P(IPU6,4)=SQRT(PABS**2+P(IPU6,5)**2)
13469 CALL PYROBO(IPU5,IPU6,THECM,PHICM,BEXCM,BEYCM,BEZCM)
13470 DO 620 JT=1,2
13471 I1=MINT(83)+8+JT
13472 I2=MINT(84)+4+JT
13473 K(I1,1)=21
13474 K(I1,2)=K(I2,2)
13475 DO 610 J=1,5
13476 P(I1,J)=P(I2,J)
13477 610 CONTINUE
13478 620 CONTINUE
13479 N=IPU6
13480 MINT(7)=MINT(83)+9
13481 MINT(8)=MINT(83)+10
13482 ENDIF
13483
13484 IF(ISET(ISUB).EQ.11) THEN
13485 ELSEIF(IDOC.GE.8) THEN
13486C...Store colour connection indices
13487 DO 630 J=1,2
13488 JC=J
13489 IF(KCS.EQ.-1) JC=3-J
13490 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13491 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)
13492 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13493 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)
13494 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU3,1).EQ.3) K(IPU3,J+3)=
13495 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13496 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13497 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13498 630 CONTINUE
13499
13500C...Copy outgoing partons to documentation lines
13501 IMAX=2
13502 IF(IDOC.EQ.9) IMAX=3
13503 DO 650 I=1,IMAX
13504 I1=MINT(83)+IDOC-IMAX+I
13505 I2=MINT(84)+2+I
13506 K(I1,1)=21
13507 K(I1,2)=K(I2,2)
13508 IF(IDOC.LE.9) K(I1,3)=0
13509 IF(IDOC.GE.11) K(I1,3)=MINT(83)+2+I
13510 DO 640 J=1,5
13511 P(I1,J)=P(I2,J)
13512 640 CONTINUE
13513 650 CONTINUE
13514
13515 ELSEIF(IDOC.EQ.9) THEN
13516C...Store colour connection indices
13517 DO 660 J=1,2
13518 JC=J
13519 IF(KCS.EQ.-1) JC=3-J
13520 IF(ICOL(KCC,1,JC).NE.0.AND.K(IPU1,1).EQ.14) K(IPU1,J+3)=
13521 & K(IPU1,J+3)+MINT(84)+ICOL(KCC,1,JC)+
13522 & MAX(0,MIN(1,ICOL(KCC,1,JC)-2))
13523 IF(ICOL(KCC,2,JC).NE.0.AND.K(IPU2,1).EQ.14) K(IPU2,J+3)=
13524 & K(IPU2,J+3)+MINT(84)+ICOL(KCC,2,JC)+
13525 & MAX(0,MIN(1,ICOL(KCC,2,JC)-2))
13526 IF(ICOL(KCC,3,JC).NE.0.AND.K(IPU4,1).EQ.3) K(IPU4,J+3)=
13527 & MSTU(5)*(MINT(84)+ICOL(KCC,3,JC))
13528 IF(ICOL(KCC,4,JC).NE.0.AND.K(IPU5,1).EQ.3) K(IPU5,J+3)=
13529 & MSTU(5)*(MINT(84)+ICOL(KCC,4,JC))
13530 660 CONTINUE
13531
13532C...Copy outgoing partons to documentation lines
13533 DO 680 I=1,3
13534 I1=MINT(83)+IDOC-3+I
13535 I2=MINT(84)+2+I
13536 K(I1,1)=21
13537 K(I1,2)=K(I2,2)
13538 K(I1,3)=0
13539 DO 670 J=1,5
13540 P(I1,J)=P(I2,J)
13541 670 CONTINUE
13542 680 CONTINUE
13543 ENDIF
13544
13545C...Copy outgoing partons to list of allowed radiators.
13546 NPART=0
13547 IF(MINT(35).GE.2.AND.ISET(ISUB).NE.0) THEN
13548 DO 690 I=MINT(84)+3,N
13549 NPART=NPART+1
13550 IPART(NPART)=I
13551 PTPART(NPART)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2)
13552 690 CONTINUE
13553 ENDIF
13554
13555C...Low-pT events: remove gluons used for string drawing purposes
13556 IF(ISUB.EQ.95) THEN
13557 IF(MINT(35).LE.1) THEN
13558 K(IPU3,1)=K(IPU3,1)+10
13559 K(IPU4,1)=K(IPU4,1)+10
13560 ENDIF
13561 DO 700 J=41,66
13562 VINTSV(J)=VINT(J)
13563 VINT(J)=0D0
13564 700 CONTINUE
13565 DO 720 I=MINT(83)+5,MINT(83)+8
13566 DO 710 J=1,5
13567 P(I,J)=0D0
13568 710 CONTINUE
13569 720 CONTINUE
13570 ENDIF
13571
13572 RETURN
13573 END
13574
13575C***********************************************************************
13576
13577C...PYEVOL
13578C...Handles intertwined pT-ordered spacelike initial-state parton
13579C...and multiple interactions.
13580
13581 SUBROUTINE PYEVOL(MODE,PT2MAX,PT2MIN)
13582C...Mode = -1 : Initialize first time. Determine MAX and MIN scales.
13583C...MODE = 0 : (Re-)initialize ISR/MI evolution.
13584C...Mode = 1 : Evolve event from PT2MAX to PT2MIN.
13585
13586C...Double precision and integer declarations.
13587 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13588 IMPLICIT INTEGER(I-N)
13589 INTEGER PYK,PYCHGE,PYCOMP
13590C...External
13591 EXTERNAL PYALPS
13592 DOUBLE PRECISION PYALPS
13593C...Parameter statement for maximum size of showers.
13594 PARAMETER (MAXNUR=1000)
13595C...Commonblocks.
13596 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13597 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13598 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13599 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13600 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13601 COMMON/PYINT1/MINT(400),VINT(400)
13602 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13603 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13604 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
13605 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
13606 & XMI(2,240),PT2MI(240),IMISEP(0:240)
13607 COMMON/PYCTAG/NCT,MCT(4000,2)
13608 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
13609 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
13610 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
13611C...Local arrays and saved variables.
13612 DIMENSION VINTSV(11:80),KSAV(4,5),PSAV(4,5),VSAV(4,5),SHAT(240)
13613 SAVE NSAV,NPARTS,M15SV,M16SV,M21SV,M22SV,VINTSV,SHAT,ISUBHD,ALAM3
13614 & ,PSAV,KSAV,VSAV
13615
13616 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
13617 & /PYINT2/,/PYINT3/,/PYINTM/,/PYCTAG/,/PYISMX/,/PYISJN/
13618
13619C----------------------------------------------------------------------
13620C...MODE=-1: Pre-initialization. Store info on hard scattering etc,
13621C...done only once per event, while MODE=0 is repeated each time the
13622C...evolution needs to be restarted.
13623 IF (MODE.EQ.-1) THEN
13624 ISUBHD=MINT(1)
13625 NSAV=N
13626 NPARTS=NPART
13627C...Store hard scattering variables
13628 M15SV=MINT(15)
13629 M16SV=MINT(16)
13630 M21SV=MINT(21)
13631 M22SV=MINT(22)
13632 DO 100 J=11,80
13633 VINTSV(J)=VINT(J)
13634 100 CONTINUE
13635 DO 120 J=1,5
13636 DO 110 IS=1,4
13637 I=IS+MINT(84)
13638 PSAV(IS,J)=P(I,J)
13639 KSAV(IS,J)=K(I,J)
13640 VSAV(IS,J)=V(I,J)
13641 110 CONTINUE
13642 120 CONTINUE
13643
13644C...Set shat for hardest scattering
13645 SHAT(1)=VINT(44)
13646 IF(ISET(ISUBHD).GE.3.AND.ISET(ISUBHD).LE.5) SHAT(1)=VINT(26)
13647 & *VINT(2)
13648
13649C...Compute 3-Flavour Lambda_QCD (sets absolute lowest PT scale below)
13650 RMC=PMAS(4,1)
13651 RMB=PMAS(5,1)
13652 ALAM4=PARP(61)
13653 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
13654 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
13655 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
13656
13657C----------------------------------------------------------------------
13658C...MODE= 0: Initialize ISR/MI evolution, i.e. begin from hardest
13659C...interaction initiators, with no previous evolution. Check the input
13660C...PT2MAX and PT2MIN and impose extra constraints on minimum PT2 (e.g.
13661C...must be larger than Lambda_QCD) and maximum PT2 (e.g. must be
13662C...smaller than the CM energy / 2.)
13663 ELSEIF (MODE.EQ.0) THEN
13664C...Reset counters and switches
13665 N=NSAV
13666 NPART=NPARTS
13667 MINT(30)=0
13668 MINT(31)=1
13669 MINT(36)=1
13670C...Reset hard scattering variables
13671 MINT(1)=ISUBHD
13672 DO 130 J=11,80
13673 VINT(J)=VINTSV(J)
13674 130 CONTINUE
13675 DO 150 J=1,5
13676 DO 140 IS=1,4
13677 I=IS+MINT(84)
13678 P(I,J)=PSAV(IS,J)
13679 K(I,J)=KSAV(IS,J)
13680 V(I,J)=VSAV(IS,J)
13681 P(MINT(83)+4+IS,J)=PSAV(IS,J)
13682 V(MINT(83)+4+IS,J)=VSAV(IS,J)
13683 140 CONTINUE
13684 150 CONTINUE
13685C...Reset statistics on activity in event.
13686 DO 160 J=351,359
13687 MINT(J)=0
13688 VINT(J)=0D0
13689 160 CONTINUE
13690C...Reset extra companion reweighting factor
13691 VINT(140)=1D0
13692
13693C...We do not generate MI for soft process (ISUB=95), but the
13694C...initialization must be done regardless, for later purposes.
13695 MINT(36)=1
13696
13697C...Initialize multiple interactions.
13698 CALL PYPTMI(-1,PTDUM1,PTDUM2,PTDUM3,IDUM)
13699 IF(MINT(51).NE.0) RETURN
13700
13701C...Decide whether quarks in hard scattering were valence or sea
13702 PT2HD=VINT(54)
13703 DO 170 JS=1,2
13704 MINT(30)=JS
13705 CALL PYPTMI(2,PT2HD,PTDUM2,PTDUM3,IDUM)
13706 IF(MINT(51).NE.0) RETURN
13707 170 CONTINUE
13708
13709C...Set lower cutoff for PT2 iteration and colour interference PT2 scale
13710 VINT(18)=0D0
13711 PT2MIN=MAX(PT2MIN,(1.1D0*ALAM3)**2)
13712 IF (MSTP(70).EQ.2) THEN
13713C...VINT(18) is freezeout scale of alpha_s: alpha_eff(0) = alpha_s(VINT(18))
13714 VINT(18)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
13715 ELSEIF (MSTP(70).EQ.3) THEN
13716C...MSTP(70) = 3 : Derive VINT(18) from alpha_eff(Lambda3) = PARP(73)
13717 ALPHA0 = MAX(1D-6,PARP(73))
13718 Q20 = ALAM3**2/PARP(64)
13719 IF (MSTP(64).EQ.3) Q20 = Q20 * 1.661**2
13720 VINT(18) = Q20 * (EXP(12*PARU(1)/27D0/ALPHA0)-1D0)
13721 ENDIF
13722C...Also store PT2MIN in VINT(17).
13723 180 VINT(17)=PT2MIN
13724
13725C...Set FS masses zero now.
13726 VINT(63)=0D0
13727 VINT(64)=0D0
13728
13729C...Initialize IS showers with VINT(56) as max scale.
13730 PT2ISR=VINT(56)
13731 PT20=PT2MIN
13732 IF (MSTP(70).EQ.0) THEN
13733 PT20=MAX(PT2MIN,PARP(62)**2)
13734 ELSEIF (MSTP(70).EQ.1) THEN
13735 PT20=MAX(PT2MIN,(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13736 ENDIF
13737 CALL PYPTIS(-1,PT2ISR,PT20,PT2DUM,IFAIL)
13738 IF(MINT(51).NE.0) RETURN
13739
13740 RETURN
13741
13742C----------------------------------------------------------------------
13743C...MODE= 1: Evolve event from PTMAX to PTMIN.
13744 ELSEIF (MODE.EQ.1) THEN
13745
13746C...Skip if no phase space.
13747 190 IF (PT2MAX.LE.PT2MIN) GOTO 330
13748
13749C...Starting pT2 max scale (to be udpated successively).
13750 PT2CMX=PT2MAX
13751
13752C...Evolve two sides of the event to find which branches at highest pT.
13753 200 JSMX=-1
13754 MIMX=0
13755 PT2MX=0D0
13756
13757C...Loop over current shower initiators.
13758 IF (MSTP(61).GE.1) THEN
13759 DO 230 MI=1,MINT(31)
13760 IF (MI.GE.2.AND.MSTP(84).LE.0) GOTO 230
13761 ISUB=96
13762 IF (MI.EQ.1) ISUB=ISUBHD
13763 MINT(1)=ISUB
13764 MINT(36)=MI
13765C...Set up shat, initiator x values, and x remaining in BR.
13766 VINT(44)=SHAT(MI)
13767 VINT(141)=XMI(1,MI)
13768 VINT(142)=XMI(2,MI)
13769 VINT(143)=1D0
13770 VINT(144)=1D0
13771 DO 210 JI=1,MINT(31)
13772 IF (JI.EQ.MINT(36)) GOTO 210
13773 VINT(143)=VINT(143)-XMI(1,JI)
13774 VINT(144)=VINT(144)-XMI(2,JI)
13775 210 CONTINUE
13776C...Loop over sides.
13777C...Generate trial branchings for this interaction. The hardest
13778C...branching so far is automatically updated if necessary in /PYISMX/.
13779 DO 220 JS=1,2
13780 MINT(30)=JS
13781 PT20=PT2MIN
13782 IF (MSTP(70).EQ.0) THEN
13783 PT20=MAX(PT2MIN,PARP(62)**2)
13784 ELSEIF (MSTP(70).EQ.1) THEN
13785 PT20=MAX(PT2MIN,
13786 & (PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2)
13787 ENDIF
13788 CALL PYPTIS(0,PT2CMX,PT20,PT2NEW,IFAIL)
13789 IF (MINT(51).NE.0) RETURN
13790 220 CONTINUE
13791 230 CONTINUE
13792 ENDIF
13793
13794C...Generate trial additional interaction.
13795 MINT(36)=MINT(31)+1
13796 240 IF (MOD(MSTP(81),10).GE.1) THEN
13797 MINT(1)=96
13798C...Set up X remaining in BR.
13799 VINT(143)=1D0
13800 VINT(144)=1D0
13801 DO 250 JI=1,MINT(31)
13802 VINT(143)=VINT(143)-XMI(1,JI)
13803 VINT(144)=VINT(144)-XMI(2,JI)
13804 250 CONTINUE
13805C...Generate trial interaction
13806 260 CALL PYPTMI(0,PT2CMX,PT2MIN,PT2NEW,IFAIL)
13807 IF (MINT(51).EQ.1) RETURN
13808 ENDIF
13809
13810C...And the winner is:
13811 IF (PT2MX.LT.PT2MIN) THEN
13812 GOTO 330
13813 ELSEIF (JSMX.EQ.0) THEN
13814C...Accept additional interaction (may still fail).
13815 CALL PYPTMI(1,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13816 IF(MINT(51).NE.0) RETURN
13817 IF (IFAIL.EQ.0) THEN
13818 SHAT(MINT(36))=VINT(44)
13819C...Decide on flavours (valence/sea/companion).
13820 DO 270 JS=1,2
13821 MINT(30)=JS
13822 CALL PYPTMI(2,PT2NEW,PT2MIN,PT2DUM,IFAIL)
13823 IF(MINT(51).NE.0) RETURN
13824 270 CONTINUE
13825 ENDIF
13826 ELSEIF (JSMX.EQ.1.OR.JSMX.EQ.2) THEN
13827C...Reconstruct kinematics of acceptable ISR branching.
13828C...Set up shat, initiator x values, and x remaining in BR.
13829 MINT(30)=JSMX
13830 MINT(36)=MIMX
13831 VINT(44)=SHAT(MINT(36))
13832 VINT(141)=XMI(1,MINT(36))
13833 VINT(142)=XMI(2,MINT(36))
13834 VINT(143)=1D0
13835 VINT(144)=1D0
13836 DO 280 JI=1,MINT(31)
13837 IF (JI.EQ.MINT(36)) GOTO 280
13838 VINT(143)=VINT(143)-XMI(1,JI)
13839 VINT(144)=VINT(144)-XMI(2,JI)
13840 280 CONTINUE
13841 PT2NEW=PT2MX
13842 CALL PYPTIS(1,PT2NEW,PT2DM1,PT2DM2,IFAIL)
13843 IF (MINT(51).EQ.1) RETURN
13844 ELSEIF (JSMX.EQ.3.OR.JSMX.EQ.4) THEN
13845C...Bookeep joining. Cannot (yet) be constructed kinematically.
13846 MINT(354)=MINT(354)+1
13847 VINT(354)=VINT(354)+SQRT(PT2MX)
13848 IF (MINT(354).EQ.1) VINT(359)=SQRT(PT2MX)
13849 MJOIND(JSMX-2,MJN1MX)=MJN2MX
13850 MJOIND(JSMX-2,MJN2MX)=MJN1MX
13851 ENDIF
13852
13853C...Update PT2 iteration scale.
13854 PT2CMX=PT2MX
13855
13856C...Loop back to continue evolution.
13857 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
13858 CALL PYERRM(11,'(PYEVOL:) no more memory left in PYJETS')
13859 ELSE
13860 IF (JSMX.GE.0.AND.PT2CMX.GE.PT2MIN) GOTO 200
13861 ENDIF
13862
13863C----------------------------------------------------------------------
13864C...MODE= 2: (Re-)store user information on hardest interaction etc.
13865 ELSEIF (MODE.EQ.2) THEN
13866
13867C...Revert to "ordinary" meanings of some parameters.
13868 290 DO 310 JS=1,2
13869 MINT(12+JS)=K(IMI(JS,1,1),2)
13870 VINT(140+JS)=XMI(JS,1)
13871 IF(MINT(18+JS).EQ.1) VINT(140+JS)=VINT(154+JS)*XMI(JS,1)
13872 VINT(142+JS)=1D0
13873 DO 300 MI=1,MINT(31)
13874 VINT(142+JS)=VINT(142+JS)-XMI(JS,MI)
13875 300 CONTINUE
13876 310 CONTINUE
13877
13878C...Restore saved quantities for hardest interaction.
13879 MINT(1)=ISUBHD
13880 MINT(15)=M15SV
13881 MINT(16)=M16SV
13882 MINT(21)=M21SV
13883 MINT(22)=M22SV
13884 DO 320 J=11,80
13885 VINT(J)=VINTSV(J)
13886 320 CONTINUE
13887
13888 ENDIF
13889
13890 330 RETURN
13891 END
13892
13893C*********************************************************************
13894
13895C...PYSSPA
13896C...Generates spacelike parton showers.
13897
13898 SUBROUTINE PYSSPA(IPU1,IPU2)
13899
13900C...Double precision and integer declarations.
13901 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
13902 IMPLICIT INTEGER(I-N)
13903 INTEGER PYK,PYCHGE,PYCOMP
13904 PARAMETER (MAXNUR=1000)
13905C...Commonblocks.
13906 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
13907 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
13908 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
13909 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
13910 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
13911 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
13912 COMMON/PYINT1/MINT(400),VINT(400)
13913 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
13914 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
13915 COMMON/PYCTAG/NCT,MCT(4000,2)
13916 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,
13917 &/PYINT1/,/PYINT2/,/PYINT3/,/PYCTAG/
13918C...Local arrays and data.
13919 DIMENSION KFLS(4),IS(2),XS(2),ZS(2),Q2S(2),TEVCSV(2),TEVESV(2),
13920 &XFS(2,-25:25),XFA(-25:25),XFB(-25:25),XFN(-25:25),WTAPC(-25:25),
13921 &WTAPE(-25:25),WTSF(-25:25),THE2(2),ALAM(2),DQ2(3),DPC(3),DPD(4),
13922 &DPB(4),ROBO(5),MORE(2),KFBEAM(2),Q2MNCS(2),KCFI(2),NFIS(2),
13923 &THEFIS(2,2),ISFI(2),DPHI(2),MCESV(2)
13924 DATA IS/2*0/
13925
13926C...Read out basic information; set global Q^2 scale.
13927 IPUS1=IPU1
13928 IPUS2=IPU2
13929 ISUB=MINT(1)
13930 Q2MX=VINT(56)
13931 VINT2R=VINT(2)*VINT(143)*VINT(144)
13932 IF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.9.OR.ISET(ISUB).EQ.11) Q2MX=
13933 &MIN(VINT2R,PARP(67)*VINT(56))
13934 FCQ2MX=1D0
13935
13936C...Define which processes ME corrections have been implemented for.
13937 MECOR=0
13938 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
13939 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ.142.OR.
13940 & ISUB.EQ.144) MECOR=1
13941 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
13942 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
13943 ENDIF
13944
13945C...Initialize QCD evolution and check phase space.
13946 Q2MNC=PARP(62)**2
13947 Q2MNCS(1)=Q2MNC
13948 Q2MNCS(2)=Q2MNC
13949 IF(MINT(107).EQ.2.AND.MSTP(66).EQ.2) THEN
13950 Q0S=PARP(15)**2
13951 PS=VINT(3)**2
13952 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13953 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13954 Q2INT=SQRT(Q0S*Q2EFF)
13955 Q2MNCS(1)=MAX(Q2MNC,Q2INT)
13956 ELSEIF(MINT(107).EQ.3.AND.MSTP(66).GE.1) THEN
13957 Q2MNCS(1)=MAX(Q2MNC,VINT(283))
13958 ENDIF
13959 IF(MINT(108).EQ.2.AND.MSTP(66).EQ.2) THEN
13960 Q0S=PARP(15)**2
13961 PS=VINT(4)**2
13962 Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
13963 & EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
13964 Q2INT=SQRT(Q0S*Q2EFF)
13965 Q2MNCS(2)=MAX(Q2MNC,Q2INT)
13966 ELSEIF(MINT(108).EQ.3.AND.MSTP(66).GE.1) THEN
13967 Q2MNCS(2)=MAX(Q2MNC,VINT(284))
13968 ENDIF
13969 MCEV=0
13970 ALAMS=PARU(112)
13971 PARU(112)=PARP(61)
13972 FQ2C=1D0
13973 TCMX=0D0
13974 IF(MINT(47).GE.2.AND.(MINT(47).LT.5.OR.MSTP(12).GE.1)) THEN
13975 MCEV=1
13976 IF(MSTP(64).EQ.1) FQ2C=PARP(63)
13977 IF(MSTP(64).EQ.2) FQ2C=PARP(64)
13978 TCMX=LOG(FQ2C*Q2MX/PARP(61)**2)
13979 IF(Q2MX.LT.MAX(Q2MNC,2D0*PARP(61)**2).OR.TCMX.LT.0.2D0)
13980 & MCEV=0
13981 ENDIF
13982
13983C...Initialize QED evolution and check phase space.
13984 MEEV=0
13985 XEE=1D-10
13986 SPME=PMAS(11,1)**2
13987 IF(IABS(MINT(11)).EQ.13.OR.IABS(MINT(12)).EQ.13)
13988 &SPME=PMAS(13,1)**2
13989 IF(IABS(MINT(11)).EQ.15.OR.IABS(MINT(12)).EQ.15)
13990 &SPME=PMAS(15,1)**2
13991 Q2MNE=MAX(PARP(68)**2,2D0*SPME)
13992 TEMX=0D0
13993 FWTE=10D0
13994 IF(MINT(45).EQ.3.OR.MINT(46).EQ.3) THEN
13995 MEEV=1
13996 TEMX=LOG(Q2MX/SPME)
13997 IF(Q2MX.LE.Q2MNE.OR.TEMX.LT.0.2D0) MEEV=0
13998 ENDIF
13999 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0) THEN
14000 MEEV=2
14001 TEMX=TCMX
14002 FWTE=1D0
14003 ENDIF
14004 IF(MCEV.EQ.0.AND.MEEV.EQ.0) RETURN
14005
14006C...Loopback point in case of failure to reconstruct kinematics.
14007 NS=N
14008 NPARTS=NPART
14009 LOOP=0
14010 MNT352=MINT(352)
14011 MNT353=MINT(353)
14012 VNT352=VINT(352)
14013 VNT353=VINT(353)
14014 100 LOOP=LOOP+1
14015 IF(LOOP.GT.100) THEN
14016 MINT(51)=1
14017 RETURN
14018 ENDIF
14019 N=NS
14020 NPART=NPARTS
14021 MINT(352)=MNT352
14022 MINT(353)=MNT353
14023 VINT(352)=VNT352
14024 VINT(353)=VNT353
14025
14026C...Initial values: flavours, momenta, virtualities.
14027 DO 120 JT=1,2
14028 MORE(JT)=1
14029 KFBEAM(JT)=MINT(10+JT)
14030 IF(MINT(18+JT).EQ.1)KFBEAM(JT)=22
14031 KFLS(JT)=MINT(14+JT)
14032 KFLS(JT+2)=KFLS(JT)
14033 XS(JT)=VINT(40+JT)
14034 IF(MINT(18+JT).EQ.1) XS(JT)=VINT(40+JT)/VINT(154+JT)
14035 IF(MINT(31).GE.2) XS(JT)=XS(JT)/VINT(142+JT)
14036 ZS(JT)=1D0
14037 Q2S(JT)=FCQ2MX*Q2MX
14038 DQ2(JT)=0D0
14039 TEVCSV(JT)=TCMX
14040 ALAM(JT)=PARP(61)
14041 THE2(JT)=1D0
14042 TEVESV(JT)=TEMX
14043 MCESV(JT)=0
14044C...Calculate initial parton distribution weights.
14045 MINT(105)=MINT(102+JT)
14046 MINT(109)=MINT(106+JT)
14047 VINT(120)=VINT(2+JT)
14048C.... ALICE
14049C.... Store side in MINT(124)
14050 MINT(124) = JT
14051C....
14052 IF(XS(JT).LT.1D0-XEE) THEN
14053 IF(MINT(31).GE.2) MINT(30)=JT
14054 IF(MSTP(57).LE.1) THEN
14055 CALL PYPDFU(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
14056 ELSE
14057 CALL PYPDFL(KFBEAM(JT),XS(JT),Q2S(JT),XFB)
14058 ENDIF
14059 ENDIF
14060 DO 110 KFL=-25,25
14061 XFS(JT,KFL)=XFB(KFL)
14062 110 CONTINUE
14063C...Special kinematics check for c/b quarks (that g -> c cbar or
14064C...b bbar kinematically possible).
14065 KFLCB=IABS(KFLS(JT))
14066 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14067 IF(XS(JT).GT.0.9D0*Q2S(JT)/(PMAS(KFLCB,1)**2+Q2S(JT))) THEN
14068 MINT(51)=1
14069 RETURN
14070 ENDIF
14071 ENDIF
14072 120 CONTINUE
14073 DSH=VINT(44)
14074 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) DSH=VINT(26)*VINT(2)
14075
14076C...Find if interference with final state partons.
14077 MFIS=0
14078 IF(MSTP(67).GE.1.AND.MSTP(67).LE.3) MFIS=MSTP(67)
14079 IF(MFIS.NE.0) THEN
14080 DO 140 I=1,2
14081 KCFI(I)=0
14082 KCA=PYCOMP(IABS(KFLS(I)))
14083 IF(KCA.NE.0) KCFI(I)=KCHG(KCA,2)*ISIGN(1,KFLS(I))
14084 NFIS(I)=0
14085 IF(KCFI(I).NE.0) THEN
14086 IF(I.EQ.1) IPFS=IPUS1
14087 IF(I.EQ.2) IPFS=IPUS2
14088 DO 130 J=1,2
14089 ICSI=MOD(K(IPFS,3+J),MSTU(5))
14090 IF(ICSI.GT.0.AND.ICSI.NE.IPUS1.AND.ICSI.NE.IPUS2.AND.
14091 & (KCFI(I).EQ.(-1)**(J+1).OR.KCFI(I).EQ.2)) THEN
14092 NFIS(I)=NFIS(I)+1
14093 THEFIS(I,NFIS(I))=PYANGL(P(ICSI,3),SQRT(P(ICSI,1)**2+
14094 & P(ICSI,2)**2))
14095 IF(I.EQ.2) THEFIS(I,NFIS(I))=PARU(1)-THEFIS(I,NFIS(I))
14096 ENDIF
14097 130 CONTINUE
14098 ENDIF
14099 140 CONTINUE
14100 IF(NFIS(1)+NFIS(2).EQ.0) MFIS=0
14101 ENDIF
14102
14103C...Pick up leg with highest virtuality.
14104 JTOLD=1
14105 150 N=N+1
14106 JT=1
14107 IF(N.GT.NS+1.AND.Q2S(2).GT.Q2S(1)) JT=2
14108 IF(N.EQ.NS+2.AND.JT.EQ.JTOLD) JT=3-JT
14109 IF(MORE(JT).EQ.0) JT=3-JT
14110 JTOLD=JT
14111 KFLB=KFLS(JT)
14112 XB=XS(JT)
14113 DO 160 KFL=-25,25
14114 XFB(KFL)=XFS(JT,KFL)
14115 160 CONTINUE
14116 DSHR=2D0*SQRT(DSH)
14117 DSHZ=DSH/ZS(JT)
14118
14119C...Check if allowed to branch.
14120 MCEV=0
14121 IF(IABS(KFLB).LE.10.OR.KFLB.EQ.21) THEN
14122 MCEV=1
14123 XEC=MAX(PARP(65)*DSHR/VINT2R,XB*(1D0/(1D0-PARP(66))-1D0))
14124 IF(XB.GE.1D0-2D0*XEC) MCEV=0
14125 ENDIF
14126 MEEV=0
14127 IF(MINT(44+JT).EQ.3) THEN
14128 MEEV=1
14129 IF(XB.GE.1D0-2D0*XEE) MEEV=0
14130 IF((IABS(KFLB).LE.10.OR.KFLB.EQ.21).AND.XB.GE.1D0-2D0*XEC)
14131 & MEEV=0
14132C***Currently kill QED shower for resolved photoproduction.
14133 IF(MINT(18+JT).EQ.1) MEEV=0
14134C***Currently kill shower for W inside electron.
14135 IF(IABS(KFLB).EQ.24) THEN
14136 MCEV=0
14137 MEEV=0
14138 ENDIF
14139 ENDIF
14140 IF(MSTP(61).GE.2.AND.MCEV.EQ.1.AND.MEEV.EQ.0.AND.IABS(KFLB).LE.10)
14141 &MEEV=2
14142 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
14143 Q2B=0D0
14144 GOTO 260
14145 ENDIF
14146
14147C...Maximum Q2 with or without Q2 ordering. Effective Lambda and n_f.
14148 Q2B=Q2S(JT)
14149 TEVCB=TEVCSV(JT)
14150 TEVEB=TEVESV(JT)
14151 IF(MSTP(62).LE.1) THEN
14152 IF(ZS(JT).GT.0.99999D0) THEN
14153 Q2B=Q2S(JT)
14154 ELSE
14155 Q2B=0.5D0*(1D0/ZS(JT)+1D0)*Q2S(JT)+0.5D0*(1D0/ZS(JT)-1D0)*
14156 & (Q2S(3-JT)-DSH+SQRT((DSH+Q2S(1)+Q2S(2))**2+
14157 & 8D0*Q2S(1)*Q2S(2)*ZS(JT)/(1D0-ZS(JT))))
14158 ENDIF
14159 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14160 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
14161 ENDIF
14162 IF(MCEV.EQ.1) THEN
14163 ALSDUM=PYALPS(FQ2C*Q2B)
14164 TEVCB=TEVCB+2D0*LOG(ALAM(JT)/PARU(117))
14165 ALAM(JT)=PARU(117)
14166 B0=(33D0-2D0*MSTU(118))/6D0
14167 ENDIF
14168 IF(MEEV.EQ.2) TEVEB=TEVCB
14169 TEVCBS=TEVCB
14170 TEVEBS=TEVEB
14171
14172C...Select side for interference with final state partons.
14173 IF(MFIS.GE.1.AND.N.LE.NS+2) THEN
14174 IFI=N-NS
14175 ISFI(IFI)=0
14176 IF(IABS(KCFI(IFI)).EQ.1.AND.NFIS(IFI).EQ.1) THEN
14177 ISFI(IFI)=1
14178 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.1) THEN
14179 IF(PYR(0).GT.0.5D0) ISFI(IFI)=1
14180 ELSEIF(KCFI(IFI).EQ.2.AND.NFIS(IFI).EQ.2) THEN
14181 ISFI(IFI)=1
14182 IF(PYR(0).GT.0.5D0) ISFI(IFI)=2
14183 ENDIF
14184 ENDIF
14185
14186C...Calculate preweighting factor for ME-corrected processes.
14187 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14188
14189C...Calculate Altarelli-Parisi weights.
14190 DO 170 KFL=-25,25
14191 WTAPC(KFL)=0D0
14192 WTAPE(KFL)=0D0
14193 WTSF(KFL)=0D0
14194 170 CONTINUE
14195C...q -> q (g or gamma emission), g -> q.
14196 IF(IABS(KFLB).LE.10) THEN
14197 WTAPC(KFLB)=(8D0/3D0)*LOG((1D0-XEC-XB)*(XB+XEC)/(XEC*(1D0-XEC)))
14198 WTAPC(21)=0.5D0*(XB/(XB+XEC)-XB/(1D0-XEC))
14199 EQ2=1D0/9D0
14200 IF(MOD(IABS(KFLB),2).EQ.0) EQ2=4D0*EQ2
14201 IF(MEEV.EQ.2) WTAPE(KFLB)=2.*EQ2*LOG((1D0-XEC-XB)*(XB+XEC)/
14202 & (XEC*(1D0-XEC)))
14203 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14204 WTAPC(KFLB)=WTFF*WTAPC(KFLB)
14205 WTAPC(21)=WTGF*WTAPC(21)
14206 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
14207 ENDIF
14208C...f -> f, gamma -> f.
14209 ELSEIF(IABS(KFLB).LE.20) THEN
14210 WTAPF1=LOG((1D0-XEE-XB)*(XB+XEE)/(XEE*(1D0-XEE)))
14211 WTAPF2=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))
14212 WTAPE(KFLB)=2D0*(WTAPF1+WTAPF2)
14213 IF(MSTP(12).GE.1) WTAPE(22)=XB/(XB+XEE)-XB/(1D0-XEE)
14214 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14215 WTAPE(KFLB)=WTFF*WTAPE(KFLB)
14216 WTAPE(22)=WTGF*WTAPE(22)
14217 ENDIF
14218C...f -> g, g -> g.
14219 ELSEIF(KFLB.EQ.21) THEN
14220 WTAPQ=(16D0/3D0)*(SQRT((1D0-XEC)/XB)-SQRT((XB+XEC)/XB))
14221 DO 180 KFL=1,MSTP(58)
14222 WTAPC(KFL)=WTAPQ
14223 WTAPC(-KFL)=WTAPQ
14224 180 CONTINUE
14225 WTAPC(21)=6D0*LOG((1D0-XEC-XB)/XEC)
14226 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14227 DO 190 KFL=1,MSTP(58)
14228 WTAPC(KFL)=WTFG*WTAPC(KFL)
14229 WTAPC(-KFL)=WTFG*WTAPC(-KFL)
14230 190 CONTINUE
14231 WTAPC(21)=WTGG*WTAPC(21)
14232 ENDIF
14233C...f -> gamma, W+, W-.
14234 ELSEIF(KFLB.EQ.22) THEN
14235 WTAPF=LOG((1D0-XEE-XB)*(1D0-XEE)/(XEE*(XB+XEE)))/XB
14236 WTAPE(11)=WTAPF
14237 WTAPE(-11)=WTAPF
14238 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14239 WTAPE(11)=WTFG*WTAPE(11)
14240 WTAPE(-11)=WTFG*WTAPE(-11)
14241 ENDIF
14242 ELSEIF(KFLB.EQ.24) THEN
14243 WTAPE(-11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
14244 & (XEE*(XB+XEE)))/XB
14245 ELSEIF(KFLB.EQ.-24) THEN
14246 WTAPE(11)=1D0/(4D0*PARU(102))*LOG((1D0-XEE-XB)*(1D0-XEE)/
14247 & (XEE*(XB+XEE)))/XB
14248 ENDIF
14249
14250C...Calculate parton distribution weights and sum.
14251 NTRY=0
14252 200 NTRY=NTRY+1
14253 IF(NTRY.GT.500) THEN
14254 MINT(51)=1
14255 RETURN
14256 ENDIF
14257 WTSUMC=0D0
14258 WTSUME=0D0
14259 XFBO=MAX(1D-10,XFB(KFLB))
14260 DO 210 KFL=-25,25
14261 WTSF(KFL)=XFB(KFL)/XFBO
14262 WTSUMC=WTSUMC+WTAPC(KFL)*WTSF(KFL)
14263 WTSUME=WTSUME+WTAPE(KFL)*WTSF(KFL)
14264 210 CONTINUE
14265 WTSUMC=MAX(0.0001D0,WTSUMC)
14266 WTSUME=MAX(0.0001D0/FWTE,WTSUME)
14267
14268C...Choose new t: fix alpha_s, alpha_s(Q^2), alpha_s(k_T^2).
14269 NTRY2=0
14270 220 NTRY2=NTRY2+1
14271 IF(NTRY2.GT.500) THEN
14272 MINT(51)=1
14273 RETURN
14274 ENDIF
14275 IF(MCEV.EQ.1) THEN
14276 IF(MSTP(64).LE.0) THEN
14277 TEVCB=TEVCB+LOG(PYR(0))*PARU(2)/(PARU(111)*WTSUMC)
14278 ELSEIF(MSTP(64).EQ.1) THEN
14279 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/WTSUMC))
14280 ELSE
14281 TEVCB=TEVCB*EXP(MAX(-50D0,LOG(PYR(0))*B0/(5D0*WTSUMC)))
14282 ENDIF
14283 ENDIF
14284 IF(MEEV.EQ.1) THEN
14285 TEVEB=TEVEB*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
14286 & (PARU(101)*FWTE*WTSUME*TEMX)))
14287 ELSEIF(MEEV.EQ.2) THEN
14288 TEVEB=TEVEB+LOG(PYR(0))*PARU(2)/(PARU(101)*WTSUME)
14289 ENDIF
14290
14291C...Translate t into Q2 scale; choose between QCD and QED evolution.
14292 230 IF(MCEV.EQ.1) Q2CB=ALAM(JT)**2*EXP(MAX(-50D0,TEVCB))/FQ2C
14293 IF(MEEV.EQ.1) Q2EB=SPME*EXP(MAX(-50D0,TEVEB))
14294 IF(MEEV.EQ.2) Q2EB=ALAM(JT)**2*EXP(MAX(-50D0,TEVEB))/FQ2C
14295C...Ensure that Q2 is above threshold for charm/bottom.
14296 KFLCB=IABS(KFLB)
14297 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14298 &MCEV.EQ.1) THEN
14299 IF(Q2CB.LT.PMAS(KFLCB,1)**2) THEN
14300 Q2CB=1.1D0*PMAS(KFLCB,1)**2
14301 TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14302 FCQ2MX=MIN(2D0,1.05D0*FCQ2MX)
14303 ENDIF
14304 ENDIF
14305 IF(KFBEAM(JT).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5).AND.
14306 &MEEV.EQ.2) THEN
14307 IF(Q2EB.LT.PMAS(KFLCB,1)**2) MEEV=0
14308 ENDIF
14309 MCE=0
14310 IF(MCEV.EQ.0.AND.MEEV.EQ.0) THEN
14311 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.0) THEN
14312 IF(Q2CB.GT.Q2MNCS(JT)) MCE=1
14313 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.1) THEN
14314 IF(Q2EB.GT.Q2MNE) MCE=2
14315 ELSEIF(MCEV.EQ.0.AND.MEEV.EQ.2) THEN
14316 IF(Q2EB.GT.Q2MNCS(JT)) MCE=2
14317 ELSEIF(MCEV.EQ.1.AND.MEEV.EQ.2) THEN
14318 IF(Q2CB.GT.Q2EB.AND.Q2CB.GT.Q2MNCS(JT)) MCE=1
14319 IF(Q2EB.GT.Q2CB.AND.Q2EB.GT.Q2MNCS(JT)) MCE=2
14320 ELSEIF(Q2MNCS(JT).GT.Q2MNE) THEN
14321 MCE=1
14322 IF(Q2EB.GT.Q2CB.OR.Q2CB.LE.Q2MNCS(JT)) MCE=2
14323 IF(MCE.EQ.2.AND.Q2EB.LE.Q2MNE) MCE=0
14324 ELSE
14325 MCE=2
14326 IF(Q2CB.GT.Q2EB.OR.Q2EB.LE.Q2MNE) MCE=1
14327 IF(MCE.EQ.1.AND.Q2CB.LE.Q2MNCS(JT)) MCE=0
14328 ENDIF
14329
14330C...Evolution possibly ended. Update t values.
14331 IF(MCE.EQ.0) THEN
14332 Q2B=0D0
14333 GOTO 260
14334 ELSEIF(MCE.EQ.1) THEN
14335 Q2B=Q2CB
14336 Q2REF=FQ2C*Q2B
14337 IF(MEEV.EQ.1) TEVEB=LOG(Q2B/SPME)
14338 IF(MEEV.EQ.2) TEVEB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14339 ELSE
14340 Q2B=Q2EB
14341 Q2REF=Q2B
14342 IF(MCEV.EQ.1) TEVCB=LOG(FQ2C*Q2B/ALAM(JT)**2)
14343 ENDIF
14344
14345C...Select flavour for branching parton.
14346 IF(MCE.EQ.1) WTRAN=PYR(0)*WTSUMC
14347 IF(MCE.EQ.2) WTRAN=PYR(0)*WTSUME
14348 KFLA=-25
14349 240 KFLA=KFLA+1
14350 IF(MCE.EQ.1) WTRAN=WTRAN-WTAPC(KFLA)*WTSF(KFLA)
14351 IF(MCE.EQ.2) WTRAN=WTRAN-WTAPE(KFLA)*WTSF(KFLA)
14352 IF(KFLA.LE.24.AND.WTRAN.GT.0D0) GOTO 240
14353 IF(KFLA.EQ.25) THEN
14354 Q2B=0D0
14355 GOTO 260
14356 ENDIF
14357
14358C...Choose z value and corrective weight.
14359 WTZ=0D0
14360C...q -> q + g or q -> q + gamma.
14361 IF(IABS(KFLA).LE.10.AND.IABS(KFLB).LE.10) THEN
14362 Z=1D0-((1D0-XB-XEC)/(1D0-XEC))*
14363 & (XEC*(1D0-XEC)/((XB+XEC)*(1D0-XB-XEC)))**PYR(0)
14364 WTZ=0.5D0*(1D0+Z**2)
14365C...q -> g + q.
14366 ELSEIF(IABS(KFLA).LE.10.AND.KFLB.EQ.21) THEN
14367 Z=XB/(SQRT(XB+XEC)+PYR(0)*(SQRT(1D0-XEC)-SQRT(XB+XEC)))**2
14368 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
14369C...f -> f + gamma.
14370 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14371 IF(WTAPF1.GT.PYR(0)*(WTAPF1+WTAPF2)) THEN
14372 Z=1D0-((1D0-XB-XEE)/(1D0-XEE))*
14373 & (XEE*(1D0-XEE)/((XB+XEE)*(1D0-XB-XEE)))**PYR(0)
14374 ELSE
14375 Z=XB+XB*(XEE/(1D0-XEE))*
14376 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14377 ENDIF
14378 WTZ=0.5D0*(1D0+Z**2)*(Z-XB)/(1D0-XB)
14379C...f -> gamma + f.
14380 ELSEIF(IABS(KFLA).LE.20.AND.KFLB.EQ.22) THEN
14381 Z=XB+XB*(XEE/(1D0-XEE))*
14382 & ((1D0-XB-XEE)*(1D0-XEE)/(XEE*(XB+XEE)))**PYR(0)
14383 WTZ=0.5D0*(1D0+(1D0-Z)**2)*XB*(Z-XB)/Z
14384C...f -> W+- + f.
14385 ELSEIF(IABS(KFLA).LE.20.AND.IABS(KFLB).EQ.24) 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)*
14389 & (Q2B/(Q2B+PMAS(24,1)**2))
14390C...g -> q + qbar.
14391 ELSEIF(KFLA.EQ.21.AND.IABS(KFLB).LE.10) THEN
14392 Z=XB/(1D0-XEC)+PYR(0)*(XB/(XB+XEC)-XB/(1D0-XEC))
14393 WTZ=1D0-2D0*Z*(1D0-Z)
14394C...g -> g + g.
14395 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14396 Z=1D0/(1D0+((1D0-XEC-XB)/XB)*(XEC/(1D0-XEC-XB))**PYR(0))
14397 WTZ=(1D0-Z*(1D0-Z))**2
14398C...gamma -> f + fbar.
14399 ELSEIF(KFLA.EQ.22.AND.IABS(KFLB).LE.20) THEN
14400 Z=XB/(1D0-XEE)+PYR(0)*(XB/(XB+XEE)-XB/(1D0-XEE))
14401 WTZ=1D0-2D0*Z*(1D0-Z)
14402 ENDIF
14403 IF(MCE.EQ.2.AND.MEEV.EQ.1) WTZ=(WTZ/FWTE)*(TEVEB/TEMX)
14404
14405C...Option with resummation of soft gluon emission as effective z shift.
14406 IF(MCE.EQ.1) THEN
14407 IF(MSTP(65).GE.1) THEN
14408 RSOFT=6D0
14409 IF(KFLB.NE.21) RSOFT=8D0/3D0
14410 Z=Z*(TEVCB/TEVCSV(JT))**(RSOFT*XEC/((XB+XEC)*B0))
14411 IF(Z.LE.XB) GOTO 220
14412 ENDIF
14413
14414C...Option with alpha_s(k_T^2): demand k_T^2 > cutoff, reweight.
14415 IF(MSTP(64).GE.2) THEN
14416 IF((1D0-Z)*Q2B.LT.Q2MNCS(JT)) GOTO 220
14417 ALPRAT=TEVCB/(TEVCB+LOG(1D0-Z))
14418 IF(ALPRAT.LT.5D0*PYR(0)) GOTO 220
14419 IF(ALPRAT.GT.5D0) WTZ=WTZ*ALPRAT/5D0
14420 ENDIF
14421 ENDIF
14422
14423C...Remove kinematically impossible branchings.
14424 UHAT=Q2B-DSH*(1D0-Z)/Z
14425 IF(MSTP(68).GE.0.AND.UHAT.GT.0D0) GOTO 220
14426
14427C...Select phi angle of branching at random.
14428 PHIBR=PARU(2)*PYR(0)
14429
14430C...Matrix-element corrections for some processes.
14431 IF(MECOR.GE.1.AND.(N.EQ.NS+1.OR.N.EQ.NS+2)) THEN
14432 IF(IABS(KFLA).LE.20.AND.IABS(KFLB).LE.20) THEN
14433 CALL PYMEWT(MECOR,1,Q2B,Z,PHIBR,WTME)
14434 WTZ=WTZ*WTME/WTFF
14435 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.IABS(KFLB).LE.20) THEN
14436 CALL PYMEWT(MECOR,2,Q2B,Z,PHIBR,WTME)
14437 WTZ=WTZ*WTME/WTGF
14438 ELSEIF(IABS(KFLA).LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
14439 CALL PYMEWT(MECOR,3,Q2B,Z,PHIBR,WTME)
14440 WTZ=WTZ*WTME/WTFG
14441 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
14442 CALL PYMEWT(MECOR,4,Q2B,Z,PHIBR,WTME)
14443 WTZ=WTZ*WTME/WTGG
14444 ENDIF
14445 ENDIF
14446
14447C...Impose angular constraint in first branching from interference
14448C...with final state partons.
14449 IF(MCE.EQ.1) THEN
14450 IF(MFIS.GE.1.AND.N.LE.NS+2.AND.NTRY2.LT.200) THEN
14451 THE2D=(4D0*Q2B)/(DSH*(1D0-Z))
14452 IF(N.EQ.NS+1.AND.ISFI(1).GE.1) THEN
14453 IF(THE2D.GT.THEFIS(1,ISFI(1))**2) GOTO 220
14454 ELSEIF(N.EQ.NS+2.AND.ISFI(2).GE.1) THEN
14455 IF(THE2D.GT.THEFIS(2,ISFI(2))**2) GOTO 220
14456 ENDIF
14457 ENDIF
14458
14459C...Option with angular ordering requirement.
14460 IF(MSTP(62).GE.3.AND.NTRY2.LT.200) THEN
14461 THE2T=(4D0*Z**2*Q2B)/(4D0*Z**2*Q2B+(1D0-Z)*XB**2*VINT2R)
14462 IF(THE2T.GT.THE2(JT)) GOTO 220
14463 ENDIF
14464 ENDIF
14465
14466C...Weighting with new parton distributions.
14467 MINT(105)=MINT(102+JT)
14468 MINT(109)=MINT(106+JT)
14469 VINT(120)=VINT(2+JT)
14470 IF(MINT(31).GE.2) MINT(30)=JT
14471C.... ALICE
14472C.... Store side in MINT(124)
14473 MINT(124) = JT
14474C....
14475 IF(MSTP(57).LE.1) THEN
14476 CALL PYPDFU(KFBEAM(JT),XB,Q2REF,XFN)
14477 ELSE
14478 CALL PYPDFL(KFBEAM(JT),XB,Q2REF,XFN)
14479 ENDIF
14480 XFBN=XFN(KFLB)
14481 IF(XFBN.LT.1D-20) THEN
14482 IF(KFLA.EQ.KFLB) THEN
14483 TEVCB=TEVCBS
14484 TEVEB=TEVEBS
14485 WTAPC(KFLB)=0D0
14486 WTAPE(KFLB)=0D0
14487 GOTO 200
14488 ELSEIF(MCE.EQ.1.AND.TEVCBS-TEVCB.GT.0.2D0) THEN
14489 TEVCB=0.5D0*(TEVCBS+TEVCB)
14490 GOTO 230
14491 ELSEIF(MCE.EQ.2.AND.TEVEBS-TEVEB.GT.0.2D0) THEN
14492 TEVEB=0.5D0*(TEVEBS+TEVEB)
14493 GOTO 230
14494 ELSE
14495 XFBN=1D-10
14496 XFN(KFLB)=XFBN
14497 ENDIF
14498 ENDIF
14499 DO 250 KFL=-25,25
14500 XFB(KFL)=XFN(KFL)
14501 250 CONTINUE
14502 XA=XB/Z
14503C.... ALICE
14504C.... Store side in MINT(124)
14505 MINT(124) = JT
14506C....
14507 IF(MINT(31).GE.2) MINT(30)=JT
14508 IF(MSTP(57).LE.1) THEN
14509 CALL PYPDFU(KFBEAM(JT),XA,Q2REF,XFA)
14510 ELSE
14511 CALL PYPDFL(KFBEAM(JT),XA,Q2REF,XFA)
14512 ENDIF
14513 XFAN=XFA(KFLA)
14514 IF(XFAN.LT.1D-20) GOTO 200
14515 WTSFA=WTSF(KFLA)
14516 IF(WTZ*XFAN/XFBN.LT.PYR(0)*WTSFA) GOTO 200
14517
14518C...Define two hard scatterers in their CM-frame.
14519 260 IF(N.EQ.NS+2) THEN
14520 DQ2(JT)=Q2B
14521 DPLCM=SQRT((DSH+DQ2(1)+DQ2(2))**2-4D0*DQ2(1)*DQ2(2))/DSHR
14522 DO 280 JR=1,2
14523 I=NS+JR
14524 IF(JR.EQ.1) IPO=IPUS1
14525 IF(JR.EQ.2) IPO=IPUS2
14526 DO 270 J=1,5
14527 K(I,J)=0
14528 P(I,J)=0D0
14529 V(I,J)=0D0
14530 270 CONTINUE
14531 K(I,1)=14
14532 K(I,2)=KFLS(JR+2)
14533 K(I,4)=IPO
14534 K(I,5)=IPO
14535 P(I,3)=DPLCM*(-1)**(JR+1)
14536 P(I,4)=(DSH+DQ2(3-JR)-DQ2(JR))/DSHR
14537 P(I,5)=-SQRT(DQ2(JR))
14538 K(IPO,1)=14
14539 K(IPO,3)=I
14540 K(IPO,4)=MOD(K(IPO,4),MSTU(5))+MSTU(5)*I
14541 K(IPO,5)=MOD(K(IPO,5),MSTU(5))+MSTU(5)*I
14542 MCT(I,1)=MCT(IPO,1)
14543 MCT(I,2)=MCT(IPO,2)
14544 280 CONTINUE
14545
14546C...Find maximum allowed mass of timelike parton.
14547 ELSEIF(N.GT.NS+2) THEN
14548 JR=3-JT
14549 DQ2(3)=Q2B
14550 DPC(1)=P(IS(1),4)
14551 DPC(2)=P(IS(2),4)
14552 DPC(3)=0.5D0*(ABS(P(IS(1),3))+ABS(P(IS(2),3)))
14553 DPD(1)=DSH+DQ2(JR)+DQ2(JT)
14554 DPD(2)=DSHZ+DQ2(JR)+DQ2(3)
14555 DPD(3)=SQRT(DPD(1)**2-4D0*DQ2(JR)*DQ2(JT))
14556 DPD(4)=SQRT(DPD(2)**2-4D0*DQ2(JR)*DQ2(3))
14557 IKIN=0
14558 IF(Q2S(JR).GE.0.25D0*Q2MNC.AND.DPD(1)-DPD(3).GE.
14559 & 1D-10*DPD(1)) IKIN=1
14560 IF(IKIN.EQ.0) DMSMA=(DQ2(JT)/ZS(JT)-DQ2(3))*
14561 & (DSH/(DSH+DQ2(JT))-DSH/(DSHZ+DQ2(3)))
14562 IF(IKIN.EQ.1) DMSMA=(DPD(1)*DPD(2)-DPD(3)*DPD(4))/
14563 & (2D0*DQ2(JR))-DQ2(JT)-DQ2(3)
14564
14565C...Generate timelike parton shower (if required).
14566 IT=N
14567 DO 290 J=1,5
14568 K(IT,J)=0
14569 P(IT,J)=0D0
14570 V(IT,J)=0D0
14571 290 CONTINUE
14572C...f -> f + g (gamma).
14573 IF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).LE.20) THEN
14574 K(IT,2)=21
14575 IF(MCESV(JT).EQ.2.OR.IABS(KFLB).GE.11) K(IT,2)=22
14576C...f -> g (gamma, W+-) + f.
14577 ELSEIF(IABS(KFLB).LE.20.AND.IABS(KFLS(JT+2)).GT.20) THEN
14578 K(IT,2)=KFLB
14579 IF(KFLS(JT+2).EQ.24) THEN
14580 K(IT,2)=-12
14581 ELSEIF(KFLS(JT+2).EQ.-24) THEN
14582 K(IT,2)=12
14583 ENDIF
14584C...g (gamma) -> f + fbar, g + g.
14585 ELSE
14586 K(IT,2)=-KFLS(JT+2)
14587 IF(KFLS(JT+2).GT.20) K(IT,2)=KFLS(JT+2)
14588 ENDIF
14589 K(IT,1)=3
14590 IF((IABS(K(IT,2)).GE.11.AND.IABS(K(IT,2)).LE.18).OR.
14591 & IABS(K(IT,2)).EQ.22) K(IT,1)=1
14592 P(IT,5)=PYMASS(K(IT,2))
14593 IF(DMSMA.LE.P(IT,5)**2) GOTO 100
14594 IF(MSTP(63).GE.1.AND.MCESV(JT).EQ.1) THEN
14595 MSTJ48=MSTJ(48)
14596 PARJ85=PARJ(85)
14597 P(IT,4)=(DSHZ-DSH-P(IT,5)**2)/DSHR
14598 P(IT,3)=SQRT(P(IT,4)**2-P(IT,5)**2)
14599 IF(MSTP(63).EQ.1) THEN
14600 Q2TIM=DMSMA
14601 ELSEIF(MSTP(63).EQ.2) THEN
14602 Q2TIM=MIN(DMSMA,PARP(71)*Q2S(JT))
14603 ELSE
14604 Q2TIM=DMSMA
14605 MSTJ(48)=1
14606 IF(IKIN.EQ.0) DPT2=DMSMA*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14607 IF(IKIN.EQ.1) DPT2=DMSMA*(0.5D0*DPD(1)*DPD(2)+0.5D0*DPD(3)*
14608 & DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)))/(4D0*DSH*DPC(3)**2)
14609 PARJ(85)=SQRT(MAX(0D0,DPT2))*
14610 & (1D0/P(IT,4)+1D0/P(IS(JT),4))
14611 ENDIF
14612C...Only do timelike shower here if using PYSHOW
14613 IF (MSTJ(41).NE.11.AND.MSTJ(41).NE.12) THEN
14614 CALL PYSHOW(IT,0,SQRT(Q2TIM))
14615 ENDIF
14616 MSTJ(48)=MSTJ48
14617 PARJ(85)=PARJ85
14618 IF(N.GE.IT+1) P(IT,5)=P(IT+1,5)
14619 ENDIF
14620
14621C...Reconstruct kinematics of branching: timelike parton shower.
14622 DMS=P(IT,5)**2
14623 IF(IKIN.EQ.0) DPT2=(DMSMA-DMS)*(DSHZ+DQ2(3))/(DSH+DQ2(JT))
14624 IF(IKIN.EQ.1) DPT2=(DMSMA-DMS)*(0.5D0*DPD(1)*DPD(2)+
14625 & 0.5D0*DPD(3)*DPD(4)-DQ2(JR)*(DQ2(JT)+DQ2(3)+DMS))/
14626 & (4D0*DSH*DPC(3)**2)
14627 IF(DPT2.LT.0D0) GOTO 100
14628 DPB(1)=(0.5D0*DPD(2)-DPC(JR)*(DSHZ+DQ2(JR)-DQ2(JT)-DMS)/
14629 & DSHR)/DPC(3)-DPC(3)
14630 P(IT,1)=SQRT(DPT2)
14631 P(IT,3)=DPB(1)*(-1)**(JT+1)
14632 P(IT,4)=SQRT(DPT2+DPB(1)**2+DMS)
14633 IF(N.GE.IT+1) THEN
14634 DPB(1)=SQRT(DPB(1)**2+DPT2)
14635 DPB(2)=SQRT(DPB(1)**2+DMS)
14636 DPB(3)=P(IT+1,3)
14637 DPB(4)=SQRT(DPB(3)**2+DMS)
14638 DBEZ=(DPB(4)*DPB(1)-DPB(3)*DPB(2))/(DPB(4)*DPB(2)-DPB(3)*
14639 & DPB(1))
14640 CALL PYROBO(IT+1,N,0D0,0D0,0D0,0D0,DBEZ)
14641 THE=PYANGL(P(IT,3),P(IT,1))
14642 CALL PYROBO(IT+1,N,THE,0D0,0D0,0D0,0D0)
14643 ENDIF
14644
14645C...Reconstruct kinematics of branching: spacelike parton.
14646 DO 300 J=1,5
14647 K(N+1,J)=0
14648 P(N+1,J)=0D0
14649 V(N+1,J)=0D0
14650 300 CONTINUE
14651 K(N+1,1)=14
14652 K(N+1,2)=KFLB
14653 P(N+1,1)=P(IT,1)
14654 P(N+1,3)=P(IT,3)+P(IS(JT),3)
14655 P(N+1,4)=P(IT,4)+P(IS(JT),4)
14656 P(N+1,5)=-SQRT(DQ2(3))
14657 MCT(N+1,1)=0
14658 MCT(N+1,2)=0
14659
14660C...Define colour flow of branching.
14661 K(IS(JT),3)=N+1
14662 K(IT,3)=N+1
14663 IM1=N+1
14664 IM2=N+1
14665C...f -> f + gamma (Z, W).
14666 IF(IABS(K(IT,2)).GE.22) THEN
14667 K(IT,1)=1
14668 ID1=IS(JT)
14669 ID2=IS(JT)
14670C...f -> gamma (Z, W) + f.
14671 ELSEIF(IABS(K(IS(JT),2)).GE.22) THEN
14672 ID1=IT
14673 ID2=IT
14674C...gamma -> q + qbar, g + g.
14675 ELSEIF(K(N+1,2).EQ.22) THEN
14676 ID1=IS(JT)
14677 ID2=IT
14678 IM1=ID2
14679 IM2=ID1
14680C...q -> q + g.
14681 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21.AND.K(IT,2).EQ.21) THEN
14682 ID1=IT
14683 ID2=IS(JT)
14684C...q -> g + q.
14685 ELSEIF(K(N+1,2).GT.0.AND.K(N+1,2).NE.21) THEN
14686 ID1=IS(JT)
14687 ID2=IT
14688C...qbar -> qbar + g.
14689 ELSEIF(K(N+1,2).LT.0.AND.K(IT,2).EQ.21) THEN
14690 ID1=IS(JT)
14691 ID2=IT
14692C...qbar -> g + qbar.
14693 ELSEIF(K(N+1,2).LT.0) THEN
14694 ID1=IT
14695 ID2=IS(JT)
14696C...g -> g + g; g -> q + qbar.
14697 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
14698 ID1=IS(JT)
14699 ID2=IT
14700 ELSE
14701 ID1=IT
14702 ID2=IS(JT)
14703 ENDIF
14704 IF(IM1.EQ.N+1) K(IM1,4)=K(IM1,4)+ID1
14705 IF(IM2.EQ.N+1) K(IM2,5)=K(IM2,5)+ID2
14706 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
14707 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
14708 IF(ID1.NE.ID2) THEN
14709 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
14710 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
14711 ENDIF
14712 N=N+1
14713 IF(K(IT,1).EQ.1) THEN
14714 K(IT,4)=0
14715 K(IT,5)=0
14716 ENDIF
14717
14718C...Boost to new CM-frame.
14719 DBSVX=(P(N,1)+P(IS(JR),1))/(P(N,4)+P(IS(JR),4))
14720 DBSVZ=(P(N,3)+P(IS(JR),3))/(P(N,4)+P(IS(JR),4))
14721 IF(DBSVX**2+DBSVZ**2.GE.1D0) GOTO 100
14722 CALL PYROBO(NS+1,N,0D0,0D0,-DBSVX,0D0,-DBSVZ)
14723 IR=N+(JT-1)*(IS(1)-N)
14724 CALL PYROBO(NS+1,N,-PYANGL(P(IR,3),P(IR,1)),DPHI(JT),
14725 & 0D0,0D0,0D0)
14726
14727C...Save timelike parton in PYPART if doing pT-ordered FSR off ISR
14728 IF (MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12) THEN
14729 NPART=NPART+1
14730 IPART(NPART)=IT
14731 PTPART(NPART)=SQRT(PARP(71)*DPT2)
14732 ENDIF
14733
14734C...Global statistics.
14735 MINT(352)=MINT(352)+1
14736 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
14737 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
14738
14739 ENDIF
14740
14741C...Update kinematics variables.
14742 IS(JT)=N
14743 DQ2(JT)=Q2B
14744 IF(MSTP(62).GE.3.AND.NTRY2.LT.200.AND.MCE.EQ.1) THE2(JT)=THE2T
14745 DSH=DSHZ
14746
14747C...Save quantities; loop back.
14748 Q2S(JT)=Q2B
14749 DPHI(JT)=PHIBR
14750 MCESV(JT)=MCE
14751 IF((MCEV.EQ.1.AND.Q2B.GE.0.25D0*Q2MNC).OR.
14752 &(MEEV.EQ.1.AND.Q2B.GE.Q2MNE)) THEN
14753 KFLS(JT+2)=KFLS(JT)
14754 KFLS(JT)=KFLA
14755 XS(JT)=XA
14756 ZS(JT)=Z
14757 DO 310 KFL=-25,25
14758 XFS(JT,KFL)=XFA(KFL)
14759 310 CONTINUE
14760 TEVCSV(JT)=TEVCB
14761 TEVESV(JT)=TEVEB
14762 ELSE
14763 MORE(JT)=0
14764 IF(JT.EQ.1) IPU1=N
14765 IF(JT.EQ.2) IPU2=N
14766 ENDIF
14767 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
14768 CALL PYERRM(11,'(PYSSPA:) no more memory left in PYJETS')
14769 IF(MSTU(21).GE.1) N=NS
14770 IF(MSTU(21).GE.1) RETURN
14771 ENDIF
14772 IF(MORE(1).EQ.1.OR.MORE(2).EQ.1) GOTO 150
14773
14774C...Boost hard scattering partons to frame of shower initiators.
14775 DO 320 J=1,3
14776 ROBO(J+2)=(P(NS+1,J)+P(NS+2,J))/(P(NS+1,4)+P(NS+2,4))
14777 320 CONTINUE
14778 K(N+2,1)=1
14779 DO 330 J=1,5
14780 P(N+2,J)=P(NS+1,J)
14781 330 CONTINUE
14782 CALL PYROBO(N+2,N+2,0D0,0D0,-ROBO(3),-ROBO(4),-ROBO(5))
14783 ROBO(2)=PYANGL(P(N+2,1),P(N+2,2))
14784 ROBO(1)=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
14785 IMIN=MINT(83)+5
14786 IF(MINT(31).GE.2) IMIN=MIN(IPUS1,IPUS2)
14787 CALL PYROBO(IMIN,NS,0D0,-ROBO(2),0D0,0D0,0D0)
14788 CALL PYROBO(IMIN,NS,ROBO(1),ROBO(2),ROBO(3),ROBO(4),ROBO(5))
14789
14790C...Store user information. Reset Lambda value.
14791 IF(MINT(31).LE.1) THEN
14792 K(IPU1,3)=MINT(83)+3
14793 K(IPU2,3)=MINT(83)+4
14794 ELSE
14795 K(IPU1,3)=MINT(83)+1
14796 K(IPU2,3)=MINT(83)+2
14797 ENDIF
14798 DO 340 JT=1,2
14799 MINT(12+JT)=KFLS(JT)
14800 VINT(140+JT)=XS(JT)
14801 IF(MINT(18+JT).EQ.1) VINT(140+JT)=VINT(154+JT)*XS(JT)
14802 IF(MINT(31).GE.2) VINT(140+JT)=VINT(140+JT)*VINT(142+JT)
14803 340 CONTINUE
14804 PARU(112)=ALAMS
14805
14806 RETURN
14807 END
14808
14809C*********************************************************************
14810
14811C...PYPTIS
14812C...Generates pT-ordered spacelike initial-state parton showers and
14813C...trial joinings.
14814C...MODE=-1: Initialize ISR from scratch, starting from the hardest
14815C... interaction initiators at PT2NOW.
14816C...MODE= 0: Generate a trial branching on interaction MINT(36), side
14817C... MINT(30). Start evolution at PT2NOW, solve Sudakov for PT2.
14818C... Store in /PYISMX/ if PT2 is largest so far. Abort if PT2
14819C... is below PT2CUT.
14820C... (Also generate test joinings if MSTP(96)=1.)
14821C...MODE= 1: Accept stored shower branching. Update event record etc.
14822C...PT2NOW : Starting (max) PT2 scale for evolution.
14823C...PT2CUT : Lower limit for evolution.
14824C...PT2 : Result of evolution. Generated PT2 for trial emission.
14825C...IFAIL : Status return code. IFAIL=0 when all is well.
14826
14827 SUBROUTINE PYPTIS(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
14828
14829C...Double precision and integer declarations.
14830 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
14831 IMPLICIT INTEGER(I-N)
14832 INTEGER PYK,PYCHGE,PYCOMP
14833C...Parameter statement for maximum size of showers.
14834 PARAMETER (MAXNUR=1000)
14835C...Commonblocks.
14836 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
14837 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
14838 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
14839 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
14840 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
14841 COMMON/PYINT1/MINT(400),VINT(400)
14842 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
14843 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
14844 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
14845 & XMI(2,240),PT2MI(240),IMISEP(0:240)
14846 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
14847 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
14848 COMMON/PYCTAG/NCT,MCT(4000,2)
14849 COMMON/PYISJN/MJN1MX,MJN2MX,MJOIND(2,240)
14850 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,
14851 & /PYINT2/,/PYINTM/,/PYISMX/,/PYCTAG/,/PYISJN/
14852C...Local variables
14853 DIMENSION ZSAV(2,240),PT2SAV(2,240),
14854 & XFB(-25:25),XFA(-25:25),XFN(-25:25),XFJ(-25:25),
14855 & WTAP(-25:25),WTPDF(-25:25),SHTNOW(240),
14856 & WTAPJ(240),WTPDFJ(240),X1(240),Y(240)
14857 SAVE ZSAV,PT2SAV,XFB,XFA,XFN,WTAP,WTPDF,XMXC,SHTNOW,
14858 & RMB2,RMC2,ALAM3,ALAM4,ALAM5,TMIN,PTEMAX,WTEMAX,AEM2PI
14859C...For check on excessive weights.
14860 CHARACTER CHWT*12
14861
14862C...Only give errors for very large weights, otherwise just warnings
14863 DATA WTEMAX /1.5D0/
14864C...Only give errors for large pT, otherwise just warnings
14865 DATA PTEMAX /5D0/
14866
14867 IFAIL=-1
14868
14869C----------------------------------------------------------------------
14870C...MODE=-1: Initialize initial state showers from scratch, i.e.
14871C...starting from the hardest interaction initiators.
14872 IF (MODE.EQ.-1) THEN
14873C...Set hard scattering SHAT.
14874 SHTNOW(1)=VINT(44)
14875C...Mass thresholds and Lambda for QCD evolution.
14876 AEM2PI=PARU(101)/PARU(2)
14877 RMB=PMAS(5,1)
14878 RMC=PMAS(4,1)
14879 ALAM4=PARP(61)
14880 IF(MSTU(112).LT.4) ALAM4=PARP(61)*(PARP(61)/RMC)**(2D0/25D0)
14881 IF(MSTU(112).GT.4) ALAM4=PARP(61)*(RMB/PARP(61))**(2D0/25D0)
14882 ALAM5=ALAM4*(ALAM4/RMB)**(2D0/23D0)
14883 ALAM3=ALAM4*(RMC/ALAM4)**(2D0/27D0)
14884C...Optionally use Lambda_MC = Lambda_CMW
14885 IF (MSTP(64).EQ.3) THEN
14886 ALAM5 = ALAM5 * 1.569
14887 ALAM4 = ALAM4 * 1.618
14888 ALAM3 = ALAM3 * 1.661
14889 ENDIF
14890 RMB2=RMB**2
14891 RMC2=RMC**2
14892C...Massive quark forced creation threshold (in M**2).
14893 TMIN=1.01D0
14894C...Set upper limit for X (ensures some X left for beam remnant).
14895 XMXC=1D0-2D0*PARP(111)/VINT(1)
14896
14897 IF (MSTP(61).GE.1) THEN
14898C...Initial values: flavours, momenta, virtualities.
14899 DO 100 JS=1,2
14900 NISGEN(JS,1)=0
14901
14902C...Special kinematics check for c/b quarks (that g -> c cbar or
14903C...b bbar kinematically possible).
14904 KFLB=K(IMI(JS,1,1),2)
14905 KFLCB=IABS(KFLB)
14906 IF(KFBEAM(JS).NE.22.AND.(KFLCB.EQ.4.OR.KFLCB.EQ.5)) THEN
14907C...Check PT2MAX > mQ^2
14908 IF (VINT(56).LT.1.05D0*PMAS(PYCOMP(KFLCB),1)**2) THEN
14909 CALL PYERRM(9,'(PYPTIS:) PT2MAX < 1.05 * MQ**2. '//
14910 & 'No Q creation possible.')
14911 MINT(51)=1
14912 RETURN
14913 ELSE
14914C...Check for physical z values (m == MQ / sqrt(s))
14915C...For creation diagram, x < z < (1-m)/(1+m(1-m))
14916 FMQ=PMAS(KFLCB,1)/SQRT(SHTNOW(1))
14917 ZMXCR=(1D0-FMQ)/(1D0+FMQ*(1D0-FMQ))
14918 IF (XMI(JS,1).GT.0.9D0*ZMXCR) THEN
14919 CALL PYERRM(9,'(PYPTIS:) No physical z value for '//
14920 & 'Q creation.')
14921 MINT(51)=1
14922 RETURN
14923 ENDIF
14924 ENDIF
14925 ENDIF
14926 100 CONTINUE
14927 ENDIF
14928
14929 MINT(354)=0
14930C...Zero joining array
14931 DO 110 MJ=1,240
14932 MJOIND(1,MJ)=0
14933 MJOIND(2,MJ)=0
14934 110 CONTINUE
14935
14936C----------------------------------------------------------------------
14937C...MODE= 0: Generate a trial branching on interaction MINT(36) side
14938C...MINT(30). Store if emission PT2 scale is largest so far.
14939C...Also generate test joinings if MSTP(96)=1.
14940 ELSEIF(MODE.EQ.0) THEN
14941 IFAIL=-1
14942 MECOR=0
14943 ISUB=MINT(1)
14944 JS=MINT(30)
14945C...No shower for structureless beam
14946 IF (MINT(44+JS).EQ.1) RETURN
14947 MI=MINT(36)
14948 SHAT=VINT(44)
14949C...Absolute shower max scale = VINT(56)
14950 IF (MSTP(67).NE.0) THEN
14951 PT2 = MIN(PT2NOW,VINT(56))
14952 ELSE
14953C...For MSTP(67)=0, adjust starting scale by PARP(67)
14954 PT2=MIN(PT2NOW,PARP(67)*VINT(56))
14955 ENDIF
14956 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) SHTNOW(MI)=SHAT
14957C...Define for which processes ME corrections have been implemented.
14958 IF(MSTP(68).EQ.1.OR.MSTP(68).EQ.3) THEN
14959 IF(ISUB.EQ.1.OR.ISUB.EQ.2.OR.ISUB.EQ.141.OR.ISUB.EQ
14960 & .142.OR.ISUB.EQ.144) MECOR=1
14961 IF(ISUB.EQ.102.OR.ISUB.EQ.152.OR.ISUB.EQ.157) MECOR=2
14962 IF(ISUB.EQ.3.OR.ISUB.EQ.151.OR.ISUB.EQ.156) MECOR=3
14963C...Calculate preweighting factor for ME-corrected processes.
14964 IF(MECOR.GE.1) CALL PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
14965 ENDIF
14966C...Basic info on daughter for which to find mother.
14967 KFLB=K(IMI(JS,MI,1),2)
14968 KFLBA=IABS(KFLB)
14969C...KSVCB: -1 for sea or first companion, 0 for valence or gluon, >1 for
14970C...second companion.
14971 KSVCB=MAX(-1,IMI(JS,MI,2))
14972C...Treat "first" companion of a pair like an ordinary sea quark
14973C...(except that creation diagram is not allowed)
14974 IF(IMI(JS,MI,2).GT.IMISEP(MI)) KSVCB=-1
14975C...X (rescaled to [0,1])
14976 XB=XMI(JS,MI)/VINT(142+JS)
14977C...Massive quarks (use physical masses.)
14978 RMQ2=0D0
14979 MQMASS=0
14980 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
14981 RMQ2=RMC2
14982 IF (KFLBA.EQ.5) RMQ2=RMB2
14983C...Special threshold treatment for non-photon beams
14984 IF (KFBEAM(JS).NE.22) MQMASS=KFLBA
14985C...Check that not below mass threshold.
14986 IF(MQMASS.GT.0.AND.PT2.LT.TMIN*RMQ2) THEN
14987 CALL PYERRM(9,'(PYPTIS:) PT2 < 1.01 * MQ**2. '//
14988 & 'No Q creation possible.')
14989 MINT(51)=1
14990C...Special return code if failing before any evolution at all: bad event
14991 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
14992 RETURN
14993 ENDIF
14994
14995 ENDIF
14996
14997C...Flags for parton distribution calls.
14998 MINT(105)=MINT(102+JS)
14999 MINT(109)=MINT(106+JS)
15000 VINT(120)=VINT(2+JS)
15001
15002C.... ALICE
15003C.... Store side in MINT(124)
15004 MINT(124) = JS
15005C...Calculate initial parton distribution weights.
15006 IF(XB.GE.XMXC) THEN
15007 RETURN
15008 ELSEIF(MQMASS.EQ.0) THEN
15009 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
15010 ELSE
15011C...Initialize massive quark PT2 dependent pdf underestimate.
15012 PT20=PT2
15013 CALL PYPDFU(KFBEAM(JS),XB,PT20,XFB)
15014C.!.Tentative treatment of massive valence quarks.
15015 XQ0=MAX(1D-10,XPSVC(KFLB,KSVCB))
15016 XG0=XFB(21)
15017 TPM0=LOG(PT20/RMQ2)
15018 WPDF0=TPM0*XG0/XQ0
15019 ENDIF
15020 IF (KFLBA.LE.6) THEN
15021C...For quarks, only include respective sea, val, or cmp part.
15022 IF (KSVCB.LE.0) THEN
15023 XFB(KFLB)=XPSVC(KFLB,KSVCB)
15024 ELSE
15025C...Find companion's companion
15026 MISEA=0
15027 120 MISEA=MISEA+1
15028 IF (IMI(JS,MISEA,2).NE.IMI(JS,MI,1)) GOTO 120
15029 XS=XMI(JS,MISEA)
15030 XREM=VINT(142+JS)
15031 YS=XS/(XREM+XS)
15032C...Momentum fraction of the companion quark.
15033C...Rescale from XB = x/XREM to YB = x/(1-Sum_rest) -> factor (1-YS).
15034 YB=XB*(1D0-YS)
15035 XFB(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
15036 ENDIF
15037 ENDIF
15038
15039C...Determine overestimated z range: switch at c and b masses.
15040 130 IF (PT2.GT.TMIN*RMB2) THEN
15041 IZRG=3
15042 PT2MNE=MAX(TMIN*RMB2,PT2CUT)
15043 B0=23D0/6D0
15044 ALAM2=ALAM5**2
15045 ELSEIF(PT2.GT.TMIN*RMC2) THEN
15046 IZRG=2
15047 PT2MNE=MAX(TMIN*RMC2,PT2CUT)
15048 B0=25D0/6D0
15049 ALAM2=ALAM4**2
15050 ELSE
15051 IZRG=1
15052 PT2MNE=PT2CUT
15053 B0=27D0/6D0
15054 ALAM2=ALAM3**2
15055 ENDIF
15056C...Divide Lambda by PARP(64) (equivalent to mult pT2 by PARP(64))
15057 ALAM2=ALAM2/PARP(64)
15058C...Overestimated ZMAX:
15059 IF (MQMASS.EQ.0) THEN
15060C...Massless
15061 ZMAX=1D0-0.5D0*(PT2MNE/SHTNOW(MI))*(SQRT(1D0+4D0*SHTNOW(MI)
15062 & /PT2MNE)-1D0)
15063 ELSE
15064C...Massive (limit for bremsstrahlung diagram > creation)
15065 FMQ=SQRT(RMQ2/SHTNOW(MI))
15066 ZMAX=1D0/(1D0+FMQ)
15067 ENDIF
15068 ZMIN=XB/XMXC
15069
15070C...If kinematically impossible then do not evolve.
15071 IF(PT2.LT.PT2CUT.OR.ZMAX.LE.ZMIN) RETURN
15072
15073C...Reset Altarelli-Parisi and PDF weights.
15074 DO 140 KFL=-5,5
15075 WTAP(KFL)=0D0
15076 WTPDF(KFL)=0D0
15077 140 CONTINUE
15078 WTAP(21)=0D0
15079 WTPDF(21)=0D0
15080C...Zero joining weights and compute X(partner) and X(mother) values.
15081 NJN=0
15082 IF (MSTP(96).NE.0) THEN
15083 DO 150 MJ=1,MINT(31)
15084 WTAPJ(MJ)=0D0
15085 WTPDFJ(MJ)=0D0
15086 X1(MJ)=XMI(JS,MJ)/(VINT(142+JS)+XMI(JS,MJ))
15087 Y(MJ)=(XMI(JS,MI)+XMI(JS,MJ))/(VINT(142+JS)+XMI(JS,MJ)
15088 & +XMI(JS,MI))
15089 150 CONTINUE
15090 ENDIF
15091
15092C...Approximate Altarelli-Parisi weights (integrated AP dz).
15093C...q -> q, g -> q or q -> q + gamma (already set which).
15094 IF(KFLBA.LE.5) THEN
15095C...Val and cmp quarks get an extra sqrt(z) to smooth their bumps.
15096 IF (KSVCB.LT.0) THEN
15097 WTAP(KFLB)=(8D0/3D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
15098 ELSE
15099 RMIN=(1+SQRT(ZMIN))/(1-SQRT(ZMIN))
15100 RMAX=(1+SQRT(ZMAX))/(1-SQRT(ZMAX))
15101 WTAP(KFLB)=(8D0/3D0)*LOG(RMAX/RMIN)
15102 ENDIF
15103 WTAP(21)=0.5D0*(ZMAX-ZMIN)
15104 WTAPE=(2D0/9D0)*LOG((1D0-ZMIN)/(1D0-ZMAX))
15105 IF(MOD(KFLBA,2).EQ.0) WTAPE=4D0*WTAPE
15106 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15107 WTAP(KFLB)=WTFF*WTAP(KFLB)
15108 WTAP(21)=WTGF*WTAP(21)
15109 WTAPE=WTFF*WTAPE
15110 ENDIF
15111 IF(MSTP(61).EQ.1) WTAPE=0D0
15112 IF (KSVCB.GE.1) THEN
15113C...Kill normal creation but add joining diagrams for cmp quark.
15114 WTAP(21)=0D0
15115 IF (KFLBA.EQ.4.OR.KFLBA.EQ.5) THEN
15116 CALL PYERRM(9,'(PYPTIS:) Sorry, I got a heavy companion'//
15117 & " quark here. Not handled yet, giving up!")
15118 PT2=0D0
15119 MINT(51)=1
15120 RETURN
15121 ENDIF
15122C...Check for possible joinings
15123 IF (MSTP(96).NE.0.AND.MJOIND(JS,MI).EQ.0) THEN
15124C...Find companion's companion.
15125 MJ=0
15126 160 MJ=MJ+1
15127 IF (IMI(JS,MJ,2).NE.IMI(JS,MI,1)) GOTO 160
15128 IF (MJOIND(JS,MJ).EQ.0) THEN
15129 Y(MI)=YB+YS
15130 Z=YB/Y(MI)
15131 WTAPJ(MJ)=Z*(1D0-Z)*0.5D0*(Z**2+(1D0-Z)**2)
15132 IF (WTAPJ(MJ).GT.1D-6) THEN
15133 NJN=1
15134 ELSE
15135 WTAPJ(MJ)=0D0
15136 ENDIF
15137 ENDIF
15138C...Add trial gluon joinings.
15139 DO 170 MJ=1,MINT(31)
15140 KFLC=K(IMI(JS,MJ,1),2)
15141 IF (KFLC.NE.21.OR.MJOIND(JS,MJ).NE.0) GOTO 170
15142 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
15143 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
15144 IF (WTAPJ(MJ).GT.1D-6) THEN
15145 NJN=NJN+1
15146 ELSE
15147 WTAPJ(MJ)=0D0
15148 ENDIF
15149 170 CONTINUE
15150 ENDIF
15151 ELSEIF (IMI(JS,MI,2).GE.0) THEN
15152C...Kill creation diagram for val quarks and sea quarks with companions.
15153 WTAP(21)=0D0
15154 ELSEIF (MQMASS.EQ.0) THEN
15155C...Extra safety factor for massless sea quark creation.
15156 WTAP(21)=WTAP(21)*1.25D0
15157 ENDIF
15158
15159C... q -> g, g -> g.
15160 ELSEIF(KFLB.EQ.21) THEN
15161C...Here we decide later whether a quark picked up is valence or
15162C...sea, so we maintain the extra factor sqrt(z) since we deal
15163C...with the *sum* of sea and valence in this context.
15164 WTAPQ=(16D0/3D0)*(SQRT(1D0/ZMIN)-SQRT(1D0/ZMAX))
15165C...new: do not allow backwards evol to pick up heavy flavour.
15166 DO 180 KFL=1,MIN(3,MSTP(58))
15167 WTAP(KFL)=WTAPQ
15168 WTAP(-KFL)=WTAPQ
15169 180 CONTINUE
15170 WTAP(21)=6D0*LOG(ZMAX*(1D0-ZMIN)/(ZMIN*(1D0-ZMAX)))
15171 IF(MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15172 WTAPQ=WTFG*WTAPQ
15173 WTAP(21)=WTGG*WTAP(21)
15174 ENDIF
15175C...Check for possible joinings (companions handled separately above)
15176 IF (MSTP(96).NE.0.AND.MINT(31).GE.2.AND.MJOIND(JS,MI).EQ.0)
15177 & THEN
15178 DO 190 MJ=1,MINT(31)
15179 IF (MJ.EQ.MI.OR.MJOIND(JS,MJ).NE.0) GOTO 190
15180 KSVCC=IMI(JS,MJ,2)
15181 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
15182 IF (KSVCC.GE.1) GOTO 190
15183 KFLC=K(IMI(JS,MJ,1),2)
15184C...Only try g -> g + g once.
15185 IF (MJ.GT.MI.AND.KFLC.EQ.21) GOTO 190
15186 Z=XMI(JS,MJ)/(XMI(JS,MI)+XMI(JS,MJ))
15187 IF (KFLC.EQ.21) THEN
15188 WTAPJ(MJ)=6D0*(Z**2+(1D0-Z)**2)
15189 ELSE
15190 WTAPJ(MJ)=Z*4D0/3D0*(1D0+Z**2)
15191 ENDIF
15192 IF (WTAPJ(MJ).GT.1D-6) THEN
15193 NJN=NJN+1
15194 ELSE
15195 WTAPJ(MJ)=0D0
15196 ENDIF
15197 190 CONTINUE
15198 ENDIF
15199 ENDIF
15200
15201C...Initialize massive quark evolution
15202 IF (MQMASS.NE.0) THEN
15203 RML=(RMQ2+VINT(18))/ALAM2
15204 TML=LOG(RML)
15205 TPL=LOG((PT2+VINT(18))/ALAM2)
15206 TPM=LOG((PT2+VINT(18))/RMQ2)
15207 WN=WTAP(21)*WPDF0/B0
15208 ENDIF
15209
15210
15211C...Loopback point for iteration
15212 NTRY=0
15213 NTHRES=0
15214 200 NTRY=NTRY+1
15215 IF(NTRY.GT.500) THEN
15216 CALL PYERRM(9,'(PYPTIS:) failed to evolve shower.')
15217 MINT(51)=1
15218 RETURN
15219 ENDIF
15220
15221C... Calculate PDF weights and sum for evolution rate.
15222 WTSUM=0D0
15223 XFBO=MAX(1D-10,XFB(KFLB))
15224 DO 210 KFL=-5,5
15225 WTPDF(KFL)=XFB(KFL)/XFBO
15226 WTSUM=WTSUM+WTAP(KFL)*WTPDF(KFL)
15227 210 CONTINUE
15228C...Only add gluon mother diagram for massless KFLB.
15229 IF(MQMASS.EQ.0) THEN
15230 WTPDF(21)=XFB(21)/XFBO
15231 WTSUM=WTSUM+WTAP(21)*WTPDF(21)
15232 ENDIF
15233 WTSUM=MAX(0.0001D0,WTSUM)
15234 WTSUMS=WTSUM
15235C...Add joining diagrams where applicable.
15236 WTJOIN=0D0
15237 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
15238 DO 220 MJ=1,MINT(31)
15239 IF (WTAPJ(MJ).LT.1D-3) GOTO 220
15240 WTPDFJ(MJ)=1D0/XFBO
15241C...x and x*pdf (+ sea/val) for parton C.
15242 KFLC=K(IMI(JS,MJ,1),2)
15243 KFLCA=IABS(KFLC)
15244 KSVCC=MAX(-1,IMI(JS,MJ,2))
15245 IF (IMI(JS,MJ,2).GT.IMISEP(MJ)) KSVCC=-1
15246 MINT(30)=JS
15247 MINT(36)=MJ
15248C.... ALICE
15249C.... Store side in MINT(124)
15250 MINT(124) = JS
15251C....
15252
15253
15254 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
15255 MINT(36)=MI
15256 IF (KFLCA.LE.6.AND.KSVCC.LE.0) THEN
15257 XFJ(KFLC)=XPSVC(KFLC,KSVCC)
15258 ELSEIF (KSVCC.GE.1) THEN
15259 print*, 'error! parton C is companion!'
15260 ENDIF
15261 WTPDFJ(MJ)=WTPDFJ(MJ)/XFJ(KFLC)
15262C...x and x*pdf (+ sea/val) for parton A.
15263 KFLA=21
15264 KSVCA=0
15265 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
15266 KFLA=KFLB
15267 KSVCA=KSVCB
15268 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15269 KFLA=KFLC
15270 KSVCA=KSVCC
15271 ENDIF
15272 MINT(30)=JS
15273C.... ALICE
15274C.... Store side in MINT(124)
15275 MINT(124) = JS
15276C ...
15277 IF (KSVCA.LE.0) THEN
15278C...Consider C the "evolved" parton if B is gluon. Val/sea
15279C...counting will then be done correctly in PYPDFU.
15280 IF (KFLBA.EQ.21) MINT(36)=MJ
15281 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15282 MINT(36)=MI
15283 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15284 ELSE
15285C...If parton A is companion, use Y(MI) and YS in call to PYFCMP.
15286 XFJ(KFLA)=PYFCMP(Y(MI)/VINT(140),YS/VINT(140),MSTP(87))
15287 ENDIF
15288 WTPDFJ(MJ)=XFJ(KFLA)*WTPDFJ(MJ)
15289 WTJOIN=WTJOIN+WTAPJ(MJ)*WTPDFJ(MJ)
15290 220 CONTINUE
15291 ENDIF
15292
15293C...Pick normal pT2 (in overestimated z range).
15294 230 PT2OLD=PT2
15295 WTSUM=WTSUMS
15296 PT2=ALAM2*((PT2+VINT(18))/ALAM2)**(PYR(0)**(B0/WTSUM))-VINT(18)
15297 KFLC=21
15298
15299C...Evolve q -> q gamma separately, pick it if larger pT.
15300 IF(KFLBA.LE.5.AND.MSTP(61).GE.2) THEN
15301 PT2QED=(PT2OLD+VINT(18))*PYR(0)**(1D0/(AEM2PI*WTAPE))-VINT(18)
15302 IF(PT2QED.GT.PT2) THEN
15303 PT2=PT2QED
15304 KFLC=22
15305 KFLA=KFLB
15306 ENDIF
15307 ENDIF
15308
15309C... Evolve massive quark creation separately.
15310 MCRQQ=0
15311 IF (MQMASS.NE.0) THEN
15312 PT2CR=(RMQ2+VINT(18))*(RML**(TPM/(TPL*PYR(0)**(-TML/WN)-TPM)))
15313 & -VINT(18)
15314C...If massive quark also on opposite side, ensure sufficient remaining
15315C...phase space also for creation of that quark
15316 TMINQQ = TMIN
15317 KFLOPP = K(IMI(3-JS,MI,1),2)
15318 IF (ABS(KFLOPP).EQ.4.OR.ABS(KFLOPP).EQ.5) TMINQQ = 1.05
15319C...Ensure mininimum PT2CR and force creation near threshold.
15320 IF (PT2CR.LT.TMINQQ*RMQ2) THEN
15321 NTHRES=NTHRES+1
15322 IF (NTHRES.GT.50) THEN
15323 CALL PYERRM(9,'(PYPTIS:) no phase space left for '//
15324 & 'massive quark creation. Gave up trying.')
15325 MINT(51)=1
15326C...Special return code if failing before any evolution at all: bad event
15327 IF (NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) MINT(51)=2
15328 RETURN
15329 ENDIF
15330 PT2=0D0
15331 PT2CR=TMINQQ*RMQ2
15332C...Signal that massive quark creation is being forced
15333 MCRQQ=2
15334 ENDIF
15335C... Select largest PT2 (brems or creation):
15336 IF (PT2CR.GT.PT2) THEN
15337 MCRQQ=MAX(MCRQQ,1)
15338 WTSUM=0D0
15339 PT2=PT2CR
15340 KFLA=21
15341 ELSE
15342 MCRQQ=0
15343 KFLA=KFLB
15344 ENDIF
15345C... Compute logarithms for this PT2
15346 TPL=LOG((PT2+VINT(18))/ALAM2)
15347 TPM=LOG((PT2+VINT(18))/(RMQ2+VINT(18)))
15348 WTCRQQ=TPM/LOG(PT2/RMQ2)
15349 ENDIF
15350
15351C...Evolve joining separately
15352 MJOIN=0
15353 IF (MSTP(96).NE.0.AND.NJN.NE.0) THEN
15354 PT2JN=ALAM2*((PT2OLD+VINT(18))/ALAM2)**(PYR(0)**(B0/WTJOIN))
15355 & -VINT(18)
15356 IF (PT2JN.GE.PT2) THEN
15357 MJOIN=1
15358 PT2=PT2JN
15359 ENDIF
15360 ENDIF
15361
15362C...Loopback if crossed c/b mass thresholds.
15363 IF(IZRG.EQ.3.AND.PT2.LT.RMB2) THEN
15364 PT2=RMB2
15365 GOTO 130
15366 ELSEIF(IZRG.EQ.2.AND.PT2.LT.RMC2) THEN
15367 PT2=RMC2
15368 GOTO 130
15369 ENDIF
15370
15371C...Speed up shower. Skip if higher-PT acceptable branching
15372C...already found somewhere else.
15373C...Also finish if below lower cutoff.
15374
15375 IF ((PT2-PT2MX).LT.-0.001.OR.PT2.LT.PT2CUT) RETURN
15376
15377C...Select parton A flavour (massive Q handled above.)
15378 IF (MQMASS.EQ.0.AND.KFLC.NE.22.AND.MJOIN.EQ.0) THEN
15379 WTRAN=PYR(0)*WTSUM
15380 KFLA=-6
15381 240 KFLA=KFLA+1
15382 WTRAN=WTRAN-WTAP(KFLA)*WTPDF(KFLA)
15383 IF(KFLA.LE.5.AND.WTRAN.GT.0D0) GOTO 240
15384 IF(KFLA.EQ.6) KFLA=21
15385 ELSEIF (MJOIN.EQ.1) THEN
15386C...Tentative joining accept/reject.
15387 WTRAN=PYR(0)*WTJOIN
15388 MJ=0
15389 250 MJ=MJ+1
15390 WTRAN=WTRAN-WTAPJ(MJ)*WTPDFJ(MJ)
15391 IF(MJ.LE.MINT(31)-1.AND.WTRAN.GT.0D0) GOTO 250
15392 IF(MJOIND(JS,MJ).NE.0.OR.MJOIND(JS,MI).NE.0) THEN
15393 CALL PYERRM(9,'(PYPTIS:) Attempted double joining.'//
15394 & ' Rejected.')
15395 GOTO 230
15396 ENDIF
15397C...x*pdf (+ sea/val) at new pT2 for parton B.
15398 IF (KSVCB.LE.0) THEN
15399 MINT(30)=JS
15400C.... ALICE
15401C.... Store side in MINT(124)
15402 MINT(124) = JS
15403C....
15404 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFB)
15405 IF (KFLBA.LE.6) XFB(KFLB)=XPSVC(KFLB,KSVCB)
15406 ELSE
15407C...Companion distributions do not evolve.
15408 XFB(KFLB)=XFBO
15409 ENDIF
15410 WTVETO=1D0/WTPDFJ(MJ)/XFB(KFLB)
15411 KFLC=K(IMI(JS,MJ,1),2)
15412 KFLCA=IABS(KFLC)
15413 KSVCC=MAX(-1,IMI(JS,MJ,2))
15414 IF (KSVCB.GE.1) KSVCC=-1
15415C...x*pdf (+ sea/val) at new pT2 for parton C.
15416 MINT(30)=JS
15417 MINT(36)=MJ
15418C.... ALICE
15419C.... Store side in MINT(124)
15420 MINT(124) = JS
15421C....
15422 CALL PYPDFU(KFBEAM(JS),X1(MJ),PT2,XFJ)
15423 MINT(36)=MI
15424 IF (KFLCA.LE.6.AND.KSVCC.LE.0) XFJ(KFLC)=XPSVC(KFLC,KSVCC)
15425 WTVETO=WTVETO/XFJ(KFLC)
15426C...x and x*pdf (+ sea/val) at new pT2 for parton A.
15427 KFLA=21
15428 KSVCA=0
15429 IF (KFLCA.EQ.21.AND.KFLBA.LE.5) THEN
15430 KFLA=KFLB
15431 KSVCA=KSVCB
15432 ELSEIF (KFLBA.EQ.21.AND.KFLCA.LE.5) THEN
15433 KFLA=KFLC
15434 KSVCA=KSVCC
15435 ENDIF
15436 IF (KSVCA.LE.0) THEN
15437 MINT(30)=JS
15438C.... ALICE
15439C.... Store side in MINT(124)
15440 MINT(124) = JS
15441C....
15442 IF (KFLB.EQ.21) MINT(36)=MJ
15443 CALL PYPDFU(KFBEAM(JS),Y(MJ),PT2,XFJ)
15444 MINT(36)=MI
15445 IF (IABS(KFLA).LE.6) XFJ(KFLA)=XPSVC(KFLA,KSVCA)
15446 ELSE
15447 XFJ(KFLA)=PYFCMP(Y(MJ)/VINT(140),YS/VINT(140),MSTP(87))
15448 ENDIF
15449 WTVETO=WTVETO*XFJ(KFLA)
15450C...Monte Carlo veto.
15451 IF (WTVETO.LT.PYR(0)) GOTO 200
15452C...If accept, save PT2 of this joining.
15453 IF (PT2.GT.PT2MX) THEN
15454 PT2MX=PT2
15455 JSMX=2+JS
15456 MJN1MX=MJ
15457 MJN2MX=MI
15458 WTAPJ(MJ)=0D0
15459 NJN=0
15460 ENDIF
15461C...Exit and continue evolution.
15462 GOTO 390
15463 ENDIF
15464 KFLAA=IABS(KFLA)
15465
15466C...Choose z value (still in overestimated range) and corrective weight.
15467C...Unphysical z will be rejected below when Q2 has is computed.
15468 WTZ=0D0
15469
15470C...Note: ME and MQ>0 give corrections to overall weights, not shapes.
15471C...q -> q + g or q -> q + gamma (already set which).
15472 IF (KFLAA.LE.5.AND.KFLBA.LE.5) THEN
15473 IF (KSVCB.LT.0) THEN
15474 Z=1D0-(1D0-ZMIN)*((1D0-ZMAX)/(1D0-ZMIN))**PYR(0)
15475 ELSE
15476 ZFAC=RMIN*(RMAX/RMIN)**PYR(0)
15477 Z=((1-ZFAC)/(1+ZFAC))**2
15478 ENDIF
15479 WTZ=0.5D0*(1D0+Z**2)
15480C...Massive weight correction.
15481 IF (KFLBA.GE.4) WTZ=WTZ-Z*(1D0-Z)**2*RMQ2/PT2
15482C...Valence quark weight correction (extra sqrt)
15483 IF (KSVCB.GE.0) WTZ=WTZ*SQRT(Z)
15484
15485C...q -> g + q.
15486C...NB: MQ>0 not yet implemented. Forced absent above.
15487 ELSEIF (KFLAA.LE.5.AND.KFLB.EQ.21) THEN
15488 KFLC=KFLA
15489 Z=ZMAX/(1D0+PYR(0)*(SQRT(ZMAX/ZMIN)-1D0))**2
15490 WTZ=0.5D0*(1D0+(1D0-Z)**2)*SQRT(Z)
15491
15492C...g -> q + qbar.
15493 ELSEIF (KFLA.EQ.21.AND.KFLBA.LE.5) THEN
15494 KFLC=-KFLB
15495 Z=ZMIN+PYR(0)*(ZMAX-ZMIN)
15496 WTZ=Z**2+(1D0-Z)**2
15497C...Massive correction
15498 IF (MQMASS.NE.0) THEN
15499 WTZ=WTZ+2D0*Z*(1D0-Z)*RMQ2/PT2
15500C...Extra safety margin for light sea quark creation
15501 ELSEIF (KSVCB.LT.0) THEN
15502 WTZ=WTZ/1.25D0
15503 ENDIF
15504
15505C...g -> g + g.
15506 ELSEIF (KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15507 KFLC=21
15508 Z=1D0/(1D0+((1D0-ZMIN)/ZMIN)*((1D0-ZMAX)*ZMIN/
15509 & (ZMAX*(1D0-ZMIN)))**PYR(0))
15510 WTZ=(1D0-Z*(1D0-Z))**2
15511 ENDIF
15512
15513C...Derive Q2 from pT2.
15514 Q2B=PT2/(1D0-Z)
15515 IF (KFLBA.GE.4) Q2B=Q2B-RMQ2
15516
15517C...Loopback if outside allowed z range for given pT2.
15518 RM2C=PYMASS(KFLC)**2
15519 PT2ADJ=Q2B-Z*(SHTNOW(MI)+Q2B)*(Q2B+RM2C)/SHTNOW(MI)
15520 IF (PT2ADJ.LT.1D-6) GOTO 230
15521
15522C...Size of phase space and coherence suppression: MSTP(67) and MSTP(62)
15523C...No modification for very first emission if using ME correction
15524 MSTP67 = MSTP(67)
15525 IF (MECOR.GE.1.AND.NISGEN(1,MI).EQ.0.AND.NISGEN(2,MI).EQ.0) THEN
15526 MSTP67 = 0
15527 ENDIF
15528
15529C...For 1st branching, limit phase space by s-hat with color-partner
15530 IF (MSTP67.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15531 MSIDE=1
15532 IDIP=IMI(JS,MI,1)
15533C...Use anticolor tag for antiquark, or for gluon half the time
15534 IF ((KFLB.LT.0.AND.KFLBA.LT.10).OR.(
15535 & KFLB.EQ.21.AND.PYR(0).GT.0.5)) MSIDE=2
15536C...Tag
15537 MCTAG=MCT(IDIP,MSIDE)
15538C...Default is to set up phase space using the opposite incoming parton
15539 JDIP=IMI(3-JS,MI,1)
15540 NDIP=0
15541C...Alternatively, look for final-state color partner (pick first if several)
15542 DO 260 IFS=1,NPART
15543 IF (MCT(IPART(IFS),MSIDE).EQ.MCTAG.AND.NDIP.EQ.0) THEN
15544 JDIP=IPART(IFS)
15545 NDIP=NDIP+1
15546 ENDIF
15547 260 CONTINUE
15548C...Compute momentum transfer: sdip = -t = - (p1 - p2)^2
15549C...(also works for annihilation since incoming massless, so shat = -(p1 - p2)^2)
15550 SDIP=ABS(((P(IDIP,4)-P(JDIP,4))**2-(P(IDIP,3)-P(JDIP,3))**2
15551 & -(P(IDIP,2)-P(JDIP,2))**2-(P(IDIP,1)-P(JDIP,1))**2))
15552 IF (MSTP67.EQ.1) THEN
15553C...1 Option to completely kill radiation above s_dip * PARP(67)
15554 IF (4D0*PT2.GT.PARP(67)*SDIP) GOTO 230
15555 ELSE IF (MSTP67.EQ.2) THEN
15556C...2 Option to allow suppressed unordered radiation above s_dip * PARP(67)
15557C... (-> improved power showers?)
15558 IF (4D0*PT2*PYR(0).GT.PARP(67)*SDIP) GOTO 230
15559 ENDIF
15560
15561C...For subsequent branchings, loopback if nonordered in angle/rapidity
15562 ELSE IF (MSTP(62).GE.3.AND.NISGEN(JS,MI).GE.1) THEN
15563 IF(PT2.GT.((1D0-Z)/(Z*(1D0-ZSAV(JS,MI))))**2*PT2SAV(JS,MI))
15564 & GOTO 230
15565 ENDIF
15566
15567C...Select phi angle of branching at random.
15568 PHI=PARU(2)*PYR(0)
15569
15570C...Matrix-element corrections for some processes.
15571 IF (MECOR.GE.1.AND.NISGEN(JS,MI).EQ.0) THEN
15572 IF (KFLAA.LE.20.AND.KFLBA.LE.20) THEN
15573 CALL PYMEWT(MECOR,1,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15574 WTZ=WTZ*WTME/WTFF
15575 ELSEIF((KFLA.EQ.21.OR.KFLA.EQ.22).AND.KFLBA.LE.20) THEN
15576 CALL PYMEWT(MECOR,2,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15577 WTZ=WTZ*WTME/WTGF
15578 ELSEIF(KFLAA.LE.20.AND.(KFLB.EQ.21.OR.KFLB.EQ.22)) THEN
15579 CALL PYMEWT(MECOR,3,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15580 WTZ=WTZ*WTME/WTFG
15581 ELSEIF(KFLA.EQ.21.AND.KFLB.EQ.21) THEN
15582 CALL PYMEWT(MECOR,4,Q2B*SHAT/SHTNOW(MI),Z,PHI,WTME)
15583 WTZ=WTZ*WTME/WTGG
15584 ENDIF
15585 ENDIF
15586
15587C...Parton distributions at new pT2 but old x.
15588 MINT(30)=JS
15589C.... ALICE
15590C.... Store side in MINT(124)
15591 MINT(124) = JS
15592C....
15593 CALL PYPDFU(KFBEAM(JS),XB,PT2,XFN)
15594C...Treat val and cmp separately
15595 IF (KFLBA.LE.6.AND.KSVCB.LE.0) XFN(KFLB)=XPSVC(KFLB,KSVCB)
15596 IF (KSVCB.GE.1)
15597 & XFN(KFLB)=PYFCMP(YB/VINT(140),YS/VINT(140),MSTP(87))
15598 XFBN=XFN(KFLB)
15599 IF(XFBN.LT.1D-20) THEN
15600 IF(KFLA.EQ.KFLB) THEN
15601 WTAP(KFLB)=0D0
15602 GOTO 200
15603 ELSE
15604 XFBN=1D-10
15605 XFN(KFLB)=XFBN
15606 ENDIF
15607 ENDIF
15608 DO 270 KFL=-5,5
15609 XFB(KFL)=XFN(KFL)
15610 270 CONTINUE
15611 XFB(21)=XFN(21)
15612
15613C...Parton distributions at new pT2 and new x.
15614 XA=XB/Z
15615 MINT(30)=JS
15616C.... ALICE
15617C.... Store side in MINT(124)
15618 MINT(124) = JS
15619C....
15620 CALL PYPDFU(KFBEAM(JS),XA,PT2,XFA)
15621 IF (KFLBA.LE.5.AND.KFLAA.LE.5) THEN
15622C...q -> q + g: only consider respective sea, val, or cmp content.
15623 IF (KSVCB.LE.0) THEN
15624 XFA(KFLA)=XPSVC(KFLA,KSVCB)
15625 ELSE
15626 YA=XA*(1D0-YS)
15627 XFA(KFLB)=PYFCMP(YA/VINT(140),YS/VINT(140),MSTP(87))
15628 ENDIF
15629 ENDIF
15630 XFAN=XFA(KFLA)
15631 IF(XFAN.LT.1D-20) THEN
15632 GOTO 200
15633 ENDIF
15634
15635C...If weighting fails continue evolution.
15636 WTTOT=0D0
15637 IF (MCRQQ.EQ.0) THEN
15638 WTPDFA=1D0/WTPDF(KFLA)
15639 WTTOT=WTZ*XFAN/XFBN*WTPDFA
15640 ELSEIF(MCRQQ.EQ.1) THEN
15641 WTPDFA=TPM/WPDF0
15642 WTTOT=WTCRQQ*WTZ*XFAN/XFBN*WTPDFA
15643 XBEST=TPM/TPM0*XQ0
15644 ELSEIF(MCRQQ.EQ.2) THEN
15645C...Force massive quark creation.
15646 WTTOT=1D0
15647 ENDIF
15648
15649C...Loop back if trial emission fails.
15650 IF(WTTOT.GE.0D0.AND.WTTOT.LT.PYR(0)) GOTO 200
15651 WTACC=((1D0+PT2)/(0.25D0+PT2))**2
15652 IF(WTTOT.LT.0D0) THEN
15653 WRITE(CHWT,'(1P,E12.4)') WTTOT
15654 CALL PYERRM(19,'(PYPTIS:) Weight '//CHWT//' negative')
15655 ELSEIF(WTTOT.GT.WTACC) THEN
15656 WRITE(CHWT,'(1P,E12.4)') WTTOT
15657 IF (PT2.GT.PTEMAX.OR.WTTOT.GE.WTEMAX) THEN
15658C...Too high weight: write out as error, but do not update error counter
15659 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)-1
15660 CALL PYERRM(19,
15661 & '(PYPTIS:) Weight '//CHWT//' above unity')
15662 IF (PT2.GT.PTEMAX) PTEMAX=PT2
15663 IF (WTTOT.GT.WTEMAX) WTEMAX=WTTOT
15664 ELSE
15665 CALL PYERRM(9,
15666 & '(PYPTIS:) Weight '//CHWT//' above unity')
15667 ENDIF
15668C...Useful for debugging but commented out for distribution:
15669C print*, 'JS, MI',JS, MI
15670C print*, 'PT:',SQRT(PT2), ' MCRQQ',MCRQQ
15671C print*, 'A -> B C',KFLA, KFLB, KFLC
15672C XFAO=XFBO/WTPDFA
15673C print*, 'WT(Z,XFA,XFB)',WTZ, XFAN/XFAO, XFBO/XFBN
15674 ENDIF
15675
15676C...Special for PT2 = PT2MX (e.g., if two incoming massive quarks
15677C...simultaneously reached their creation thresholds)
15678 IF (ABS(PT2-PT2MX).LT.0.001) THEN
15679 IF (PYR(0).GT.0.5) PT2=1.0001*PT2MX
15680 ENDIF
15681
15682C...Save acceptable branching.
15683 IF(PT2.GT.PT2MX) THEN
15684 MIMX=MINT(36)
15685 JSMX=JS
15686 PT2MX=PT2
15687 KFLAMX=KFLA
15688 KFLCMX=KFLC
15689 RM2CMX=RM2C
15690 Q2BMX=Q2B
15691 ZMX=Z
15692 PT2AMX=PT2ADJ
15693 PHIMX=PHI
15694 ENDIF
15695
15696C----------------------------------------------------------------------
15697C...MODE= 1: Accept stored shower branching. Update event record etc.
15698 ELSEIF (MODE.EQ.1) THEN
15699 MI=MIMX
15700 JS=JSMX
15701 SHAT=SHTNOW(MI)
15702 SIDE=3D0-2D0*JS
15703C...Shift down rest of event record to make room for insertion.
15704 IT=IMISEP(MI)+1
15705 IM=IT+1
15706 IS=IMI(JS,MI,1)
15707 DO 290 I=N,IT,-1
15708 IF (K(I,3).GE.IT) K(I,3)=K(I,3)+2
15709 KT1=K(I,4)/MSTU(5)**2
15710 KT2=K(I,5)/MSTU(5)**2
15711 ID1=MOD(K(I,4),MSTU(5))
15712 ID2=MOD(K(I,5),MSTU(5))
15713 IM1=MOD(K(I,4)/MSTU(5),MSTU(5))
15714 IM2=MOD(K(I,5)/MSTU(5),MSTU(5))
15715 IF (ID1.GE.IT) ID1=ID1+2
15716 IF (ID2.GE.IT) ID2=ID2+2
15717 IF (IM1.GE.IT) IM1=IM1+2
15718 IF (IM2.GE.IT) IM2=IM2+2
15719 K(I,4)=KT1*MSTU(5)**2+IM1*MSTU(5)+ID1
15720 K(I,5)=KT2*MSTU(5)**2+IM2*MSTU(5)+ID2
15721 DO 280 IX=1,5
15722 K(I+2,IX)=K(I,IX)
15723 P(I+2,IX)=P(I,IX)
15724 V(I+2,IX)=V(I,IX)
15725 280 CONTINUE
15726 MCT(I+2,1)=MCT(I,1)
15727 MCT(I+2,2)=MCT(I,2)
15728 290 CONTINUE
15729 N=N+2
15730C...Also update shifted-down pointers in IMI, IMISEP, and IPART.
15731 DO 300 JI=1,MINT(31)
15732 IF (IMI(1,JI,1).GE.IT) IMI(1,JI,1)=IMI(1,JI,1)+2
15733 IF (IMI(1,JI,2).GE.IT) IMI(1,JI,2)=IMI(1,JI,2)+2
15734 IF (IMI(2,JI,1).GE.IT) IMI(2,JI,1)=IMI(2,JI,1)+2
15735 IF (IMI(2,JI,2).GE.IT) IMI(2,JI,2)=IMI(2,JI,2)+2
15736 IF (JI.GE.MI) IMISEP(JI)=IMISEP(JI)+2
15737C...Also update companion pointers to the present mother.
15738 IF (IMI(JS,JI,2).EQ.IS) IMI(JS,JI,2)=IM
15739 300 CONTINUE
15740 DO 310 IFS=1,NPART
15741 IF (IPART(IFS).GE.IT) IPART(IFS)=IPART(IFS)+2
15742 310 CONTINUE
15743C...Zero entries dedicated for new timelike and mother partons.
15744 DO 330 I=IT,IT+1
15745 DO 320 J=1,5
15746 K(I,J)=0
15747 P(I,J)=0D0
15748 V(I,J)=0D0
15749 320 CONTINUE
15750 MCT(I,1)=0
15751 MCT(I,2)=0
15752 330 CONTINUE
15753
15754C...Define timelike and new mother partons. History.
15755 K(IT,1)=3
15756 K(IT,2)=KFLCMX
15757 K(IM,1)=14
15758 K(IM,2)=KFLAMX
15759 K(IS,3)=IM
15760 K(IT,3)=IM
15761C...Set mother origin = side.
15762 K(IM,3)=MINT(83)+JS+2
15763 IF(MI.GE.2) K(IM,3)=MINT(83)+JS
15764
15765C...Define colour flow of branching.
15766 IM1=IM
15767 IM2=IM
15768C...q -> q + gamma.
15769 IF(K(IT,2).EQ.22) THEN
15770 K(IT,1)=1
15771 ID1=IS
15772 ID2=IS
15773C...q -> q + g.
15774 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5.AND.K(IT,2).EQ.21) THEN
15775 ID1=IT
15776 ID2=IS
15777C...q -> g + q.
15778 ELSEIF(K(IM,2).GT.0.AND.K(IM,2).LE.5) THEN
15779 ID1=IS
15780 ID2=IT
15781C...qbar -> qbar + g.
15782 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5.AND.K(IT,2).EQ.21) THEN
15783 ID1=IS
15784 ID2=IT
15785C...qbar -> g + qbar.
15786 ELSEIF(K(IM,2).LT.0.AND.K(IM,2).GE.-5) THEN
15787 ID1=IT
15788 ID2=IS
15789C...g -> g + g; g -> q + qbar..
15790 ELSEIF((K(IT,2).EQ.21.AND.PYR(0).GT.0.5D0).OR.K(IT,2).LT.0) THEN
15791 ID1=IS
15792 ID2=IT
15793 ELSE
15794 ID1=IT
15795 ID2=IS
15796 ENDIF
15797 IF(IM1.EQ.IM) K(IM1,4)=K(IM1,4)+ID1
15798 IF(IM2.EQ.IM) K(IM2,5)=K(IM2,5)+ID2
15799 K(ID1,4)=K(ID1,4)+MSTU(5)*IM1
15800 K(ID2,5)=K(ID2,5)+MSTU(5)*IM2
15801 IF(ID1.NE.ID2) THEN
15802 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
15803 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
15804 ENDIF
15805 IF(K(IT,1).EQ.1) THEN
15806 K(IT,4)=0
15807 K(IT,5)=0
15808 ENDIF
15809C...Update IMI and colour tag arrays.
15810 IMI(JS,MI,1)=IM
15811 DO 340 MC=1,2
15812 MCT(IT,MC)=0
15813 MCT(IM,MC)=0
15814 340 CONTINUE
15815 DO 350 JCS=4,5
15816 KCS=JCS
15817C...If mother flag not yet set for spacelike parton, trace it.
15818 IF (K(IS,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IS,-KCS,IM)
15819 IF(MINT(51).NE.0) RETURN
15820 350 CONTINUE
15821 DO 360 JCS=4,5
15822 KCS=JCS
15823C...If mother flag not yet set for timelike parton, trace it.
15824 IF (K(IT,KCS)/MSTU(5)**2.LE.1) CALL PYCTTR(IT,KCS,IM)
15825 IF(MINT(51).NE.0) RETURN
15826 360 CONTINUE
15827
15828C...Boost recoiling parton to compensate for Q2 scale.
15829 BETAZ=SIDE*(1D0-(1D0+Q2BMX/SHAT)**2)/
15830 & (1D0+(1D0+Q2BMX/SHAT)**2)
15831 IR=IMI(3-JS,MI,1)
15832 CALL PYROBO(IR,IR,0D0,0D0,0D0,0D0,BETAZ)
15833
15834C...Define system to be rotated and boosted
15835C...(not including the 2 just added partons)
15836C...(but including the docu lines for first interaction)
15837 IMIN=IMISEP(MI-1)+1
15838 IF (MI.EQ.1) IMIN=MINT(83)+5
15839 IMAX=IMISEP(MI)-2
15840
15841C...Rotate back system in phi to compensate for subsequent rotation.
15842 CALL PYROBO(IMIN,IMAX,0D0,-PHIMX,0D0,0D0,0D0)
15843
15844C...Define kinematics of new partons in old frame.
15845 IMAX=IMISEP(MI)
15846 P(IM,1)=SQRT(PT2AMX)*SHAT/(ZMX*(SHAT+Q2BMX))
15847 P(IM,3)=0.5D0*SQRT(SHAT)*((SHAT-Q2BMX)/((SHAT
15848 & +Q2BMX)*ZMX)+(Q2BMX+RM2CMX)/SHAT)*SIDE
15849 P(IM,4)=SQRT(P(IM,1)**2+P(IM,3)**2)
15850 P(IT,1)=P(IM,1)
15851 P(IT,3)=P(IM,3)-0.5D0*(SHAT+Q2BMX)/SQRT(SHAT)*SIDE
15852 P(IT,4)=SQRT(P(IT,1)**2+P(IT,3)**2+RM2CMX)
15853 P(IT,5)=SQRT(RM2CMX)
15854
15855C...Update internal line, now spacelike
15856 P(IS,1)=P(IM,1)-P(IT,1)
15857 P(IS,2)=P(IM,2)-P(IT,2)
15858 P(IS,3)=P(IM,3)-P(IT,3)
15859 P(IS,4)=P(IM,4)-P(IT,4)
15860 P(IS,5)=P(IS,4)**2-P(IS,1)**2-P(IS,2)**2-P(IS,3)**2
15861C...Represent spacelike virtualities as -sqrt(abs(Q2)) .
15862 IF (P(IS,5).LT.0D0) THEN
15863 P(IS,5)=-SQRT(ABS(P(IS,5)))
15864 ELSE
15865 P(IS,5)=SQRT(P(IS,5))
15866 ENDIF
15867
15868C...Boost entire system and rotate to new frame.
15869C...(including docu lines)
15870 BETAX=(P(IM,1)+P(IR,1))/(P(IM,4)+P(IR,4))
15871 BETAZ=(P(IM,3)+P(IR,3))/(P(IM,4)+P(IR,4))
15872 IF(BETAX**2+BETAZ**2.GE.1D0) THEN
15873 CALL PYERRM(1,'(PYPTIS:) boost bigger than unity')
15874 MINT(51)=1
15875 IFAIL=-1
15876 RETURN
15877 ENDIF
15878 CALL PYROBO(IMIN,IMAX,0D0,0D0,-BETAX,0D0,-BETAZ)
15879 I1=IMI(1,MI,1)
15880 THETA=PYANGL(P(I1,3),P(I1,1))
15881 CALL PYROBO(IMIN,IMAX,-THETA,PHIMX,0D0,0D0,0D0)
15882
15883C...Global statistics.
15884 MINT(352)=MINT(352)+1
15885 VINT(352)=VINT(352)+SQRT(P(IT,1)**2+P(IT,2)**2)
15886 IF (MINT(352).EQ.1) VINT(357)=SQRT(P(IT,1)**2+P(IT,2)**2)
15887
15888C...Add parton with relevant pT scale for timelike shower.
15889 IF (K(IT,2).NE.22) THEN
15890 NPART=NPART+1
15891 IPART(NPART)=IT
15892 PTPART(NPART)=SQRT(PT2AMX)
15893 ENDIF
15894
15895C...Update saved variables.
15896 SHTNOW(MIMX)=SHTNOW(MIMX)/ZMX
15897 NISGEN(JSMX,MIMX)=NISGEN(JSMX,MIMX)+1
15898 XMI(JSMX,MIMX)=XMI(JSMX,MIMX)/ZMX
15899 PT2SAV(JSMX,MIMX)=PT2MX
15900 ZSAV(JS,MIMX)=ZMX
15901
15902 KSA=IABS(K(IS,2))
15903 KMA=IABS(K(IM,2))
15904 IF (KSA.EQ.21.AND.KMA.GE.1.AND.KMA.LE.5) THEN
15905C...Gluon reconstructs to quark.
15906C...Decide whether newly created quark is valence or sea:
15907 MINT(30)=JS
15908 CALL PYPTMI(2,PT2NOW,PTDUM1,PTDUM2,IFAIL)
15909 IF(MINT(51).NE.0) RETURN
15910 ENDIF
15911 IF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.EQ.21) THEN
15912C...Quark reconstructs to gluon.
15913C...Now some guy may have lost his companion. Check.
15914 ICMP=IMI(JS,MI,2)
15915 IF (ICMP.GT.0) THEN
15916 CALL PYERRM(9,'(PYPTIS:) Sorry, companion quark radiated'
15917 & //' away. Cannot handle that yet. Giving up.')
15918 MINT(51)=1
15919 RETURN
15920 ELSEIF(ICMP.LT.0) THEN
15921C...A sea quark with companion still in BR was reconstructed to a gluon.
15922C...Companion should now be removed from the beam remnant.
15923C...(Momentum integral is automatically updated in next call to PYPDFU.)
15924 ICMP=-ICMP
15925 IFL=-K(IS,2)
15926 DO 380 JCMP=ICMP,NVC(JS,IFL)-1
15927 XASSOC(JS,IFL,JCMP)=XASSOC(JS,IFL,JCMP+1)
15928 DO 370 JI=1,MINT(31)
15929 KMI=-IMI(JS,JI,2)
15930 JFL=-K(IMI(JS,JI,1),2)
15931 IF (KMI.EQ.JCMP+1.AND.JFL.EQ.IFL) IMI(JS,JI,2)=IMI(JS,JI
15932 & ,2)+1
15933 370 CONTINUE
15934 380 CONTINUE
15935 NVC(JS,IFL)=NVC(JS,IFL)-1
15936 ENDIF
15937C...Set gluon IMI(JS,MI,2) = 0.
15938 IMI(JS,MI,2)=0
15939 ELSEIF(KSA.GE.1.AND.KSA.LE.5.AND.KMA.NE.21) THEN
15940C...Quark reconstructing to quark. If sea with companion still in BR
15941C...then update associated x value.
15942C...(Momentum integral is automatically updated in next call to PYPDFU.)
15943 IF (IMI(JS,MI,2).LT.0) THEN
15944 ICMP=-IMI(JS,MI,2)
15945 IFL=-K(IS,2)
15946 XASSOC(JS,IFL,ICMP)=XMI(JSMX,MIMX)
15947 ENDIF
15948 ENDIF
15949
15950 ENDIF
15951
15952C...If reached this point, normal exit.
15953 390 IFAIL=0
15954
15955 RETURN
15956 END
15957
15958C*********************************************************************
15959
15960C...PYMEMX
15961C...Generates maximum ME weight in some initial-state showers.
15962C...Inparameter MECOR: kind of hard scattering process
15963C...Outparameter WTFF: maximum weight for fermion -> fermion
15964C... WTGF: maximum weight for gluon/photon -> fermion
15965C... WTFG: maximum weight for fermion -> gluon/photon
15966C... WTGG: maximum weight for gluon -> gluon
15967
15968 SUBROUTINE PYMEMX(MECOR,WTFF,WTGF,WTFG,WTGG)
15969
15970C...Double precision and integer declarations.
15971 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
15972 IMPLICIT INTEGER(I-N)
15973 INTEGER PYK,PYCHGE,PYCOMP
15974C...Commonblocks.
15975 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
15976 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
15977 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
15978 COMMON/PYINT1/MINT(400),VINT(400)
15979 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
15980 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
15981
15982C...Default maximum weight.
15983 WTFF=1D0
15984 WTGF=1D0
15985 WTFG=1D0
15986 WTGG=1D0
15987
15988C...Select maximum weight by process.
15989 IF(MECOR.EQ.1) THEN
15990 WTFF=1D0
15991 WTGF=3D0
15992 ELSEIF(MECOR.EQ.2) THEN
15993 WTFG=1D0
15994 WTGG=1D0
15995 ENDIF
15996
15997 RETURN
15998 END
15999
16000C*********************************************************************
16001
16002C...PYMEWT
16003C...Calculates actual ME weight in some initial-state showers.
16004C...Inparameter MECOR: kind of hard scattering process
16005C... IFLCB: flavour combination of branching,
16006C... 1 for fermion -> fermion,
16007C... 2 for gluon/photon -> fermion
16008C... 3 for fermion -> gluon/photon,
16009C... 4 for gluon -> gluon
16010C... Q2: Q2 value of shower branching
16011C... Z: Z value of branching
16012C...In+outparameter PHIBR: azimuthal angle of branching
16013C...Outparameter WTME: actual ME weight
16014
16015 SUBROUTINE PYMEWT(MECOR,IFLCB,Q2,Z,PHIBR,WTME)
16016
16017C...Double precision and integer declarations.
16018 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16019 IMPLICIT INTEGER(I-N)
16020 INTEGER PYK,PYCHGE,PYCOMP
16021C...Commonblocks.
16022 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16023 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16024 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16025 COMMON/PYINT1/MINT(400),VINT(400)
16026 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16027 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINT2/
16028
16029C...Default output.
16030 WTME=1D0
16031
16032C...Define kinematics of shower branching in Mandelstam variables.
16033 SQM=VINT(44)
16034 SH=SQM/Z
16035 TH=-Q2
16036 UH=Q2-SQM*(1D0-Z)/Z
16037
16038C...Matrix-element corrections for f + fbar -> s-channel vector boson.
16039 IF(MECOR.EQ.1) THEN
16040 IF(IFLCB.EQ.1) THEN
16041 WTME=(TH**2+UH**2+2D0*SQM*SH)/(SH**2+SQM**2)
16042 ELSEIF(IFLCB.EQ.2) THEN
16043 WTME=(SH**2+TH**2+2D0*SQM*UH)/((SH-SQM)**2+SQM**2)
16044 ENDIF
16045
16046C...Matrix-element corrections for g + g -> Higgs (h0, H0, A0).
16047 ELSEIF(MECOR.EQ.2) THEN
16048 IF(IFLCB.EQ.3) THEN
16049 WTME=(SH**2+UH**2)/(SH**2+(SH-SQM)**2)
16050 ELSEIF(IFLCB.EQ.4) THEN
16051 WTME=0.5D0*(SH**4+UH**4+TH**4+SQM**4)/(SH**2-SQM*(SH-SQM))**2
16052 ENDIF
16053
16054C...Matrix-element corrections for q + qbar -> Higgs (h0)
16055 ELSEIF(MECOR.EQ.3) THEN
16056 IF(IFLCB.EQ.2) THEN
16057 WTME=(SH**2+TH**2+2D0*(SQM-TH)*(SQM-SH))/
16058 1 (SH**2+2D0*SQM*(SQM-SH))
16059 ENDIF
16060 ENDIF
16061
16062 RETURN
16063 END
16064
16065C*********************************************************************
16066
16067C...PYPTMI
16068C...Handles the generation of additional interactions in the new
16069C...multiple interactions framework.
16070C...MODE=-1 : Initalize MI from scratch.
16071C...MODE= 0 : Generate trial interaction. Start at PT2NOW, solve
16072C... Sudakov for PT2, abort if below PT2CUT.
16073C...MODE= 1 : Accept interaction at PT2NOW and store variables.
16074C...MODE= 2 : Decide sea/val/cmp for kicked-out quark at PT2NOW
16075C...PT2NOW : Starting (max) PT2 scale for evolution.
16076C...PT2CUT : Lower limit for evolution.
16077C...PT2 : Result of evolution. Generated PT2 for trial interaction.
16078C...IFAIL : Status return code.
16079C... = 0: All is well.
16080C... < 0: Phase space exhausted, generation to be terminated.
16081C... > 0: Additional interaction vetoed, but continue evolution.
16082
16083 SUBROUTINE PYPTMI(MODE,PT2NOW,PT2CUT,PT2,IFAIL)
16084C...Double precision and integer declarations.
16085 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16086 IMPLICIT INTEGER(I-N)
16087 INTEGER PYK,PYCHGE,PYCOMP
16088C...Parameter statement for maximum size of showers.
16089 PARAMETER (MAXNUR=1000)
16090C...Commonblocks.
16091 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16092 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16093 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16094 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
16095 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
16096 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16097 COMMON/PYINT1/MINT(400),VINT(400)
16098 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
16099 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
16100 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
16101 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
16102 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
16103 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
16104 & XMI(2,240),PT2MI(240),IMISEP(0:240)
16105 COMMON/PYISMX/MIMX,JSMX,KFLAMX,KFLCMX,KFBEAM(2),NISGEN(2,240),
16106 & PT2MX,PT2AMX,ZMX,RM2CMX,Q2BMX,PHIMX
16107 COMMON/PYCTAG/NCT,MCT(4000,2)
16108C...Local arrays and saved variables.
16109 DIMENSION WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25)
16110
16111 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,
16112 & /PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/,
16113 & /PYISMX/,/PYCTAG/
16114 SAVE NCHN,XT2FAC,SIGS
16115
16116 IFAIL=0
16117C...Set MI subprocess = QCD 2 -> 2.
16118 ISUB=96
16119
16120C----------------------------------------------------------------------
16121C...MODE=-1: Initialize from scratch
16122 IF (MODE.EQ.-1) THEN
16123C...Initialize PT2 array.
16124 PT2MI(1)=VINT(54)
16125C...Initialize list of incoming beams and partons from two sides.
16126 DO 110 JS=1,2
16127 DO 100 MI=1,240
16128 IMI(JS,MI,1)=0
16129 IMI(JS,MI,2)=0
16130 100 CONTINUE
16131 NMI(JS)=1
16132 IMI(JS,1,1)=MINT(84)+JS
16133 IMI(JS,1,2)=0
16134 XMI(JS,1)=VINT(40+JS)
16135C...Rescale x values to fractions of photon energy.
16136 IF(MINT(18+JS).EQ.1) XMI(JS,1)=VINT(40+JS)/VINT(154+JS)
16137C...Hard reset: hard interaction initiators motherless by definition.
16138 K(MINT(84)+JS,3)=2+JS
16139 K(MINT(84)+JS,4)=MOD(K(MINT(84)+JS,4),MSTU(5))
16140 K(MINT(84)+JS,5)=MOD(K(MINT(84)+JS,5),MSTU(5))
16141 110 CONTINUE
16142 IMISEP(0)=MINT(84)
16143 IMISEP(1)=N
16144 IF (MOD(MSTP(81),10).GE.1) THEN
16145 IF(MSTP(82).LE.1) THEN
16146 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0
16147 & ,5))
16148 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
16149 & VINT(317)/(VINT(318)*VINT(320))
16150 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
16151 ELSE
16152 XT2FAC=VINT(146)*VINT(148)*XSEC(ISUB,1)/
16153 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
16154 ENDIF
16155 ENDIF
16156C...Zero entries relating to scatterings beyond the first.
16157 DO 120 MI=2,240
16158 IMI(1,MI,1)=0
16159 IMI(2,MI,1)=0
16160 IMI(1,MI,2)=0
16161 IMI(2,MI,2)=0
16162 IMISEP(MI)=IMISEP(1)
16163 PT2MI(MI)=0D0
16164 XMI(1,MI)=0D0
16165 XMI(2,MI)=0D0
16166 120 CONTINUE
16167C...Initialize factors for PDF reshaping.
16168 DO 140 JS=1,2
16169 KFBEAM(JS)=MINT(10+JS)
16170 IF(MINT(18+JS).EQ.1) KFBEAM(JS)=22
16171 KFABM=IABS(KFBEAM(JS))
16172 KFSBM=ISIGN(1,KFBEAM(JS))
16173
16174C...Zero flavour content of incoming beam particle.
16175 KFIVAL(JS,1)=0
16176 KFIVAL(JS,2)=0
16177 KFIVAL(JS,3)=0
16178C... Flavour content of baryon.
16179 IF(KFABM.GT.1000) THEN
16180 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
16181 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
16182 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
16183C... Flavour content of pi+-, K+-.
16184 ELSEIF(KFABM.EQ.211) THEN
16185 KFIVAL(JS,1)=KFSBM*2
16186 KFIVAL(JS,2)=-KFSBM
16187 ELSEIF(KFABM.EQ.321) THEN
16188 KFIVAL(JS,1)=-KFSBM*3
16189 KFIVAL(JS,2)=KFSBM*2
16190C... Flavour content of pi0, gamma, K0S, K0L not defined yet.
16191 ENDIF
16192
16193C...Zero initial valence and companion content.
16194 DO 130 IFL=-6,6
16195 NVC(JS,IFL)=0
16196 130 CONTINUE
16197 140 CONTINUE
16198C...Set up colour line tags starting from hard interaction initiators.
16199 NCT=0
16200C...Reset colour tag array and colour processing flags.
16201 DO 150 I=IMISEP(0)+1,N
16202 MCT(I,1)=0
16203 MCT(I,2)=0
16204 K(I,4)=MOD(K(I,4),MSTU(5)**2)
16205 K(I,5)=MOD(K(I,5),MSTU(5)**2)
16206 150 CONTINUE
16207C... Consider each side in turn.
16208 DO 170 JS=1,2
16209 I1=IMI(JS,1,1)
16210 I2=IMI(3-JS,1,1)
16211 DO 160 JCS=4,5
16212 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
16213 & GOTO 160
16214 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 160
16215 KCS=JCS
16216 CALL PYCTTR(I1,KCS,I2)
16217 IF(MINT(51).NE.0) RETURN
16218 160 CONTINUE
16219 170 CONTINUE
16220
16221C...Range checking for companion quark pdf large-x param.
16222 IF (MSTP(87).LT.0) THEN
16223 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
16224 & ' MSTP(87)=0')
16225 MSTP(87)=0
16226 ELSEIF (MSTP(87).GT.4) THEN
16227 CALL PYERRM(19,'(PYPTMI:) MSTP(87) out of range. Forced'//
16228 & ' MSTP(87)=4')
16229 MSTP(87)=4
16230 ENDIF
16231
16232C----------------------------------------------------------------------
16233C...MODE=0: Generate trial interaction. Return codes:
16234C...IFAIL < 0: Phase space exhausted, generation to be terminated.
16235C...IFAIL = 0: Additional interaction generated at PT2.
16236C...IFAIL > 0: Additional interaction vetoed, but continue evolution.
16237 ELSEIF (MODE.EQ.0) THEN
16238C...Abolute MI max scale = VINT(62)
16239 XT2=4D0*MIN(PT2NOW,VINT(62))/VINT(2)
16240 180 IF(MSTP(82).LE.1) THEN
16241 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
16242 IF(XT2.LT.VINT(149)) IFAIL=-2
16243 ELSE
16244 IF(XT2.LE.0.01001D0*VINT(149)) THEN
16245 IFAIL=-3
16246 ELSE
16247 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
16248 & LOG(PYR(0)))-VINT(149)
16249 ENDIF
16250 ENDIF
16251C...Also exit if below lower limit or if higher trial branching
16252C...already found.
16253 PT2=0.25D0*VINT(2)*XT2
16254 IF (PT2.LE.PT2CUT) IFAIL=-4
16255 IF (PT2.LE.PT2MX) IFAIL=-5
16256 IF (IFAIL.NE.0) THEN
16257 PT2=0D0
16258 RETURN
16259 ENDIF
16260 IF(MSTP(82).GE.2) PT2=MAX(0.25D0*VINT(2)*0.01D0*VINT(149),PT2)
16261 VINT(25)=4D0*PT2/VINT(2)
16262 XT2=VINT(25)
16263
16264C...Choose tau and y*. Calculate cos(theta-hat).
16265 IF(PYR(0).LE.COEF(ISUB,1)) THEN
16266 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
16267 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
16268 ELSE
16269 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
16270 ENDIF
16271 VINT(21)=TAU
16272C...New: require shat > 1.
16273 IF(TAU*VINT(2).LT.1D0) GOTO 180
16274 CALL PYKLIM(2)
16275 RYST=PYR(0)
16276 MYST=1
16277 IF(RYST.GT.COEF(ISUB,8)) MYST=2
16278 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
16279 CALL PYKMAP(2,MYST,PYR(0))
16280 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
16281
16282C...Check that x not used up. Accept or reject kinematical variables.
16283 X1M=SQRT(TAU)*EXP(VINT(22))
16284 X2M=SQRT(TAU)*EXP(-VINT(22))
16285 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 180
16286 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
16287 NCHN=0
16288 CALL PYSIGH(NCHN,SIGS)
16289 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
16290 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 180
16291 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
16292
16293C...Save if highest PT so far.
16294 IF (PT2.GT.PT2MX) THEN
16295 JSMX=0
16296 MIMX=MINT(31)+1
16297 PT2MX=PT2
16298 ENDIF
16299
16300C----------------------------------------------------------------------
16301C...MODE=1: Generate and save accepted scattering.
16302 ELSEIF (MODE.EQ.1) THEN
16303 PT2=PT2NOW
16304C...Reset K, P, V, and MCT vectors.
16305 DO 200 I=N+1,N+4
16306 DO 190 J=1,5
16307 K(I,J)=0
16308 P(I,J)=0D0
16309 V(I,J)=0D0
16310 190 CONTINUE
16311 MCT(I,1)=0
16312 MCT(I,2)=0
16313 200 CONTINUE
16314
16315 NTRY=0
16316C...Choose flavour of reacting partons (and subprocess).
16317 210 NTRY=NTRY+1
16318 IF (NTRY.GT.50) THEN
16319 CALL PYERRM(9,'(PYPTMI:) Unable to generate additional '
16320 & //'interaction. Giving up!')
16321 MINT(51)=1
16322 RETURN
16323 ENDIF
16324 RSIGS=SIGS*PYR(0)
16325 DO 220 ICHN=1,NCHN
16326 KFL1=ISIG(ICHN,1)
16327 KFL2=ISIG(ICHN,2)
16328 ICONMI=ISIG(ICHN,3)
16329 RSIGS=RSIGS-SIGH(ICHN)
16330 IF(RSIGS.LE.0D0) GOTO 230
16331 220 CONTINUE
16332
16333C...Reassign to appropriate process codes.
16334 230 ISUBMI=ICONMI/10
16335 ICONMI=MOD(ICONMI,10)
16336
16337C...Choose new quark flavour for annihilation graphs
16338 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
16339 SH=VINT(21)*VINT(2)
16340 CALL PYWIDT(21,SH,WDTP,WDTE)
16341 240 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
16342 DO 250 I=1,MDCY(21,3)
16343 KFLF=KFDP(I+MDCY(21,2)-1,1)
16344 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
16345 IF(RKFL.LE.0D0) GOTO 260
16346 250 CONTINUE
16347 260 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
16348 IF(KFLF.GE.4) GOTO 240
16349 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
16350 KFLF=4
16351 ICONMI=ICONMI-2
16352 ELSEIF(ISUBMI.EQ.53) THEN
16353 KFLF=5
16354 ICONMI=ICONMI-4
16355 ENDIF
16356 ENDIF
16357
16358C...Final state flavours and colour flow: default values
16359 JS=1
16360 KFL3=KFL1
16361 KFL4=KFL2
16362 KCC=20
16363 KCS=ISIGN(1,KFL1)
16364
16365 IF(ISUBMI.EQ.11) THEN
16366C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
16367 KCC=ICONMI
16368 IF(KFL1*KFL2.LT.0) KCC=KCC+2
16369
16370 ELSEIF(ISUBMI.EQ.12) THEN
16371C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
16372 KFL3=ISIGN(KFLF,KFL1)
16373 KFL4=-KFL3
16374 KCC=4
16375
16376 ELSEIF(ISUBMI.EQ.13) THEN
16377C...f + fbar -> g + g; th arbitrary
16378 KFL3=21
16379 KFL4=21
16380 KCC=ICONMI+4
16381
16382 ELSEIF(ISUBMI.EQ.28) THEN
16383C...f + g -> f + g; th = (p(f)-p(f))**2
16384 IF(KFL1.EQ.21) JS=2
16385 KCC=ICONMI+6
16386 IF(KFL1.EQ.21) KCC=KCC+2
16387 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
16388 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
16389
16390 ELSEIF(ISUBMI.EQ.53) THEN
16391C...g + g -> f + fbar; th arbitrary
16392 KCS=(-1)**INT(1.5D0+PYR(0))
16393 KFL3=ISIGN(KFLF,KCS)
16394 KFL4=-KFL3
16395 KCC=ICONMI+10
16396
16397 ELSEIF(ISUBMI.EQ.68) THEN
16398C...g + g -> g + g; th arbitrary
16399 KCC=ICONMI+12
16400 KCS=(-1)**INT(1.5D0+PYR(0))
16401 ENDIF
16402
16403C...Check that massive sea quarks have non-zero phase space for g -> Q Q
16404 IF (IABS(KFL3).EQ.4.OR.IABS(KFL4).EQ.4.OR.IABS(KFL3).EQ.5
16405 & .OR.IABS(KFL4).EQ.5) THEN
16406 RMMAX2=MAX(PMAS(PYCOMP(KFL3),1),PMAS(PYCOMP(KFL4),1))**2
16407 IF (PT2.LE.1.05*RMMAX2) THEN
16408 IF (NTRY.EQ.2) CALL PYERRM(9,'(PYPTMI:) Heavy quarks'
16409 & //' too close to threshold (2nd try).')
16410 GOTO 210
16411 ENDIF
16412 ENDIF
16413
16414C...Store flavours of scattering.
16415 MINT(13)=KFL1
16416 MINT(14)=KFL2
16417 MINT(15)=KFL1
16418 MINT(16)=KFL2
16419 MINT(21)=KFL3
16420 MINT(22)=KFL4
16421
16422C...Set flavours and mothers of scattering partons.
16423 K(N+1,1)=14
16424 K(N+2,1)=14
16425 K(N+3,1)=3
16426 K(N+4,1)=3
16427 K(N+1,2)=KFL1
16428 K(N+2,2)=KFL2
16429 K(N+3,2)=KFL3
16430 K(N+4,2)=KFL4
16431 K(N+1,3)=MINT(83)+1
16432 K(N+2,3)=MINT(83)+2
16433 K(N+3,3)=N+1
16434 K(N+4,3)=N+2
16435
16436C...Store colour connection indices.
16437 DO 270 J=1,2
16438 JC=J
16439 IF(KCS.EQ.-1) JC=3-J
16440 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
16441 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
16442 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
16443 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
16444 270 CONTINUE
16445
16446C...Store incoming and outgoing partons in their CM-frame.
16447 SHR=SQRT(VINT(21))*VINT(1)
16448 P(N+1,3)=0.5D0*SHR
16449 P(N+1,4)=0.5D0*SHR
16450 P(N+2,3)=-0.5D0*SHR
16451 P(N+2,4)=0.5D0*SHR
16452 P(N+3,5)=PYMASS(K(N+3,2))
16453 P(N+4,5)=PYMASS(K(N+4,2))
16454 IF(P(N+3,5)+P(N+4,5).GE.SHR) THEN
16455 IFAIL=1
16456 RETURN
16457 ENDIF
16458 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
16459 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
16460 P(N+4,4)=SHR-P(N+3,4)
16461 P(N+4,3)=-P(N+3,3)
16462
16463C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
16464 PHI=PARU(2)*PYR(0)
16465 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
16466
16467C...Global statistics.
16468 MINT(351)=MINT(351)+1
16469 VINT(351)=VINT(351)+SQRT(P(N+3,1)**2+P(N+3,2)**2)
16470 IF (MINT(351).EQ.1) VINT(356)=SQRT(P(N+3,1)**2+P(N+3,2)**2)
16471
16472C...Keep track of loose colour ends and information on scattering.
16473 MINT(31)=MINT(31)+1
16474 MINT(36)=MINT(31)
16475 PT2MI(MINT(36))=PT2
16476 IMISEP(MINT(31))=N+4
16477 DO 280 JS=1,2
16478 IMI(JS,MINT(31),1)=N+JS
16479 IMI(JS,MINT(31),2)=0
16480 XMI(JS,MINT(31))=VINT(40+JS)
16481 NMI(JS)=NMI(JS)+1
16482C...Update cumulative counters
16483 VINT(142+JS)=VINT(142+JS)-VINT(40+JS)
16484 VINT(150+JS)=VINT(150+JS)+VINT(40+JS)
16485 280 CONTINUE
16486
16487C...Add to list of final state partons
16488 IPART(NPART+1)=N+3
16489 IPART(NPART+2)=N+4
16490 PTPART(NPART+1)=SQRT(PT2)
16491 PTPART(NPART+2)=SQRT(PT2)
16492 NPART=NPART+2
16493
16494C...Initialize ISR
16495 NISGEN(1,MINT(31))=0
16496 NISGEN(2,MINT(31))=0
16497
16498C...Update ER
16499 N=N+4
16500 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
16501 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
16502 MINT(51)=1
16503 RETURN
16504 ENDIF
16505
16506C...Finally, assign colour tags to new partons
16507 DO 300 JS=1,2
16508 I1=IMI(JS,MINT(31),1)
16509 I2=IMI(3-JS,MINT(31),1)
16510 DO 290 JCS=4,5
16511 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
16512 & GOTO 290
16513 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 290
16514 KCS=JCS
16515 CALL PYCTTR(I1,KCS,I2)
16516 IF(MINT(51).NE.0) RETURN
16517 290 CONTINUE
16518 300 CONTINUE
16519
16520C----------------------------------------------------------------------
16521C...MODE=2: Decide whether quarks in last scattering were valence,
16522C...companion, or sea.
16523 ELSEIF (MODE.EQ.2) THEN
16524 JS=MINT(30)
16525 MI=MINT(36)
16526 PT2=PT2NOW
16527 KFSBM=ISIGN(1,MINT(10+JS))
16528 IFL=K(IMI(JS,MI,1),2)
16529 IMI(JS,MI,2)=0
16530 IF (IABS(IFL).GE.6) THEN
16531 IF (IABS(IFL).EQ.6) THEN
16532 CALL PYERRM(29,'(PYPTMI:) top in initial state!')
16533 ENDIF
16534 RETURN
16535 ENDIF
16536C...Get PDFs at X(rescaled) and PT2 of the current initiator.
16537C...(Do not include the parton itself in the X rescaling.)
16538 X=XMI(JS,MI)
16539 XRSC=X/(VINT(142+JS)+X)
16540C...Note: XPSVC = x*pdf.
16541 MINT(30)=JS
16542C.... ALICE
16543C.... Store side in MINT(124)
16544 MINT(124) = JS
16545 CALL PYPDFU(KFBEAM(JS),XRSC,PT2,XPQ)
16546 SEA=XPSVC(IFL,-1)
16547 VAL=XPSVC(IFL,0)
16548C...Ensure that pdfs are positive definite
16549 IF (SEA.LT.0D0) THEN
16550 CALL PYERRM(9,'(PYPTMI:) Sea distribution negative.')
16551 SEA=MAX(0D0,SEA)
16552 ELSEIF (VAL.LT.0D0) THEN
16553 CALL PYERRM(9,'(PYPTMI:) Val distribution negative.')
16554 VAL=MAX(0D0,VAL)
16555 ENDIF
16556 CMP=0D0
16557 DO 310 IVC=1,NVC(JS,IFL)
16558 CMP=CMP+XPSVC(IFL,IVC)
16559 310 CONTINUE
16560
16561 NTRY=0
16562C...Decide (Extra factor x cancels in the dvision).
16563 320 RVCS=PYR(0)*(SEA+VAL+CMP)
16564 IVNOW=1
16565 NTRY=NTRY+1
16566 330 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
16567C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
16568 IVNOW=0
16569 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
16570 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
16571 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
16572 IF(KFIVAL(JS,1).EQ.0) THEN
16573 IF(KFBEAM(JS).EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
16574 IF(KFBEAM(JS).EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
16575 IF((KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310).AND.
16576 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
16577 ELSE
16578C...Count down valence remaining. Do not count current scattering.
16579 DO 340 I1=1,NMI(JS)
16580 IF (I1.EQ.MINT(36)) GOTO 340
16581 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
16582 & IVNOW=IVNOW-1
16583 340 CONTINUE
16584 ENDIF
16585 IF(IVNOW.EQ.0) GOTO 330
16586C...Mark valence.
16587 IMI(JS,MI,2)=0
16588C...Sets valence content of gamma, pi0, K0S, K0L if not done.
16589 IF(KFIVAL(JS,1).EQ.0) THEN
16590 IF(KFBEAM(JS).EQ.111.OR.KFBEAM(JS).EQ.22) THEN
16591 KFIVAL(JS,1)=IFL
16592 KFIVAL(JS,2)=-IFL
16593 ELSEIF(KFBEAM(JS).EQ.130.OR.KFBEAM(JS).EQ.310) THEN
16594 KFIVAL(JS,1)=IFL
16595 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
16596 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
16597 ENDIF
16598 ENDIF
16599
16600 ELSEIF (RVCS.LE.VAL+SEA) THEN
16601C...If sea, add opposite sign companion parton. Store X and I.
16602 NVC(JS,-IFL)=NVC(JS,-IFL)+1
16603 XASSOC(JS,-IFL,NVC(JS,-IFL))=XMI(JS,MI)
16604C...Set pointer to companion
16605 IMI(JS,MI,2)=-NVC(JS,-IFL)
16606
16607 ELSE
16608C...If companion, check whether we've got any in the books
16609 IF (NVC(JS,IFL).EQ.0) THEN
16610 CMP=0D0
16611C...Only report error first time for this event
16612 IF (NTRY.EQ.1)
16613 & CALL PYERRM(9,'(PYPTMI:) No cmp quark, but pdf != 0!')
16614C...Try a few times
16615 IF (NTRY.LE.10) THEN
16616 GOTO 320
16617C... But if it stil fails, abort this event
16618 ELSE
16619 MINT(51)=1
16620 RETURN
16621 ENDIF
16622 ENDIF
16623C...If several possibilities, decide which one
16624 CMPSUM=VAL+SEA
16625 ISEL=0
16626 350 ISEL=ISEL+1
16627 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
16628 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 350
16629C...Find original sea (anti-)quark. Do not consider current scattering.
16630 IASSOC=0
16631 DO 360 I1=1,NMI(JS)
16632 IF (I1.EQ.MINT(36)) GOTO 360
16633 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 360
16634 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
16635 IMI(JS,MI,2)=IMI(JS,I1,1)
16636 IMI(JS,I1,2)=IMI(JS,MI,1)
16637 ENDIF
16638 360 CONTINUE
16639C...Mark companion "out-kicked".
16640 XASSOC(JS,IFL,ISEL)=-XASSOC(JS,IFL,ISEL)
16641 ENDIF
16642
16643 ENDIF
16644 RETURN
16645 END
16646
16647C*********************************************************************
16648
16649C...PYFCMP: Auxiliary to PYPDFU and PYPTIS.
16650C...Giving the x*f pdf of a companion quark, with its partner at XS,
16651C...using an approximate gluon density like (1-X)^NPOW/X. The value
16652C...corresponds to an unrescaled range between 0 and 1-X.
16653
16654 FUNCTION PYFCMP(XC,XS,NPOW)
16655 IMPLICIT NONE
16656 DOUBLE PRECISION XC, XS, Y, PYFCMP,FAC
16657 INTEGER NPOW
16658
16659 PYFCMP=0D0
16660C...Parent gluon momentum fraction
16661 Y=XC+XS
16662 IF (Y.GE.1D0) RETURN
16663C...Common factor (includes factor XC, since PYFCMP=x*f)
16664 FAC=3D0*XC*XS*(XC**2+XS**2)/(Y**4)
16665C...Store normalized companion x*f distribution.
16666 IF (NPOW.LE.0) THEN
16667 PYFCMP=FAC/(2D0-XS*(3D0-XS*(3D0-2D0*XS)))
16668 ELSEIF (NPOW.EQ.1) THEN
16669 PYFCMP=FAC*(1D0-Y)/(2D0+XS**2*(-3D0+XS)+3D0*XS*LOG(XS))
16670 ELSEIF (NPOW.EQ.2) THEN
16671 PYFCMP=FAC*(1D0-Y)**2/(2D0*((1D0-XS)*(1D0+XS*(4D0+XS))
16672 & +3D0*XS*(1D0+XS)*LOG(XS)))
16673 ELSEIF (NPOW.EQ.3) THEN
16674 PYFCMP=FAC*(1D0-Y)**3*2D0/(4D0+27D0*XS-31D0*XS**3
16675 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16676 ELSEIF (NPOW.GE.4) THEN
16677 PYFCMP=FAC*(1D0-Y)**4/(2D0*(1D0+2D0*XS)*((1D0-XS)*(1D0+
16678 & XS*(10D0+XS))+6D0*XS*LOG(XS)*(1D0+XS)))
16679 ENDIF
16680 RETURN
16681 END
16682
16683C*********************************************************************
16684
16685C...PYPCMP: Auxiliary to PYPDFU.
16686C...Giving the momentum integral of a companion quark, with its
16687C...partner at XS, using an approximate gluon density like (1-x)^NPOW/x.
16688C...The value corresponds to an unrescaled range between 0 and 1-XS.
16689
16690 FUNCTION PYPCMP(XS,NPOW)
16691 IMPLICIT NONE
16692 DOUBLE PRECISION XS, PYPCMP
16693 INTEGER NPOW
16694 IF (XS.GE.1D0.OR.XS.LE.0D0) THEN
16695 PYPCMP=0D0
16696 ELSEIF (NPOW.LE.0) THEN
16697 PYPCMP=XS*(5D0+XS*(-9D0-2D0*XS*(-3D0+XS))+3D0*LOG(XS))
16698 PYPCMP=PYPCMP/((-1D0+XS)*(2D0+XS*(-1D0+2D0*XS)))
16699 ELSEIF (NPOW.EQ.1) THEN
16700 PYPCMP=-1D0-3D0*XS+(2D0*(-1D0+XS)**2*(1D0+XS+XS**2))
16701 & /(2D0+XS**2*(XS-3D0)+3D0*XS*LOG(XS))
16702 ELSEIF (NPOW.EQ.2) THEN
16703 PYPCMP=XS*((1D0-XS)*(19D0+XS*(43D0+4D0*XS))
16704 & +6D0*LOG(XS)*(1D0+6D0*XS+4D0*XS**2))
16705 PYPCMP=PYPCMP/(4D0*((XS-1D0)*(1D0+XS*(4D0+XS))
16706 & -3D0*XS*LOG(XS)*(1+XS)))
16707 ELSEIF (NPOW.EQ.3) THEN
16708 PYPCMP=3D0*XS*((XS-1)*(7D0+XS*(28D0+13D0*XS))
16709 & -2D0*LOG(XS)*(1D0+XS*(9D0+2D0*XS*(6D0+XS))))
16710 PYPCMP=PYPCMP/(4D0+27D0*XS-31D0*XS**3
16711 & +6D0*XS*LOG(XS)*(3D0+2D0*XS*(3D0+XS)))
16712 ELSE
16713 PYPCMP=(-9D0*XS*(XS**2-1D0)*(5D0+XS*(24D0+XS))+12D0*XS*LOG(XS)
16714 & *(1D0+2D0*XS)*(1D0+2D0*XS*(5D0+2D0*XS)))
16715 PYPCMP=PYPCMP/(8D0*(1D0+2D0*XS)*((XS-1D0)*(1D0+XS*(10D0+XS))
16716 & -6D0*XS*LOG(XS)*(1D0+XS)))
16717 ENDIF
16718 RETURN
16719 END
16720
16721C*********************************************************************
16722
16723C...PYUPRE
16724C...Rearranges contents of the HEPEUP commonblock so that
16725C...mothers precede daughters and daughters of a decay are
16726C...listed consecutively.
16727
16728 SUBROUTINE PYUPRE
16729
16730C...Double precision and integer declarations.
16731 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16732 IMPLICIT INTEGER(I-N)
16733
16734C...User process event common block.
16735 INTEGER MAXNUP
16736 PARAMETER (MAXNUP=500)
16737 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
16738 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
16739 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
16740 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
16741 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
16742 SAVE /HEPEUP/
16743
16744C...Local arrays.
16745 DIMENSION NEWPOS(0:MAXNUP),IDUPT(MAXNUP),ISTUPT(MAXNUP),
16746 &MOTUPT(2,MAXNUP),ICOUPT(2,MAXNUP),PUPT(5,MAXNUP),
16747 &VTIUPT(MAXNUP),SPIUPT(MAXNUP)
16748
16749C...Check whether a rearrangement is required.
16750 NEED=0
16751 DO 100 IUP=1,NUP
16752 IF(MOTHUP(1,IUP).GT.IUP) NEED=NEED+1
16753 100 CONTINUE
16754 DO 110 IUP=2,NUP
16755 IF(MOTHUP(1,IUP).LT.MOTHUP(1,IUP-1)) NEED=NEED+1
16756 110 CONTINUE
16757
16758 IF(NEED.NE.0) THEN
16759C...Find the new order that particles should have.
16760 NEWPOS(0)=0
16761 NNEW=0
16762 INEW=-1
16763 120 INEW=INEW+1
16764 DO 130 IUP=1,NUP
16765 IF(MOTHUP(1,IUP).EQ.NEWPOS(INEW)) THEN
16766 NNEW=NNEW+1
16767 NEWPOS(NNEW)=IUP
16768 ENDIF
16769 130 CONTINUE
16770 IF(INEW.LT.NNEW.AND.INEW.LT.NUP) GOTO 120
16771 IF(NNEW.NE.NUP) THEN
16772 CALL PYERRM(2,
16773 & '(PYUPRE:) failed to make sense of mother pointers in HEPEUP')
16774 RETURN
16775 ENDIF
16776
16777C...Copy old info into temporary storage.
16778 DO 150 I=1,NUP
16779 IDUPT(I)=IDUP(I)
16780 ISTUPT(I)=ISTUP(I)
16781 MOTUPT(1,I)=MOTHUP(1,I)
16782 MOTUPT(2,I)=MOTHUP(2,I)
16783 ICOUPT(1,I)=ICOLUP(1,I)
16784 ICOUPT(2,I)=ICOLUP(2,I)
16785 DO 140 J=1,5
16786 PUPT(J,I)=PUP(J,I)
16787 140 CONTINUE
16788 VTIUPT(I)=VTIMUP(I)
16789 SPIUPT(I)=SPINUP(I)
16790 150 CONTINUE
16791
16792C...Copy info back into HEPEUP in right order.
16793 DO 180 I=1,NUP
16794 IOLD=NEWPOS(I)
16795 IDUP(I)=IDUPT(IOLD)
16796 ISTUP(I)=ISTUPT(IOLD)
16797 MOTHUP(1,I)=0
16798 MOTHUP(2,I)=0
16799 DO 160 IMOT=1,I-1
16800 IF(MOTUPT(1,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(1,I)=IMOT
16801 IF(MOTUPT(2,IOLD).EQ.NEWPOS(IMOT)) MOTHUP(2,I)=IMOT
16802 160 CONTINUE
16803 IF(MOTHUP(2,I).GT.0.AND.MOTHUP(2,I).LT.MOTHUP(1,I)) THEN
16804 MOTHSW=MOTHUP(1,I)
16805 MOTHUP(1,I)=MOTHUP(2,I)
16806 MOTHUP(2,I)=MOTHSW
16807 ENDIF
16808 ICOLUP(1,I)=ICOUPT(1,IOLD)
16809 ICOLUP(2,I)=ICOUPT(2,IOLD)
16810 DO 170 J=1,5
16811 PUP(J,I)=PUPT(J,IOLD)
16812 170 CONTINUE
16813 VTIMUP(I)=VTIUPT(IOLD)
16814 SPINUP(I)=SPIUPT(IOLD)
16815 180 CONTINUE
16816 ENDIF
16817
16818c...If incoming particles are massive recalculate to put them massless.
16819 IF(PUP(5,1).NE.0D0.OR.PUP(5,2).NE.0D0) THEN
16820 PPLUS=(PUP(4,1)+PUP(3,1))+(PUP(4,2)+PUP(3,2))
16821 PMINUS=(PUP(4,1)-PUP(3,1))+(PUP(4,2)-PUP(3,2))
16822 PUP(4,1)=0.5D0*PPLUS
16823 PUP(3,1)=PUP(4,1)
16824 PUP(5,1)=0D0
16825 PUP(4,2)=0.5D0*PMINUS
16826 PUP(3,2)=-PUP(4,2)
16827 PUP(5,2)=0D0
16828 ENDIF
16829
16830 RETURN
16831 END
16832
16833C*********************************************************************
16834
16835C...PYADSH
16836C...Administers the generation of successive final-state showers
16837C...in external processes.
16838
16839 SUBROUTINE PYADSH(NFIN)
16840
16841C...Double precision and integer declarations.
16842 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
16843 IMPLICIT INTEGER(I-N)
16844 INTEGER PYK,PYCHGE,PYCOMP
16845C...Parameter statement for maximum size of showers.
16846 PARAMETER (MAXNUR=1000)
16847C...Commonblocks.
16848 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
16849 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
16850 COMMON/PYCTAG/NCT,MCT(4000,2)
16851 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
16852 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
16853 COMMON/PYINT1/MINT(400),VINT(400)
16854 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYPARS/,/PYINT1/
16855C...Local array.
16856 DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)
16857
16858C...Set primary vertex.
16859 DO 100 J=1,5
16860 V(MINT(83)+5,J)=0D0
16861 V(MINT(83)+6,J)=0D0
16862 V(MINT(84)+1,J)=0D0
16863 V(MINT(84)+2,J)=0D0
16864 100 CONTINUE
16865
16866C...Isolate systems of particles with the same mother.
16867 NSYS=0
16868 IMS=-1
16869 DO 140 I=MINT(84)+3,NFIN
16870 IM=K(I,3)
16871 IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
16872 IF(IM.NE.IMS) THEN
16873 NSYS=NSYS+1
16874 IBEG(NSYS)=I
16875 IMS=IM
16876 ENDIF
16877
16878C...Set production vertices.
16879 IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
16880 & THEN
16881 DO 110 J=1,4
16882 V(I,J)=0D0
16883 110 CONTINUE
16884 ELSE
16885 DO 120 J=1,4
16886 V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
16887 120 CONTINUE
16888 ENDIF
16889 IF(MSTP(125).GE.1) THEN
16890 IDOC=I-MSTP(126)+4
16891 DO 130 J=1,5
16892 V(IDOC,J)=V(I,J)
16893 130 CONTINUE
16894 ENDIF
16895 140 CONTINUE
16896
16897C...End loop over systems. Return if no showers to be performed.
16898 IBEG(NSYS+1)=NFIN+1
16899 IF(MSTP(71).LE.0) RETURN
16900
16901C...Loop through systems of particles; check that sensible size.
16902 DO 270 ISYS=1,NSYS
16903 NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
16904 IF(MINT(35).LE.2) THEN
16905 IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
16906 GOTO 270
16907 ELSEIF(NSIZ.LE.1) THEN
16908 CALL PYERRM(2,'(PYADSH:) only one particle in system')
16909 GOTO 270
16910 ELSEIF(NSIZ.GT.80) THEN
16911 CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
16912 GOTO 270
16913 ENDIF
16914 ENDIF
16915
16916C...Save status codes and daughters of showering particles; reset them.
16917 DO 150 J=1,4
16918 PSUM(J)=0D0
16919 150 CONTINUE
16920 DO 170 II=1,NSIZ
16921 I=IBEG(ISYS)-1+II
16922 KSAV(II,1)=K(I,1)
16923 IF(K(I,1).GT.10) THEN
16924 K(I,1)=1
16925 IF(KSAV(II,1).EQ.14) K(I,1)=3
16926 ENDIF
16927 IF(KSAV(II,1).LE.10) THEN
16928 ELSEIF(K(I,1).EQ.1) THEN
16929 KSAV(II,4)=K(I,4)
16930 KSAV(II,5)=K(I,5)
16931 K(I,4)=0
16932 K(I,5)=0
16933 ELSE
16934 KSAV(II,4)=MOD(K(I,4),MSTU(5))
16935 KSAV(II,5)=MOD(K(I,5),MSTU(5))
16936 K(I,4)=K(I,4)-KSAV(II,4)
16937 K(I,5)=K(I,5)-KSAV(II,5)
16938 ENDIF
16939 DO 160 J=1,4
16940 PSUM(J)=PSUM(J)+P(I,J)
16941 160 CONTINUE
16942 170 CONTINUE
16943
16944C...Perform shower.
16945 QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
16946 & PSUM(3)**2))
16947 IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
16948 NSAV=N
16949 IF(MINT(35).LE.2) THEN
16950 IF(NSIZ.EQ.2) THEN
16951 CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
16952 ELSE
16953 CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
16954 ENDIF
16955
16956C...For external processes, first call, also ISR partons radiate.
16957C...Can use existing PYPART list, removing partons that radiate later.
16958 ELSEIF(ISYS.EQ.1) THEN
16959 NPARTN=0
16960 DO 175 II=1,NPART
16961 IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
16962 NPARTN=NPARTN+1
16963 IPART(NPARTN)=IPART(II)
16964 PTPART(NPARTN)=PTPART(II)
16965 ENDIF
16966 175 CONTINUE
16967 NPART=NPARTN
16968 CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
16969 ELSE
16970C...For subsequent calls use the systems excluded above.
16971 NPART=NSIZ
16972 NPARTD=0
16973 DO 180 II=1,NSIZ
16974 I=IBEG(ISYS)-1+II
16975 IPART(II)=I
16976 PTPART(II)=0.5D0*QMAX
16977 180 CONTINUE
16978 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
16979 ENDIF
16980
16981C...Look up showered copies of original showering particles.
16982 DO 260 II=1,NSIZ
16983 I=IBEG(ISYS)-1+II
16984 IMV=I
16985C...Particles without daughters need not be studied.
16986 IF(KSAV(II,1).LE.10) GOTO 260
16987 IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
16988 ELSEIF(K(I,1).EQ.11) THEN
16989 190 IMV=MOD(K(IMV,4),MSTU(5))
16990 IF(K(IMV,1).EQ.11) GOTO 190
16991 ELSE
16992 KDA1=MOD(K(I,4),MSTU(5))
16993 IF(KDA1.GT.0) THEN
16994 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
16995 ENDIF
16996 KDA2=MOD(K(I,5),MSTU(5))
16997 IF(KDA2.GT.0) THEN
16998 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
16999 ENDIF
17000 DO 200 I3=I+1,N
17001 IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
17002 & THEN
17003 IMV=I3
17004 KDA1=MOD(K(I3,4),MSTU(5))
17005 IF(KDA1.GT.0) THEN
17006 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17007 ENDIF
17008 KDA2=MOD(K(I3,5),MSTU(5))
17009 IF(KDA2.GT.0) THEN
17010 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17011 ENDIF
17012 ENDIF
17013 200 CONTINUE
17014 ENDIF
17015
17016C...Restore daughter info of original partons to showered copies.
17017 IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
17018 IF(KSAV(II,1).LE.10) THEN
17019 ELSEIF(K(I,1).EQ.1) THEN
17020 K(IMV,4)=KSAV(II,4)
17021 K(IMV,5)=KSAV(II,5)
17022 ELSE
17023 K(IMV,4)=K(IMV,4)+KSAV(II,4)
17024 K(IMV,5)=K(IMV,5)+KSAV(II,5)
17025 ENDIF
17026
17027C...Reset mother info of existing daughters to showered copies.
17028 DO 210 I3=IBEG(ISYS+1),NFIN
17029 IF(K(I3,3).EQ.I) K(I3,3)=IMV
17030 IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
17031 IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
17032 IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
17033 ENDIF
17034 210 CONTINUE
17035
17036C...Boost all original daughters to new frame of showered copy.
17037C...Also update their colour tags.
17038 IF(IMV.NE.I) THEN
17039 DO 220 J=1,3
17040 BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
17041 220 CONTINUE
17042 FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
17043 DO 230 J=1,3
17044 BETA(J)=FAC*BETA(J)
17045 230 CONTINUE
17046 DO 250 I3=IBEG(ISYS+1),NFIN
17047 IMO=I3
17048 240 IMO=K(IMO,3)
17049 IF(MSTP(128).LE.0) THEN
17050 IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
17051 IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
17052 & THEN
17053 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
17054 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
17055 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
17056 ENDIF
17057 ELSE
17058 IF(IMO.EQ.IMV) THEN
17059 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
17060 IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
17061 IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
17062 ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
17063 GOTO 240
17064 ENDIF
17065 ENDIF
17066 250 CONTINUE
17067 ENDIF
17068 260 CONTINUE
17069
17070C...End of loop over showering systems
17071 270 CONTINUE
17072
17073 RETURN
17074 END
17075
17076C*********************************************************************
17077
17078C...PYVETO
17079C...Interface to UPVETO, which allows user to veto event generation
17080C...on the parton level, after parton showers but before multiple
17081C...interactions, beam remnants and hadronization is added.
17082
17083 SUBROUTINE PYVETO(IVETO)
17084
17085C...All real arithmetic in double precision.
17086 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17087C...Three Pythia functions return integers, so need declaring.
17088 INTEGER PYK,PYCHGE,PYCOMP
17089
17090C...PYTHIA commonblocks.
17091 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
17092 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17093 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17094 COMMON/PYINT1/MINT(400),VINT(400)
17095 SAVE /PYJETS/,/PYPARS/,/PYINT1/
17096C...HEPEVT commonblock.
17097 PARAMETER (NMXHEP=4000)
17098 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
17099 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
17100 DOUBLE PRECISION PHEP,VHEP
17101 SAVE /HEPEVT/
17102C...Local array.
17103 DIMENSION IRESO(100)
17104
17105C...Define longitudinal boost from initiator rest frame to cm frame.
17106 GAMMA=0.5D0*(VINT(141)+VINT(142))/SQRT(VINT(141)*VINT(142))
17107 GABEZ=0.5D0*(VINT(141)-VINT(142))/SQRT(VINT(141)*VINT(142))
17108
17109C...Presentation is different if using pT-ordered shower
17110 IF(MINT(35).EQ.3) THEN
17111 GAMMA=1D0
17112 GABEZ=0D0
17113 ENDIF
17114
17115C... Reset counters.
17116 NEVHEP=0
17117 NHEP=0
17118 NRESO=0
17119
17120C...Oth pass: identify beam and incoming partons
17121 DO 140 I=MINT(83)+1,MINT(83)+6
17122 ISTORE=0
17123 IF(K(I,2).EQ.94) THEN
17124
17125 ELSE
17126 NRESO=NRESO+1
17127 IRESO(NRESO)=I
17128 IMOTH=K(I,3)
17129 ENDIF
17130 140 CONTINUE
17131
17132C...First pass: identify final locations of resonances
17133C...and of their daughters before showering.
17134 DO 150 I=MINT(84)+3,N
17135 ISTORE=0
17136 IMOTH=0
17137
17138C...Skip shower CM frame documentation lines.
17139 IF(K(I,2).EQ.94) THEN
17140
17141C... Store a new intermediate product, when mother in documentation.
17142 ELSEIF(MSTP(128).EQ.0.AND.K(I,3).GT.MINT(83)+6.AND.
17143 & K(I,3).LE.MINT(84)) THEN
17144 ISTORE=1
17145 NHEP=NHEP+1
17146 II=NHEP
17147 NRESO=NRESO+1
17148 IRESO(NRESO)=I
17149 IMOTH=MAX(0,K(K(I,3),3)-(MINT(83)+6))
17150
17151C... Store a new intermediate product, when mother in main section.
17152 ELSEIF(MSTP(128).EQ.1.AND.K(I-MINT(84)+MINT(83)+4,1).EQ.21.AND.
17153 & K(I-MINT(84)+MINT(83)+4,2).EQ.K(I,2)) THEN
17154 ISTORE=1
17155 NHEP=NHEP+1
17156 II=NHEP
17157 NRESO=NRESO+1
17158 IRESO(NRESO)=I
17159 IMOTH=MAX(0,K(I-MINT(84)+MINT(83)+4,3)-(MINT(83)+6))
17160 ENDIF
17161
17162 IF(ISTORE.EQ.1) THEN
17163C...Copy parton info, boosting momenta along z axis to cm frame.
17164 ISTHEP(II)=2
17165 IDHEP(II)=K(I,2)
17166 PHEP(1,II)=P(I,1)
17167 PHEP(2,II)=P(I,2)
17168 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
17169 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
17170 PHEP(5,II)=P(I,5)
17171C...Store one mother. Rest of history and vertex info zeroed.
17172 JMOHEP(1,II)=IMOTH
17173 JMOHEP(2,II)=0
17174 JDAHEP(1,II)=0
17175 JDAHEP(2,II)=0
17176 VHEP(1,II)=0D0
17177 VHEP(2,II)=0D0
17178 VHEP(3,II)=0D0
17179 VHEP(4,II)=0D0
17180 ENDIF
17181 150 CONTINUE
17182
17183C...Second pass: identify current set of "final" partons.
17184 DO 200 I=MINT(84)+3,N
17185 ISTORE=0
17186 IMOTH=0
17187
17188C...Store a final parton.
17189 IF(K(I,1).GE.1.AND.K(I,1).LE.10) THEN
17190 ISTORE=1
17191 NHEP=NHEP+1
17192 II=NHEP
17193C..Trace it back through shower, to check if from documented particle.
17194 IHIST=I
17195 ISAVE=IHIST
17196 160 CONTINUE
17197 IF(IHIST.GT.MINT(84)) THEN
17198 IF(K(IHIST,2).EQ.94) IHIST=K(IHIST,3)+(ISAVE-1-IHIST)
17199 DO 170 IRI=1,NRESO
17200 IF(IHIST.EQ.IRESO(IRI)) IMOTH=IRI
17201 170 CONTINUE
17202 ISAVE=IHIST
17203 IHIST=K(IHIST,3)
17204 IF(IMOTH.EQ.0) GOTO 160
17205 IMOTH=MAX(0,IMOTH-6)
17206 ELSEIF(IHIST.LE.4) THEN
17207 IF(IHIST.EQ.1.OR.IHIST.EQ.2) THEN
17208 ISTORE=0
17209 NHEP=NHEP-1
17210 ELSE
17211 IMOTH=0
17212 ENDIF
17213 ENDIF
17214 ENDIF
17215
17216 IF(ISTORE.EQ.1) THEN
17217C...Copy parton info, boosting momenta along z axis to cm frame.
17218 ISTHEP(II)=1
17219 IDHEP(II)=K(I,2)
17220 PHEP(1,II)=P(I,1)
17221 PHEP(2,II)=P(I,2)
17222 PHEP(3,II)=GAMMA*P(I,3)+GABEZ*P(I,4)
17223 PHEP(4,II)=GAMMA*P(I,4)+GABEZ*P(I,3)
17224 PHEP(5,II)=P(I,5)
17225C...Store one mother. Rest of history and vertex info zeroed.
17226 JMOHEP(1,II)=IMOTH
17227 JMOHEP(2,II)=0
17228 JDAHEP(1,II)=0
17229 JDAHEP(2,II)=0
17230 VHEP(1,II)=0D0
17231 VHEP(2,II)=0D0
17232 VHEP(3,II)=0D0
17233 VHEP(4,II)=0D0
17234 ENDIF
17235 200 CONTINUE
17236C...Call user-written routine to decide whether to keep events.
17237 CALL UPVETO(IVETO)
17238 RETURN
17239 END
17240C*********************************************************************
17241
17242C...PYRESD
17243C...Allows resonances to decay (including parton showers for hadronic
17244C...channels).
17245
17246 SUBROUTINE PYRESD(IRES)
17247
17248C...Double precision and integer declarations.
17249 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
17250 IMPLICIT INTEGER(I-N)
17251 INTEGER PYK,PYCHGE,PYCOMP
17252C...Parameter statement to help give large particle numbers.
17253 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
17254 &KEXCIT=4000000,KDIMEN=5000000)
17255C...Parameter statement for maximum size of showers.
17256 PARAMETER (MAXNUR=1000)
17257C...Commonblocks.
17258 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
17259 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
17260 COMMON/PYCTAG/NCT,MCT(4000,2)
17261 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
17262 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
17263 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
17264 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
17265 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
17266 COMMON/PYINT1/MINT(400),VINT(400)
17267 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
17268 COMMON/PYINT4/MWID(500),WIDS(500,5)
17269 COMMON/PYPUED/IUED(0:99),RUED(0:99)
17270 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYDAT3/,
17271 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT4/,/PYPUED/
17272C...Local arrays and complex and character variables.
17273 DIMENSION IREF(50,8),KDCY(3),KFL1(3),KFL2(3),KFL3(3),KEQL(3),
17274 &KCQM(3),KCQ1(3),KCQ2(3),KCQ3(3),NSD(3),PMMN(4),ILIN(6),
17275 &HGZ(3,3),COUP(6,4),CORL(2,2,2),PK(6,4),PKK(6,6),CTHE(3),
17276 &PHI(3),WDTP(0:400),WDTE(0:400,0:5),DPMO(5),VDCY(4),
17277 &ITJUNC(3),CTM2(3),KCQ(0:10),IANT(4),ITRI(4),IOCT(4),KCQ4(3),
17278 &KFL4(3)
17279 COMPLEX FGK,HA(6,6),HC(6,6)
17280 REAL TIR,UIR
17281 CHARACTER CODE*9,MASS*9
17282C...Local arrays.
17283 DIMENSION PV(10,5),RORD(10),UE(3),BE(3),WTCOR(10)
17284 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
17285
17286C...Functions: momentum in two-particle decays and four-product.
17287 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
17288
17289C...The F, Xi and Xj functions of Gunion and Kunszt
17290C...(Phys. Rev. D33, 665, plus errata from the authors).
17291 FGK(I1,I2,I3,I4,I5,I6)=4.*HA(I1,I3)*HC(I2,I6)*(HA(I1,I5)*
17292 &HC(I1,I4)+HA(I3,I5)*HC(I3,I4))
17293 DIGK(DT,DU)=-4D0*D34*D56+DT*(3D0*DT+4D0*DU)+DT**2*(DT*DU/
17294 &(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+2D0*(D34/D56+D56/D34))
17295 DJGK(DT,DU)=8D0*(D34+D56)**2-8D0*(D34+D56)*(DT+DU)-6D0*DT*DU-
17296 &2D0*DT*DU*(DT*DU/(D34*D56)-2D0*(1D0/D34+1D0/D56)*(DT+DU)+
17297 &2D0*(D34/D56+D56/D34))
17298
17299C...Some general constants.
17300 XW=PARU(102)
17301 XWV=XW
17302 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
17303 XW1=1D0-XW
17304 SQMZ=PMAS(23,1)**2
17305
17306 GMMZ=PMAS(23,1)*PMAS(23,2)
17307 SQMW=PMAS(24,1)**2
17308 GMMW=PMAS(24,1)*PMAS(24,2)
17309 SH=VINT(44)
17310
17311C...Boost and rotate to rest frame of incoming partons,
17312C...to get proper amount of smearing of decay angles.
17313 IBST=0
17314 IF(IRES.EQ.0) THEN
17315 IBST=1
17316 IIN1=MINT(84)+1
17317 IIN2=MINT(84)+2
17318C...Bug fix 09 OCT 2008 (PS) at 6.4.18: in new shower, the incoming partons
17319C...(101,102) are off shell and can have inconsistent momenta, resulting
17320C...in boosts larger than unity. However, the corresponding docu partons
17321C...(5,6) are kept on shell, and have consistent momenta that can be used
17322C...to derive this boost instead. Ultimately, should change the way the new
17323C...shower stores intermediate partons, but just using partons (5,6) for now
17324C...does define the boost and furnishes a quick and much needed solution.
17325 IF (MINT(35).EQ.3) THEN
17326 IIN1=MINT(83)+5
17327 IIN2=MINT(83)+6
17328 ENDIF
17329 ETOTIN=P(IIN1,4)+P(IIN2,4)
17330 BEXIN=(P(IIN1,1)+P(IIN2,1))/ETOTIN
17331 BEYIN=(P(IIN1,2)+P(IIN2,2))/ETOTIN
17332 BEZIN=(P(IIN1,3)+P(IIN2,3))/ETOTIN
17333 CALL PYROBO(MINT(83)+7,N,0D0,0D0,-BEXIN,-BEYIN,-BEZIN)
17334 PHIIN=PYANGL(P(MINT(84)+1,1),P(MINT(84)+1,2))
17335 CALL PYROBO(MINT(83)+7,N,0D0,-PHIIN,0D0,0D0,0D0)
17336 THEIN=PYANGL(P(MINT(84)+1,3),P(MINT(84)+1,1))
17337 CALL PYROBO(MINT(83)+7,N,-THEIN,0D0,0D0,0D0,0D0)
17338 ENDIF
17339
17340C...Reset original resonance configuration.
17341 DO 100 JT=1,8
17342 IREF(1,JT)=0
17343 100 CONTINUE
17344
17345C...Define initial one, two or three objects for subprocess.
17346 IHDEC=0
17347 IF(IRES.EQ.0) THEN
17348 ISUB=MINT(1)
17349 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
17350 IREF(1,1)=MINT(84)+2+ISET(ISUB)
17351 IREF(1,4)=MINT(83)+6+ISET(ISUB)
17352 JTMAX=1
17353 ELSEIF(ISET(ISUB).EQ.2.OR.ISET(ISUB).EQ.4) THEN
17354 IREF(1,1)=MINT(84)+1+ISET(ISUB)
17355 IREF(1,2)=MINT(84)+2+ISET(ISUB)
17356 IREF(1,4)=MINT(83)+5+ISET(ISUB)
17357 IREF(1,5)=MINT(83)+6+ISET(ISUB)
17358 JTMAX=2
17359 ELSEIF(ISET(ISUB).EQ.5) THEN
17360 IREF(1,1)=MINT(84)+3
17361 IREF(1,2)=MINT(84)+4
17362 IREF(1,3)=MINT(84)+5
17363 IREF(1,4)=MINT(83)+7
17364 IREF(1,5)=MINT(83)+8
17365 IREF(1,6)=MINT(83)+9
17366 JTMAX=3
17367 ENDIF
17368
17369C...Define original resonance for odd cases.
17370 ELSE
17371 ISUB=0
17372 IF(K(IRES,2).EQ.25.OR.K(IRES,2).EQ.35.OR.K(IRES,2).EQ.36)
17373 & IHDEC=1
17374 IF(IHDEC.EQ.1) ISUB=3
17375 IREF(1,1)=IRES
17376 IREF(1,4)=K(IRES,3)
17377 IRESTM=IRES
17378 IF(IREF(1,4).GT.MINT(84)) THEN
17379 110 ITMPMO=IREF(1,4)
17380 IF(K(ITMPMO,2).EQ.94) THEN
17381 IREF(1,4)=K(ITMPMO,3)+(IRESTM-ITMPMO-1)
17382 IF(K(IREF(1,4),3).LE.MINT(84)) IREF(1,4)=K(IREF(1,4),3)
17383 ELSEIF(K(ITMPMO,2).EQ.K(IRES,2)) THEN
17384 IRESTM=ITMPMO
17385C...Explicitly check that reference particle exists, otherwise stop recursion
17386 IF(ITMPMO.GT.0.AND.K(ITMPMO,3).GT.0) THEN
17387 IREF(1,4)=K(ITMPMO,3)
17388 GOTO 110
17389 ENDIF
17390 ENDIF
17391 ENDIF
17392 IF(IREF(1,4).GT.MINT(84)) THEN
17393 EMATCH=1D10
17394 IREF14=IREF(1,4)
17395 DO 120 II=MINT(83)+7,MINT(83)+MINT(4)
17396 IF(K(II,2).EQ.K(IRES,2).AND.ABS(P(II,4)-P(IREF14,4)).LT.
17397 & EMATCH) THEN
17398 IREF(1,4)=II
17399 EMATCH=ABS(P(II,4)-P(IREF14,4))
17400 ENDIF
17401 120 CONTINUE
17402 ENDIF
17403 JTMAX=1
17404 ENDIF
17405
17406C...Check if initial resonance has been moved (in resonance + jet).
17407 DO 140 JT=1,3
17408 IF(IREF(1,JT).GT.0) THEN
17409 IF(K(IREF(1,JT),1).GT.10) THEN
17410 KFA=IABS(K(IREF(1,JT),2))
17411 IF(KFA.GE.6.AND.KCHG(PYCOMP(KFA),2).NE.0) THEN
17412 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17413 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17414 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17415 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17416 ENDIF
17417 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17418 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17419 ENDIF
17420 DO 130 I=IREF(1,JT)+1,N
17421 IF(K(I,2).EQ.K(IREF(1,JT),2).AND.(I.EQ.KDA1.OR.
17422 & I.EQ.KDA2)) THEN
17423 IREF(1,JT)=I
17424 KDA1=MOD(K(IREF(1,JT),4),MSTU(5))
17425 KDA2=MOD(K(IREF(1,JT),5),MSTU(5))
17426 IF(KDA1.GT.IREF(1,JT).AND.KDA1.LE.N) THEN
17427 IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
17428 ENDIF
17429 IF(KDA2.GT.IREF(1,JT).AND.KDA2.LE.N) THEN
17430 IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
17431 ENDIF
17432 ENDIF
17433 130 CONTINUE
17434 ELSE
17435 KDA=MOD(K(IREF(1,JT),4),MSTU(5))
17436 IF(MWID(PYCOMP(KFA)).NE.0.AND.KDA.GT.1) IREF(1,JT)=KDA
17437 ENDIF
17438 ENDIF
17439 ENDIF
17440 140 CONTINUE
17441
17442C...Set decay vertex for initial resonances
17443 DO 160 JT=1,JTMAX
17444 DO 150 I=1,4
17445 V(IREF(1,JT),I)=0D0
17446 150 CONTINUE
17447 160 CONTINUE
17448
17449C...Loop over decay history.
17450 NP=1
17451 IP=0
17452 170 IP=IP+1
17453 NINH=0
17454 JTMAX=2
17455 IF(IREF(IP,2).EQ.0) JTMAX=1
17456 IF(IREF(IP,3).NE.0) JTMAX=3
17457 IT4=0
17458 NSAV=N
17459
17460C...Check for Higgs which appears as decay product of user-process.
17461 IF(ISUB.EQ.0) THEN
17462 IHDEC=0
17463 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
17464 & .EQ.36) IHDEC=1
17465 IF(IHDEC.EQ.1) ISUB=3
17466 ENDIF
17467
17468C...Start treatment of one, two or three resonances in parallel.
17469 180 N=NSAV
17470 DO 340 JT=1,JTMAX
17471 ID=IREF(IP,JT)
17472 KDCY(JT)=0
17473 KFL1(JT)=0
17474 KFL2(JT)=0
17475 KFL3(JT)=0
17476 KFL4(JT)=0
17477 KEQL(JT)=0
17478 NSD(JT)=ID
17479 ITJUNC(JT)=0
17480
17481C...Check whether particle can/is allowed to decay.
17482 IF(ID.EQ.0) GOTO 330
17483 KFA=IABS(K(ID,2))
17484 KCA=PYCOMP(KFA)
17485 IF(MWID(KCA).EQ.0) GOTO 330
17486 IF(K(ID,1).GT.10.OR.MDCY(KCA,1).EQ.0) GOTO 330
17487 IF(KFA.EQ.6.OR.KFA.EQ.7.OR.KFA.EQ.8.OR.KFA.EQ.17.OR.
17488 & KFA.EQ.18) IT4=IT4+1
17489 K(ID,4)=MSTU(5)*(K(ID,4)/MSTU(5))
17490 K(ID,5)=MSTU(5)*(K(ID,5)/MSTU(5))
17491
17492C...Choose lifetime and determine decay vertex.
17493 IF(K(ID,1).EQ.5) THEN
17494 V(ID,5)=0D0
17495 ELSEIF(K(ID,1).NE.4) THEN
17496 V(ID,5)=-PMAS(KCA,4)*LOG(PYR(0))
17497 ENDIF
17498 DO 190 J=1,4
17499 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
17500 190 CONTINUE
17501
17502C...Determine whether decay allowed or not.
17503 MOUT=0
17504 IF(MSTJ(22).EQ.2) THEN
17505 IF(PMAS(KCA,4).GT.PARJ(71)) MOUT=1
17506 ELSEIF(MSTJ(22).EQ.3) THEN
17507 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
17508 ELSEIF(MSTJ(22).EQ.4) THEN
17509 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
17510 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
17511 ENDIF
17512 IF(MOUT.EQ.1.AND.K(ID,1).NE.5) THEN
17513 K(ID,1)=4
17514 GOTO 330
17515 ENDIF
17516
17517C...Info for selection of decay channel: sign, pairings.
17518 IF(KCHG(KCA,3).EQ.0) THEN
17519 IPM=2
17520 ELSE
17521 IPM=(5-ISIGN(1,K(ID,2)))/2
17522 ENDIF
17523 KFB=0
17524 IF(JTMAX.EQ.2) THEN
17525 KFB=IABS(K(IREF(IP,3-JT),2))
17526 ELSEIF(JTMAX.EQ.3) THEN
17527 JT2=JT+1-3*(JT/3)
17528 KFB=IABS(K(IREF(IP,JT2),2))
17529 IF(KFB.NE.KFA) THEN
17530 JT2=JT+2-3*((JT+1)/3)
17531 KFB=IABS(K(IREF(IP,JT2),2))
17532 ENDIF
17533 ENDIF
17534
17535C...Select decay channel.
17536 IF(ISUB.EQ.1.OR.ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.
17537 & ISUB.EQ.30.OR.ISUB.EQ.35.OR.ISUB.EQ.141) MINT(61)=1
17538 CALL PYWIDT(KFA,P(ID,5)**2,WDTP,WDTE)
17539 WDTE0S=WDTE(0,1)+WDTE(0,IPM)+WDTE(0,4)
17540 IF(KFB.EQ.KFA) WDTE0S=WDTE0S+WDTE(0,5)
17541 IF(WDTE0S.LE.0D0) GOTO 330
17542 RKFL=WDTE0S*PYR(0)
17543 IDL=0
17544 200 IDL=IDL+1
17545 IDC=IDL+MDCY(KCA,2)-1
17546 RKFL=RKFL-(WDTE(IDL,1)+WDTE(IDL,IPM)+WDTE(IDL,4))
17547 IF(KFB.EQ.KFA) RKFL=RKFL-WDTE(IDL,5)
17548 IF(IDL.LT.MDCY(KCA,3).AND.RKFL.GT.0D0) GOTO 200
17549
17550 NPROD=0
17551C...Read out flavours and colour charges of decay channel chosen.
17552 KCQM(JT)=KCHG(KCA,2)*ISIGN(1,K(ID,2))
17553 IF(KCQM(JT).EQ.-2) KCQM(JT)=2
17554 KFL1(JT)=KFDP(IDC,1)*ISIGN(1,K(ID,2))
17555 KFC1A=PYCOMP(IABS(KFL1(JT)))
17556 IF(KCHG(KFC1A,3).EQ.0) KFL1(JT)=IABS(KFL1(JT))
17557 NPROD=NPROD+1
17558 KCQ1(JT)=KCHG(KFC1A,2)*ISIGN(1,KFL1(JT))
17559 IF(KCQ1(JT).EQ.-2) KCQ1(JT)=2
17560 KFL2(JT)=KFDP(IDC,2)*ISIGN(1,K(ID,2))
17561 KFC2A=PYCOMP(IABS(KFL2(JT)))
17562 IF(KCHG(KFC2A,3).EQ.0) KFL2(JT)=IABS(KFL2(JT))
17563 KCQ2(JT)=KCHG(KFC2A,2)*ISIGN(1,KFL2(JT))
17564 IF(KCQ2(JT).EQ.-2) KCQ2(JT)=2
17565 NPROD=NPROD+1
17566 KFL3(JT)=KFDP(IDC,3)*ISIGN(1,K(ID,2))
17567 KCQ3(JT)=0
17568 KFL4(JT)=KFDP(IDC,4)*ISIGN(1,K(ID,2))
17569 KCQ4(JT)=0
17570 IF(KFL3(JT).NE.0) THEN
17571 KFC3A=PYCOMP(IABS(KFL3(JT)))
17572 IF(KCHG(KFC3A,3).EQ.0) KFL3(JT)=IABS(KFL3(JT))
17573 KCQ3(JT)=KCHG(KFC3A,2)*ISIGN(1,KFL3(JT))
17574 IF(KCQ3(JT).EQ.-2) KCQ3(JT)=2
17575 NPROD=NPROD+1
17576 IF(KFL4(JT).NE.0) THEN
17577 KFC4A=PYCOMP(IABS(KFL4(JT)))
17578 IF(KCHG(KFC4A,3).EQ.0) KFL4(JT)=IABS(KFL4(JT))
17579 KCQ4(JT)=KCHG(KFC4A,2)*ISIGN(1,KFL4(JT))
17580 IF(KCQ4(JT).EQ.-2) KCQ4(JT)=2
17581 NPROD=NPROD+1
17582 ENDIF
17583 ENDIF
17584
17585C...Set/save further info on channel.
17586 KDCY(JT)=1
17587 IF(KFB.EQ.KFA) KEQL(JT)=MDME(IDC,1)
17588 NSD(JT)=N
17589 HGZ(JT,1)=VINT(111)
17590 HGZ(JT,2)=VINT(112)
17591 HGZ(JT,3)=VINT(114)
17592 JTZ=JT
17593
17594 PXSUM=0D0
17595C...Select masses; to begin with assume resonances narrow.
17596 DO 220 I=1,4
17597 P(N+I,5)=0D0
17598 PMMN(I)=0D0
17599 IF(I.EQ.1) THEN
17600 KFLW=IABS(KFL1(JT))
17601 KCW=KFC1A
17602 ELSEIF(I.EQ.2) THEN
17603 KFLW=IABS(KFL2(JT))
17604 KCW=KFC2A
17605 ELSEIF(I.EQ.3) THEN
17606 IF(KFL3(JT).EQ.0) GOTO 220
17607 KFLW=IABS(KFL3(JT))
17608 KCW=KFC3A
17609 ELSEIF(I.EQ.4) THEN
17610 IF(KFL4(JT).EQ.0) GOTO 220
17611 KFLW=IABS(KFL4(JT))
17612 KCW=KFC4A
17613 ENDIF
17614 P(N+I,5)=PMAS(KCW,1)
17615 PXSUM=PXSUM+P(N+I,5)
17616CMRENNA++
17617C...This prevents SUSY/t particles from becoming too light.
17618 IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
17619 PMMN(I)=PMAS(KCW,1)
17620 DO 210 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
17621 IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
17622 PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
17623 & PMAS(PYCOMP(KFDP(IDC,2)),1)
17624 IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
17625 & PMAS(PYCOMP(KFDP(IDC,3)),1)
17626 IF(KFDP(IDC,4).NE.0) PMSUM=PMSUM+
17627 & PMAS(PYCOMP(KFDP(IDC,4)),1)
17628 PMMN(I)=MIN(PMMN(I),PMSUM)
17629 ENDIF
17630 210 CONTINUE
17631C MRENNA--
17632 ELSEIF(KFLW.EQ.6) THEN
17633 PMMN(I)=PMAS(24,1)+PMAS(5,1)
17634 ENDIF
17635C...UED: select a graviton mass from continuous distribution
17636C...(stored in PMAS(39,1) so no value returned)
17637 IF (IUED(1).EQ.1.AND.IUED(2).EQ.1.AND.KFLW.EQ.39)
17638 & CALL PYGRAM(1)
17639 220 CONTINUE
17640
17641C...Check which two out of three are widest.
17642 IWID1=1
17643 IWID2=2
17644 PWID1=PMAS(KFC1A,2)
17645 PWID2=PMAS(KFC2A,2)
17646 KFLW1=IABS(KFL1(JT))
17647 KFLW2=IABS(KFL2(JT))
17648 IF(KFL3(JT).NE.0) THEN
17649 PWID3=PMAS(KFC3A,2)
17650 IF(PWID3.GT.PWID1.AND.PWID2.GE.PWID1) THEN
17651 IWID1=3
17652 PWID1=PWID3
17653 KFLW1=IABS(KFL3(JT))
17654 ELSEIF(PWID3.GT.PWID2) THEN
17655 IWID2=3
17656 PWID2=PWID3
17657 KFLW2=IABS(KFL3(JT))
17658 ENDIF
17659 ENDIF
17660 IF(KFL4(JT).NE.0) THEN
17661 PWID4=PMAS(KFC4A,2)
17662 IF(PWID4.GT.PWID1.AND.PWID2.GE.PWID1) THEN
17663 IWID1=4
17664 PWID1=PWID4
17665 KFLW1=IABS(KFL4(JT))
17666 ELSEIF(PWID4.GT.PWID2) THEN
17667 IWID2=4
17668 PWID2=PWID4
17669 KFLW2=IABS(KFL4(JT))
17670 ENDIF
17671 ENDIF
17672
17673C...If all narrow then only check that masses consistent.
17674 IF(MSTP(42).LE.0.OR.(PWID1.LT.PARP(41).AND.
17675 & PWID2.LT.PARP(41))) THEN
17676CMRENNA++
17677C....Handle near degeneracy cases.
17678 IF(KFA/KSUSY1.EQ.1.OR.KFA/KSUSY1.EQ.2) THEN
17679 IF(P(N+1,5)+P(N+2,5)+P(N+3,5).GT.P(ID,5)) THEN
17680 P(N+1,5)=P(ID,5)-P(N+2,5)-0.5D0
17681 IF(P(N+1,5).LT.0D0) P(N+1,5)=0D0
17682 ENDIF
17683 ENDIF
17684CMRENNA--
17685 IF(PXSUM.GT.P(ID,5)) THEN
17686 CALL PYERRM(13,'(PYRESD:) daughter masses too large')
17687 MINT(51)=1
17688 GOTO 720
17689 ELSEIF(PXSUM+PARJ(64).GT.P(ID,5)) THEN
17690 CALL PYERRM(3,'(PYRESD:) masses+PARJ(64) too large')
17691 MINT(51)=1
17692 GOTO 720
17693 ENDIF
17694
17695C...For three wide resonances select narrower of three
17696C...according to BW decoupled from rest.
17697 ELSE
17698 PMTOT=P(ID,5)
17699 IF(KFL3(JT).NE.0) THEN
17700 IWID3=6-IWID1-IWID2
17701 KFLW3=IABS(KFL1(JT))+IABS(KFL2(JT))+IABS(KFL3(JT))-
17702 & KFLW1-KFLW2
17703 LOOP=0
17704 230 LOOP=LOOP+1
17705 P(N+IWID3,5)=PYMASS(KFLW3)
17706 IF(LOOP.LE.10.AND. P(N+IWID3,5).LE.PMMN(IWID3)) GOTO 230
17707 PMTOT=PMTOT-P(N+IWID3,5)
17708 ENDIF
17709C...Select other two correlated within remaining phase space.
17710 IF(IP.EQ.1) THEN
17711 CKIN45=CKIN(45)
17712 CKIN47=CKIN(47)
17713 CKIN(45)=MAX(PMMN(IWID1),CKIN(45))
17714 CKIN(47)=MAX(PMMN(IWID2),CKIN(47))
17715 CALL PYOFSH(2,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17716 & P(N+IWID2,5))
17717 CKIN(45)=CKIN45
17718 CKIN(47)=CKIN47
17719 ELSE
17720 CKIN(49)=PMMN(IWID1)
17721 CKIN(50)=PMMN(IWID2)
17722 CALL PYOFSH(5,KFA,KFLW1,KFLW2,PMTOT,P(N+IWID1,5),
17723 & P(N+IWID2,5))
17724 CKIN(49)=0D0
17725 CKIN(50)=0D0
17726 ENDIF
17727 IF(MINT(51).EQ.1) GOTO 720
17728 ENDIF
17729
17730C...Begin fill decay products, with colour flow for coloured objects.
17731 MSTU10=MSTU(10)
17732 MSTU(10)=1
17733 MSTU(19)=1
17734
17735
17736C...Three-body decays
17737 IF(KFL3(JT).NE.0.OR.KFL4(JT).NE.0) THEN
17738 DO 250 I=N+1,N+NPROD
17739 DO 240 J=1,5
17740 K(I,J)=0
17741 V(I,J)=0D0
17742 240 CONTINUE
17743 MCT(I,1)=0
17744 MCT(I,2)=0
17745 250 CONTINUE
17746 K(N+1,1)=1
17747 K(N+1,2)=KFL1(JT)
17748 K(N+2,1)=1
17749 K(N+2,2)=KFL2(JT)
17750 K(N+3,1)=1
17751 K(N+3,2)=KFL3(JT)
17752 IF(KFL4(JT).NE.0) THEN
17753 K(N+4,1)=1
17754 K(N+4,2)=KFL4(JT)
17755 ENDIF
17756 IDIN=ID
17757
17758C...Generate kinematics (default is flat)
17759 IF(KFL4(JT).EQ.0) THEN
17760 CALL PYTBDY(IDIN)
17761 ELSE
17762 PS=P(N+1,5)+P(N+2,5)+P(N+3,5)+P(N+4,5)
17763 ND=4
17764 PV(1,1)=0D0
17765 PV(1,2)=0D0
17766 PV(1,3)=0D0
17767 PV(1,4)=P(IDIN,5)
17768 PV(1,5)=P(IDIN,5)
17769C...Calculate maximum weight ND-particle decay.
17770 PV(ND,5)=P(N+ND,5)
17771 WTMAX=1D0/WTCOR(ND-2)
17772 PMAX=PV(1,5)-PS+P(N+ND,5)
17773 PMIN=0D0
17774 DO 381 IL=ND-1,1,-1
17775 PMAX=PMAX+P(N+IL,5)
17776 PMIN=PMIN+P(N+IL+1,5)
17777 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
17778 381 CONTINUE
17779
17780C...M-generator gives weight. If rejected, try again.
17781
17782 411 RORD(1)=1D0
17783 DO 441 IL1=2,ND-1
17784 RSAV=PYR(0)
17785 DO 421 IL2=IL1-1,1,-1
17786 IF(RSAV.LE.RORD(IL2)) GOTO 431
17787 RORD(IL2+1)=RORD(IL2)
17788 421 CONTINUE
17789 431 RORD(IL2+1)=RSAV
17790 441 CONTINUE
17791 RORD(ND)=0D0
17792 WT=1D0
17793 DO 451 IL=ND-1,1,-1
17794 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
17795 & (PV(1,5)-PS)
17796 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
17797 451 CONTINUE
17798 IF(WT.LT.PYR(0)*WTMAX) GOTO 411
17799
17800C...Perform two-particle decays in respective CM frame.
17801 DO 481 IL=1,ND-1
17802 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
17803 UE(3)=2D0*PYR(0)-1D0
17804 PHIX=PARU(2)*PYR(0)
17805 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHIX)
17806 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHIX)
17807 DO 471 J=1,3
17808 P(N+IL,J)=PA*UE(J)
17809 PV(IL+1,J)=-PA*UE(J)
17810 471 CONTINUE
17811 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
17812 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
17813 481 CONTINUE
17814
17815C...Lorentz transform decay products to lab frame.
17816 DO 491 J=1,4
17817 P(N+ND,J)=PV(ND,J)
17818 491 CONTINUE
17819 DO 531 IL=ND-1,1,-1
17820 DO 501 J=1,3
17821 BE(J)=PV(IL,J)/PV(IL,4)
17822 501 CONTINUE
17823 GA=PV(IL,4)/PV(IL,5)
17824 DO 521 I=N+IL,N+ND
17825 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
17826 DO 511 J=1,3
17827 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
17828 511 CONTINUE
17829 P(I,4)=GA*(P(I,4)+BEP)
17830 521 CONTINUE
17831 531 CONTINUE
17832
17833 ENDIF
17834
17835C...Set generic colour flows whenever unambiguous,
17836C...(independently of the order of the decay products)
17837C...Sum up total colour content
17838 NANT=0
17839 NTRI=0
17840 NOCT=0
17841 KCQ(0)=KCQM(JT)
17842 KCQ(1)=KCQ1(JT)
17843 KCQ(2)=KCQ2(JT)
17844 KCQ(3)=KCQ3(JT)
17845 KCQ(4)=KCQ4(JT)
17846 DO 255 J=0,NPROD
17847 IF (KCQ(J).EQ.-1) THEN
17848 NANT=NANT+1
17849 IANT(NANT)=N+J
17850 ELSEIF (KCQ(J).EQ.1) THEN
17851 NTRI=NTRI+1
17852 ITRI(NTRI)=N+J
17853 ELSEIF (KCQ(J).EQ.2) THEN
17854 NOCT=NOCT+1
17855 IOCT(NOCT)=N+J
17856 ENDIF
17857 255 CONTINUE
17858
17859C...Set color flow for generic 1 -> N processes (N arbitrary)
17860 IF (NTRI.EQ.0.AND.NANT.EQ.0.AND.NOCT.EQ.0) THEN
17861C...All singlets: do nothing
17862
17863 ELSEIF (NOCT.EQ.2.AND.NTRI.EQ.0.AND.NANT.EQ.0) THEN
17864C...Two octets, zero triplets, n singlets:
17865 IF (KCQ(0).EQ.2) THEN
17866C...8 -> 8 + n(1)
17867 K(ID,4)=K(ID,4)+IOCT(2)
17868 K(ID,5)=K(ID,5)+IOCT(2)
17869 K(IOCT(2),1)=3
17870 K(IOCT(2),4)=MSTU(5)*ID
17871 K(IOCT(2),5)=MSTU(5)*ID
17872 MCT(IOCT(2),1)=MCT(ID,1)
17873 MCT(IOCT(2),2)=MCT(ID,2)
17874 ELSE
17875C...1 -> 8 + 8 + n(1)
17876 K(IOCT(1),1)=3
17877 K(IOCT(1),4)=MSTU(5)*IOCT(2)
17878 K(IOCT(1),5)=MSTU(5)*IOCT(2)
17879 K(IOCT(2),1)=3
17880 K(IOCT(2),4)=MSTU(5)*IOCT(1)
17881 K(IOCT(2),5)=MSTU(5)*IOCT(1)
17882 NCT=NCT+1
17883 MCT(IOCT(1),1)=NCT
17884 MCT(IOCT(2),2)=NCT
17885 NCT=NCT+1
17886 MCT(IOCT(2),1)=NCT
17887 MCT(IOCT(1),2)=NCT
17888 ENDIF
17889
17890 ELSEIF (NTRI+NANT.EQ.2.AND.NOCT.EQ.0) THEN
17891C...Two triplets, zero octets, n singlets.
17892 IF (KCQ(0).EQ.1) THEN
17893C...3 -> 3 + n(1)
17894 K(ID,4)=K(ID,4)+ITRI(2)
17895 K(ITRI(2),1)=3
17896 K(ITRI(2),4)=MSTU(5)*ID
17897 MCT(ITRI(2),1)=MCT(ID,1)
17898 ELSEIF (KCQ(0).EQ.-1) THEN
17899C...3bar -> 3bar + n(1)
17900 K(ID,5)=K(ID,5)+IANT(2)
17901 K(IANT(2),1)=3
17902 K(IANT(2),5)=MSTU(5)*ID
17903 MCT(IANT(2),2)=MCT(ID,2)
17904 ELSE
17905C...1 -> 3 + 3bar + n(1)
17906 K(ITRI(1),1)=3
17907 K(ITRI(1),4)=MSTU(5)*IANT(1)
17908 K(IANT(1),1)=3
17909 K(IANT(1),5)=MSTU(5)*ITRI(1)
17910 NCT=NCT+1
17911 MCT(ITRI(1),1)=NCT
17912 MCT(IANT(1),2)=NCT
17913 ENDIF
17914
17915 ELSEIF(NTRI+NANT.EQ.2.AND.NOCT.EQ.1) THEN
17916C...Two triplets, one octet, n singlets.
17917 IF (KCQ(0).EQ.2) THEN
17918C...8 -> 3 + 3bar + n(1)
17919 K(ID,4)=K(ID,4)+ITRI(1)
17920 K(ID,5)=K(ID,5)+IANT(1)
17921 K(ITRI(1),1)=3
17922 K(ITRI(1),4)=MSTU(5)*ID
17923 K(IANT(1),1)=3
17924 K(IANT(1),5)=MSTU(5)*ID
17925 MCT(ITRI(1),1)=MCT(ID,1)
17926 MCT(IANT(1),2)=MCT(ID,2)
17927 ELSEIF (KCQ(0).EQ.1) THEN
17928C...3 -> 8 + 3 + n(1)
17929 K(ID,4)=K(ID,4)+IOCT(1)
17930 K(IOCT(1),1)=3
17931 K(IOCT(1),4)=MSTU(5)*ID
17932 K(IOCT(1),5)=MSTU(5)*ITRI(2)
17933 K(ITRI(2),1)=3
17934 K(ITRI(2),4)=MSTU(5)*IOCT(1)
17935 MCT(IOCT(1),1)=MCT(ID,1)
17936 NCT=NCT+1
17937 MCT(IOCT(1),2)=NCT
17938 MCT(ITRI(2),1)=NCT
17939 ELSEIF (KCQ(0).EQ.-1) THEN
17940C...3bar -> 8 + 3bar + n(1)
17941 K(ID,5)=K(ID,5)+IOCT(1)
17942 K(IOCT(1),1)=3
17943 K(IOCT(1),5)=MSTU(5)*ID
17944 K(IOCT(1),4)=MSTU(5)*IANT(2)
17945 K(IANT(2),1)=3
17946 K(IANT(2),5)=MSTU(5)*IOCT(1)
17947 MCT(IOCT(1),2)=MCT(ID,2)
17948 NCT=NCT+1
17949 MCT(IOCT(1),1)=NCT
17950 MCT(IANT(2),2)=NCT
17951 ELSE
17952C...1 -> 3 + 3bar + 8 + n(1)
17953 K(ITRI(1),1)=3
17954 K(ITRI(1),4)=MSTU(5)*IOCT(1)
17955 K(IOCT(1),1)=3
17956 K(IOCT(1),5)=MSTU(5)*ITRI(1)
17957 K(IOCT(1),4)=MSTU(5)*IANT(1)
17958 K(IANT(1),1)=3
17959 K(IANT(1),5)=MSTU(5)*IOCT(1)
17960 NCT=NCT+1
17961 MCT(ITRI(1),1)=NCT
17962 MCT(IOCT(1),2)=NCT
17963 NCT=NCT+1
17964 MCT(IOCT(1),1)=NCT
17965 MCT(IANT(1),2)=NCT
17966 ENDIF
17967 ELSEIF(NTRI+NANT.EQ.4) THEN
17968C...
17969 IF (KCQ(0).EQ.1) THEN
17970C...3 -> 3 + n(1) -> 3 + 3bar
17971 K(ID,4)=K(ID,4)+ITRI(2)
17972 K(ITRI(2),1)=3
17973 K(ITRI(2),4)=MSTU(5)*ID
17974 MCT(ITRI(2),1)=MCT(ID,1)
17975 K(ITRI(3),1)=3
17976 K(ITRI(3),4)=MSTU(5)*IANT(1)
17977 K(IANT(1),1)=3
17978 K(IANT(1),5)=MSTU(5)*ITRI(3)
17979 NCT=NCT+1
17980 MCT(ITRI(3),1)=NCT
17981 MCT(IANT(1),2)=NCT
17982 ELSEIF (KCQ(0).EQ.-1) THEN
17983C...3bar -> 3bar + n(1) -> 3 + 3bar
17984 K(ID,5)=K(ID,5)+IANT(2)
17985 K(IANT(2),1)=3
17986 K(IANT(2),5)=MSTU(5)*ID
17987 MCT(IANT(2),2)=MCT(ID,2)
17988 K(ITRI(1),1)=3
17989 K(ITRI(1),4)=MSTU(5)*IANT(3)
17990 K(IANT(3),1)=3
17991 K(IANT(3),5)=MSTU(5)*ITRI(1)
17992 NCT=NCT+1
17993 MCT(ITRI(1),1)=NCT
17994 MCT(IANT(3),2)=NCT
17995 ENDIF
17996 ELSEIF(KFL4(JT).NE.0) THEN
17997 CALL PYERRM(21,'(PYRESD:) unknown 4-bdy decay')
17998CPS-- End of generic cases
17999C...(could three octets also be handled?)
18000C...(could (some of) the RPV cases be made generic as well?)
18001
18002C...Special cases (= old treatment)
18003C...Set colour flow for t -> W + b + Z.
18004 ELSEIF(KFA.EQ.6) THEN
18005 K(N+2,1)=3
18006 ISID=4
18007 IF(KCQM(JT).EQ.-1) ISID=5
18008 IDAU=N+2
18009 K(ID,ISID)=K(ID,ISID)+IDAU
18010 K(IDAU,ISID)=MSTU(5)*ID
18011
18012C...Set colour flow in three-body decays - programmed as special cases.
18013
18014 ELSEIF(KFC2A.LE.6) THEN
18015 K(N+2,1)=3
18016 K(N+3,1)=3
18017 ISID=4
18018 IF(KFL2(JT).LT.0) ISID=5
18019 K(N+2,ISID)=MSTU(5)*(N+3)
18020 K(N+3,9-ISID)=MSTU(5)*(N+2)
18021C...PS++: Bugfix 16 MAR 2006 for 3-body squark decays (e.g. via SLHA)
18022 ELSEIF(KFA.GT.KSUSY1.AND.MOD(KFA,KSUSY1).LT.10
18023 & .AND.KFL3(JT).NE.0) THEN
18024 KQSUMA=IABS(KCQ1(JT))+IABS(KCQ2(JT))+IABS(KCQ3(JT))
18025C...3-body decays of squarks to colour singlets plus one quark
18026 IF (KQSUMA.EQ.1) THEN
18027C...Find quark
18028 IQ=0
18029 IF (KCQ1(JT).NE.0) IQ=1
18030 IF (KCQ2(JT).NE.0) IQ=2
18031 IF (KCQ3(JT).NE.0) IQ=3
18032 ISID=4
18033 IF (K(N+IQ,2).LT.0) ISID=5
18034 K(N+IQ,1)=3
18035 K(ID,ISID)=K(ID,ISID)+(N+IQ)
18036 K(N+IQ,ISID)=MSTU(5)*ID
18037 ENDIF
18038C...PS--
18039 ELSEIF(KFL1(JT).EQ.KSUSY1+21) THEN
18040 K(N+1,1)=3
18041 K(N+2,1)=3
18042 K(N+3,1)=3
18043 ISID=4
18044 IF(KFL2(JT).LT.0) ISID=5
18045 K(N+1,ISID)=MSTU(5)*(N+2)
18046 K(N+1,9-ISID)=MSTU(5)*(N+3)
18047 K(N+2,ISID)=MSTU(5)*(N+1)
18048 K(N+3,9-ISID)=MSTU(5)*(N+1)
18049 ELSEIF(KFA.EQ.KSUSY1+21) THEN
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(ID,ISID)=K(ID,ISID)+(N+2)
18055 K(ID,9-ISID)=K(ID,9-ISID)+(N+3)
18056 K(N+2,ISID)=MSTU(5)*ID
18057 K(N+3,9-ISID)=MSTU(5)*ID
18058CMRENNA--
18059
18060 ELSEIF(KFA.GE.KSUSY1+22.AND.KFA.LE.KSUSY1+37.AND.
18061 & IABS(KCQ2(JT)).EQ.1) THEN
18062 K(N+2,1)=3
18063 K(N+3,1)=3
18064 ISID=4
18065 IF(KFL2(JT).LT.0) ISID=5
18066 K(N+2,ISID)=MSTU(5)*(N+3)
18067 K(N+3,9-ISID)=MSTU(5)*(N+2)
18068 ENDIF
18069
18070 NSAV=N
18071
18072C...Set colour flow in three-body decays with baryon number violation.
18073C...Neutralino and chargino decays first.
18074 KCQSUM=KCQ1(JT)+KCQ2(JT)+KCQ3(JT)
18075 IF(KCQM(JT).EQ.0.AND.IABS(KCQSUM).EQ.3) THEN
18076 ITJUNC(JT)=(1+(1-KCQ1(JT))/2)
18077 K(N+4,4)=ITJUNC(JT)*MSTU(5)
18078C...Insert junction to keep track of colours.
18079 IF(KCQ1(JT).NE.0) K(N+1,1)=3
18080 IF(KCQ2(JT).NE.0) K(N+2,1)=3
18081 IF(KCQ3(JT).NE.0) K(N+3,1)=3
18082C...Set special junction codes:
18083 K(N+4,1)=42
18084 K(N+4,2)=88
18085
18086C...Order decay products by invariant mass. (will be used in PYSTRF).
18087 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)-
18088 & P(N+1,3)*P(N+2,3)
18089 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)-
18090 & P(N+1,3)*P(N+3,3)
18091 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)-
18092 & P(N+2,3)*P(N+3,3)
18093 IF(PM12.LT.PM13.AND.PM12.LT.PM23) THEN
18094 K(N+4,4)=N+3+K(N+4,4)
18095 K(N+4,5)=N+1+MSTU(5)*(N+2)
18096 ELSEIF(PM13.LT.PM23) THEN
18097 K(N+4,4)=N+2+K(N+4,4)
18098 K(N+4,5)=N+1+MSTU(5)*(N+3)
18099 ELSE
18100 K(N+4,4)=N+1+K(N+4,4)
18101 K(N+4,5)=N+2+MSTU(5)*(N+3)
18102 ENDIF
18103 DO 260 J=1,5
18104 P(N+4,J)=0D0
18105 V(N+4,J)=0D0
18106 260 CONTINUE
18107C...Connect daughters to junction.
18108 DO 270 II=N+1,N+3
18109 K(II,4)=0
18110 K(II,5)=0
18111 K(II,ITJUNC(JT)+3)=MSTU(5)*(N+4)
18112 270 CONTINUE
18113C...Particle counter should be stepped up one extra for junction.
18114 N=N+1
18115
18116C...Gluino decays.
18117 ELSEIF (KCQM(JT).EQ.2.AND.IABS(KCQSUM).EQ.3) THEN
18118 ITJUNC(JT)=(5+(1-KCQ1(JT))/2)
18119 K(N+4,4)=ITJUNC(JT)*MSTU(5)
18120C...Insert junction to keep track of colours.
18121 IF(KCQ1(JT).NE.0) K(N+1,1)=3
18122 IF(KCQ2(JT).NE.0) K(N+2,1)=3
18123 IF(KCQ3(JT).NE.0) K(N+3,1)=3
18124 K(N+4,1)=42
18125 K(N+4,2)=88
18126 DO 280 J=1,5
18127 P(N+4,J)=0D0
18128 V(N+4,J)=0D0
18129 280 CONTINUE
18130 CTMSUM=0D0
18131 DO 290 II=N+1,N+3
18132 K(II,4)=0
18133 K(II,5)=0
18134C...Start by connecting all daughters to junction.
18135 K(II,ITJUNC(JT)-1)=MSTU(5)*(N+4)
18136C...Only consider colour topologies with off shell resonances.
18137 RMQ1=PMAS(PYCOMP(K(II,2)),1)
18138 RMRES=PMAS(PYCOMP(KSUSY1+IABS(K(II,2))),1)
18139 RMGLU=PMAS(PYCOMP(KSUSY1+21),1)
18140 IF (RMGLU-RMQ1.LT.RMRES) THEN
18141C...Calculate propagators for each colour topology.
18142 RM2Q23=RMGLU**2+RMQ1**2-2D0*(P(II,4)*P(ID,4)+P(II,1)
18143 & *P(ID,1)+P(II,2)*P(ID,2)+P(II,3)*P(ID,3))
18144 CTM2(II-N)=1D0/(RM2Q23-RMRES**2)**2
18145 ELSE
18146 CTM2(II-N)=0D0
18147 ENDIF
18148 CTMSUM=CTMSUM+CTM2(II-N)
18149 290 CONTINUE
18150 CTMSUM=PYR(0)*CTMSUM
18151C...Select colour topology J, with most off shell least likely.
18152 J=0
18153 300 J=J+1
18154 CTMSUM=CTMSUM-CTM2(J)
18155 IF (CTMSUM.GT.0D0) GOTO 300
18156C...The lucky winner gets its colour (anti-colour) directly from gluino.
18157 K(N+J,ITJUNC(JT)-1)=MSTU(5)*ID
18158 K(ID,ITJUNC(JT)-1)=N+J+(K(ID,ITJUNC(JT)-1)/MSTU(5))*MSTU(5)
18159C...The other gluino colour is connected to junction
18160 K(ID,10-ITJUNC(JT))=N+4+(K(ID,10-ITJUNC(JT))/MSTU(5))*
18161 & MSTU(5)
18162 K(N+4,4)=K(N+4,4)+ID
18163C...Lastly, connect junction to remaining daughters.
18164 K(N+4,5)=N+1+MOD(J,3)+MSTU(5)*(N+1+MOD(J+1,3))
18165C...Particle counter should be stepped up one extra for junction.
18166 N=N+1
18167 ENDIF
18168
18169C...Update particle counter.
18170 N=N+NPROD
18171
18172C...2) Everything else two-body decay.
18173 ELSE
18174 CALL PY2ENT(N+1,KFL1(JT),KFL2(JT),P(ID,5))
18175 MCT(N-1,1)=0
18176 MCT(N-1,2)=0
18177 MCT(N,1)=0
18178 MCT(N,2)=0
18179C...First set colour flow as if mother colour singlet.
18180 IF(KCQ1(JT).NE.0) THEN
18181 K(N-1,1)=3
18182 IF(KCQ1(JT).NE.-1) K(N-1,4)=MSTU(5)*N
18183 IF(KCQ1(JT).NE.1) K(N-1,5)=MSTU(5)*N
18184 ENDIF
18185 IF(KCQ2(JT).NE.0) THEN
18186 K(N,1)=3
18187 IF(KCQ2(JT).NE.-1) K(N,4)=MSTU(5)*(N-1)
18188 IF(KCQ2(JT).NE.1) K(N,5)=MSTU(5)*(N-1)
18189 ENDIF
18190C...Then redirect colour flow if mother (anti)triplet.
18191 IF(KCQM(JT).EQ.0) THEN
18192 ELSEIF(KCQM(JT).NE.2) THEN
18193 ISID=4
18194 IF(KCQM(JT).EQ.-1) ISID=5
18195 IDAU=N-1
18196 IF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.2) IDAU=N
18197 K(ID,ISID)=K(ID,ISID)+IDAU
18198 K(IDAU,ISID)=MSTU(5)*ID
18199C...Then redirect colour flow if mother octet.
18200 ELSEIF(KCQ1(JT).EQ.0.OR.KCQ2(JT).EQ.0) THEN
18201 IDAU=N-1
18202 IF(KCQ1(JT).EQ.0) IDAU=N
18203 K(ID,4)=K(ID,4)+IDAU
18204 K(ID,5)=K(ID,5)+IDAU
18205 K(IDAU,4)=MSTU(5)*ID
18206 K(IDAU,5)=MSTU(5)*ID
18207 ELSE
18208 ISID=4
18209 IF(KCQ1(JT).EQ.-1) ISID=5
18210 IF(KCQ1(JT).EQ.2) ISID=INT(4.5D0+PYR(0))
18211 K(ID,ISID)=K(ID,ISID)+(N-1)
18212 K(ID,9-ISID)=K(ID,9-ISID)+N
18213 K(N-1,ISID)=MSTU(5)*ID
18214 K(N,9-ISID)=MSTU(5)*ID
18215 ENDIF
18216
18217C...Insert junction
18218 IF(IABS(KCQ1(JT)+KCQ2(JT)-KCQM(JT)).EQ.3) THEN
18219 N=N+1
18220C...~q* mother: type 3 junction. ~q mother: type 4.
18221 ITJUNC(JT)=(7+KCQM(JT))/2
18222C...Specify junction KF and set colour flow from junction
18223 K(N,1)=42
18224 K(N,2)=88
18225 K(N,3)=ID
18226C...Junction type encoded together with mother:
18227 K(N,4)=ID+ITJUNC(JT)*MSTU(5)
18228 K(N,5)=N-1+MSTU(5)*(N-2)
18229C...Zero P and V for junction (V filled later)
18230 DO 310 J=1,5
18231 P(N,J)=0D0
18232 V(N,J)=0D0
18233 310 CONTINUE
18234C...Set colour flow from mother to junction
18235 K(ID,8-ITJUNC(JT))= N + MSTU(5)*(K(ID,8-ITJUNC(JT))/MSTU(5))
18236C...Set colour flow from daughters to junction
18237 DO 320 II=N-2,N-1
18238 K(II,4) = 0
18239 K(II,5) = 0
18240C...(Anti-)colour mother is junction.
18241 K(II,1+ITJUNC(JT)) = MSTU(5)*N
18242 320 CONTINUE
18243 ENDIF
18244 ENDIF
18245
18246C...End loop over resonances for daughter flavour and mass selection.
18247 MSTU(10)=MSTU10
18248 330 IF(MWID(KCA).NE.0.AND.(KFL1(JT).EQ.0.OR.KFL3(JT).NE.0))
18249 & NINH=NINH+1
18250 IF(IRES.GT.0.AND.MWID(KCA).NE.0.AND.MDCY(KCA,1).NE.0.AND.
18251 & KFL1(JT).EQ.0) THEN
18252 WRITE(CODE,'(I9)') K(ID,2)
18253 WRITE(MASS,'(F9.3)') P(ID,5)
18254 CALL PYERRM(3,'(PYRESD:) Failed to decay particle'//
18255 & CODE//' with mass'//MASS)
18256 MINT(51)=1
18257 GOTO 720
18258 ENDIF
18259 340 CONTINUE
18260
18261C...Check for allowed combinations. Skip if no decays.
18262 IF(JTMAX.EQ.1) THEN
18263 IF(KDCY(1).EQ.0) GOTO 710
18264 ELSEIF(JTMAX.EQ.2) THEN
18265 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0) GOTO 710
18266 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
18267 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
18268 ELSEIF(JTMAX.EQ.3) THEN
18269 IF(KDCY(1).EQ.0.AND.KDCY(2).EQ.0.AND.KDCY(3).EQ.0) GOTO 710
18270 IF(KEQL(1).EQ.4.AND.KEQL(2).EQ.4) GOTO 180
18271 IF(KEQL(1).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
18272 IF(KEQL(2).EQ.4.AND.KEQL(3).EQ.4) GOTO 180
18273 IF(KEQL(1).EQ.5.AND.KEQL(2).EQ.5) GOTO 180
18274 IF(KEQL(1).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
18275 IF(KEQL(2).EQ.5.AND.KEQL(3).EQ.5) GOTO 180
18276 ENDIF
18277
18278C...Special case: matrix element option for Z0 decay to quarks.
18279 IF(MSTP(48).EQ.1.AND.ISUB.EQ.1.AND.JTMAX.EQ.1.AND.
18280 &IABS(MINT(11)).EQ.11.AND.IABS(KFL1(1)).LE.5) THEN
18281
18282C...Check consistency of MSTJ options set.
18283 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
18284 CALL PYERRM(6,
18285 & '(PYRESD:) MSTJ(109) value requires MSTJ(110) = 1')
18286 MSTJ(110)=1
18287 ENDIF
18288 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
18289 CALL PYERRM(6,
18290 & '(PYRESD:) MSTJ(109) value requires MSTJ(111) = 0')
18291
18292 MSTJ(111)=0
18293 ENDIF
18294
18295C...Select alpha_strong behaviour.
18296 MST111=MSTU(111)
18297 PAR112=PARU(112)
18298 MSTU(111)=MSTJ(108)
18299 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
18300 & MSTU(111)=1
18301 PARU(112)=PARJ(121)
18302 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
18303
18304C...Find axial fraction in total cross section for scalar gluon model.
18305 PARJ(171)=0D0
18306 IF((IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.1).OR.
18307 & (MSTJ(101).EQ.5.AND.MSTJ(49).EQ.1)) THEN
18308 POLL=1D0-PARJ(131)*PARJ(132)
18309 SFF=1D0/(16D0*XW*XW1)
18310 SFW=P(ID,5)**4/((P(ID,5)**2-PARJ(123)**2)**2+
18311 & (PARJ(123)*PARJ(124))**2)
18312 SFI=SFW*(1D0-(PARJ(123)/P(ID,5))**2)
18313 VE=4D0*XW-1D0
18314 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
18315 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*
18316 & (PARJ(132)-PARJ(131)))
18317 KFLC=IABS(KFL1(1))
18318 PMQ=PYMASS(KFLC)
18319 QF=KCHG(KFLC,1)/3D0
18320 VQ=1D0
18321 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,
18322 & 1D0-(2D0*PMQ/P(ID,5))**2))
18323 VF=SIGN(1D0,QF)-4D0*QF*XW
18324 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+
18325 & VF**2*HF1W)+VQ**3*HF1W
18326 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
18327 ENDIF
18328
18329C...Choice of jet configuration.
18330 CALL PYXJET(P(ID,5),NJET,CUT)
18331 KFLC=IABS(KFL1(1))
18332 KFLN=21
18333 IF(NJET.EQ.4) THEN
18334 CALL PYX4JT(NJET,CUT,KFLC,P(ID,5),KFLN,X1,X2,X4,X12,X14)
18335 ELSEIF(NJET.EQ.3) THEN
18336 CALL PYX3JT(NJET,CUT,KFLC,P(ID,5),X1,X3)
18337 ELSE
18338 MSTJ(120)=1
18339 ENDIF
18340
18341C...Fill jet configuration; return if incorrect kinematics.
18342 NC=N-2
18343 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) THEN
18344 CALL PY2ENT(NC+1,KFLC,-KFLC,P(ID,5))
18345 ELSEIF(NJET.EQ.2) THEN
18346 CALL PY2ENT(-(NC+1),KFLC,-KFLC,P(ID,5))
18347 ELSEIF(NJET.EQ.3) THEN
18348 CALL PY3ENT(NC+1,KFLC,21,-KFLC,P(ID,5),X1,X3)
18349 ELSEIF(KFLN.EQ.21) THEN
18350 CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
18351 & X12,X14)
18352 ELSE
18353 CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,-KFLC,P(ID,5),X1,X2,X4,
18354 & X12,X14)
18355 ENDIF
18356 IF(MSTU(24).NE.0) THEN
18357 MINT(51)=1
18358 MSTU(111)=MST111
18359 PARU(112)=PAR112
18360 GOTO 720
18361 ENDIF
18362
18363C...Angular orientation according to matrix element.
18364 IF(MSTJ(106).EQ.1) THEN
18365 CALL PYXDIF(NC,NJET,KFLC,P(ID,5),CHIZ,THEZ,PHIZ)
18366 IF(MINT(11).LT.0) THEZ=PARU(1)-THEZ
18367 CTHE(1)=COS(THEZ)
18368 CALL PYROBO(NC+1,N,0D0,CHIZ,0D0,0D0,0D0)
18369 CALL PYROBO(NC+1,N,THEZ,PHIZ,0D0,0D0,0D0)
18370 ENDIF
18371
18372C...Boost partons to Z0 rest frame.
18373 CALL PYROBO(NC+1,N,0D0,0D0,P(ID,1)/P(ID,4),
18374 & P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
18375
18376C...Mark decayed resonance and add documentation lines,
18377 K(ID,1)=K(ID,1)+10
18378 IDOC=MINT(83)+MINT(4)
18379 DO 360 I=NC+1,N
18380 I1=MINT(83)+MINT(4)+1
18381 K(I,3)=I1
18382 IF(MSTP(128).GE.1) K(I,3)=ID
18383 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
18384 MINT(4)=MINT(4)+1
18385 K(I1,1)=21
18386 K(I1,2)=K(I,2)
18387 K(I1,3)=IREF(IP,4)
18388 DO 350 J=1,5
18389 P(I1,J)=P(I,J)
18390 350 CONTINUE
18391 ENDIF
18392 360 CONTINUE
18393
18394C...Generate parton shower.
18395 IF(MSTJ(101).EQ.5.AND.MINT(35).LE.1) THEN
18396 CALL PYSHOW(N-1,N,P(ID,5))
18397 ELSEIF(MSTJ(101).EQ.5.AND.MINT(35).GE.2) THEN
18398 NPART=2
18399 IPART(1)=N-1
18400 IPART(2)=N
18401 PTPART(1)=0.5D0*P(ID,5)
18402 PTPART(2)=PTPART(1)
18403 NCT=NCT+1
18404 IF(K(N-1,2).GT.0) THEN
18405 MCT(N-1,1)=NCT
18406 MCT(N,2)=NCT
18407 ELSE
18408 MCT(N-1,2)=NCT
18409 MCT(N,1)=NCT
18410 ENDIF
18411 CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
18412 ENDIF
18413
18414C... End special case for Z0: skip ahead.
18415 MSTU(111)=MST111
18416 PARU(112)=PAR112
18417 GOTO 700
18418 ENDIF
18419
18420C...Order incoming partons and outgoing resonances.
18421 IF(JTMAX.EQ.2.AND.ISUB.NE.0.AND.MSTP(47).GE.1.AND.
18422 &NINH.EQ.0) THEN
18423 ILIN(1)=MINT(84)+1
18424 IF(K(MINT(84)+1,2).GT.0) ILIN(1)=MINT(84)+2
18425 IF(K(ILIN(1),2).EQ.21.OR.K(ILIN(1),2).EQ.22)
18426 & ILIN(1)=2*MINT(84)+3-ILIN(1)
18427 ILIN(2)=2*MINT(84)+3-ILIN(1)
18428 IMIN=1
18429 IF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.IREF(IP,7)
18430 & .EQ.36) IMIN=3
18431 IMAX=2
18432 IORD=1
18433 IF(K(IREF(IP,1),2).EQ.23) IORD=2
18434 IF(K(IREF(IP,1),2).EQ.24.AND.K(IREF(IP,2),2).EQ.-24) IORD=2
18435 IAKIPD=IABS(K(IREF(IP,IORD),2))
18436 IF(IAKIPD.EQ.25.OR.IAKIPD.EQ.35.OR.IAKIPD.EQ.36) IORD=3-IORD
18437 IF(KDCY(IORD).EQ.0) IORD=3-IORD
18438
18439C...Order decay products of resonances.
18440 DO 370 JT=IORD,3-IORD,3-2*IORD
18441 IF(KDCY(JT).EQ.0) THEN
18442 ILIN(IMAX+1)=NSD(JT)
18443 IMAX=IMAX+1
18444 ELSEIF(K(NSD(JT)+1,2).GT.0) THEN
18445 ILIN(IMAX+1)=N+2*JT-1
18446 ILIN(IMAX+2)=N+2*JT
18447 IMAX=IMAX+2
18448 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18449 K(N+2*JT,2)=K(NSD(JT)+2,2)
18450 ELSE
18451 ILIN(IMAX+1)=N+2*JT
18452
18453 ILIN(IMAX+2)=N+2*JT-1
18454 IMAX=IMAX+2
18455 K(N+2*JT-1,2)=K(NSD(JT)+1,2)
18456 K(N+2*JT,2)=K(NSD(JT)+2,2)
18457 ENDIF
18458 370 CONTINUE
18459
18460C...Find charge, isospin, left- and righthanded couplings.
18461 DO 390 I=IMIN,IMAX
18462 DO 380 J=1,4
18463 COUP(I,J)=0D0
18464 380 CONTINUE
18465 KFA=IABS(K(ILIN(I),2))
18466 IF(KFA.EQ.0.OR.KFA.GT.20) GOTO 390
18467 COUP(I,1)=KCHG(KFA,1)/3D0
18468 COUP(I,2)=(-1)**MOD(KFA,2)
18469 COUP(I,4)=-2D0*COUP(I,1)*XWV
18470 COUP(I,3)=COUP(I,2)+COUP(I,4)
18471 390 CONTINUE
18472
18473C...Full propagator dependence and flavour correlations for 2 gamma*/Z.
18474 IF(ISUB.EQ.22) THEN
18475 DO 420 I=3,5,2
18476 I1=IORD
18477 IF(I.EQ.5) I1=3-IORD
18478 DO 410 J1=1,2
18479 DO 400 J2=1,2
18480 CORL(I/2,J1,J2)=COUP(1,1)**2*HGZ(I1,1)*COUP(I,1)**2/
18481 & 16D0+COUP(1,1)*COUP(1,J1+2)*HGZ(I1,2)*COUP(I,1)*
18482 & COUP(I,J2+2)/4D0+COUP(1,J1+2)**2*HGZ(I1,3)*
18483 & COUP(I,J2+2)**2
18484 400 CONTINUE
18485 410 CONTINUE
18486 420 CONTINUE
18487 COWT12=(CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18488 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2))
18489 COMX12=(CORL(1,1,1)+CORL(1,1,2)+CORL(1,2,1)+CORL(1,2,2))*
18490 & (CORL(2,1,1)+CORL(2,1,2)+CORL(2,2,1)+CORL(2,2,2))
18491
18492 IF(COWT12.LT.PYR(0)*COMX12) GOTO 180
18493 ENDIF
18494 ENDIF
18495
18496C...Select angular orientation type - Z'/W' only.
18497 MZPWP=0
18498 IF(ISUB.EQ.141) THEN
18499 IF(PYR(0).LT.PARU(130)) MZPWP=1
18500 IF(IP.EQ.2) THEN
18501 IF(IABS(K(IREF(2,1),2)).EQ.37) MZPWP=2
18502 IAKIR=IABS(K(IREF(2,2),2))
18503 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18504 IF(IAKIR.LE.20) MZPWP=2
18505 ENDIF
18506 IF(IP.GE.3) MZPWP=2
18507 ELSEIF(ISUB.EQ.142) THEN
18508 IF(PYR(0).LT.PARU(136)) MZPWP=1
18509 IF(IP.EQ.2) THEN
18510 IAKIR=IABS(K(IREF(2,2),2))
18511 IF(IAKIR.EQ.25.OR.IAKIR.EQ.35.OR.IAKIR.EQ.36) MZPWP=2
18512 IF(IAKIR.LE.20) MZPWP=2
18513 ENDIF
18514 IF(IP.GE.3) MZPWP=2
18515 ENDIF
18516
18517C...Select random angles (begin of weighting procedure).
18518 430 DO 440 JT=1,JTMAX
18519 IF(KDCY(JT).EQ.0) GOTO 440
18520 IF(JTMAX.EQ.1.AND.ISUB.NE.0.AND.IHDEC.EQ.0) THEN
18521 CTHE(JT)=VINT(13)+(VINT(33)-VINT(13)+VINT(34)-VINT(14))*PYR(0)
18522 IF(CTHE(JT).GT.VINT(33)) CTHE(JT)=CTHE(JT)+VINT(14)-VINT(33)
18523 PHI(JT)=VINT(24)
18524 ELSE
18525 CTHE(JT)=2D0*PYR(0)-1D0
18526 PHI(JT)=PARU(2)*PYR(0)
18527 ENDIF
18528 440 CONTINUE
18529
18530 IF(JTMAX.EQ.2.AND.MSTP(47).GE.1.AND.NINH.EQ.0) THEN
18531C...Construct massless four-vectors.
18532 DO 460 I=N+1,N+4
18533 K(I,1)=1
18534 DO 450 J=1,5
18535 P(I,J)=0D0
18536 V(I,J)=0D0
18537 450 CONTINUE
18538 460 CONTINUE
18539 DO 470 JT=1,JTMAX
18540 IF(KDCY(JT).EQ.0) GOTO 470
18541 ID=IREF(IP,JT)
18542 P(N+2*JT-1,3)=0.5D0*P(ID,5)
18543 P(N+2*JT-1,4)=0.5D0*P(ID,5)
18544 P(N+2*JT,3)=-0.5D0*P(ID,5)
18545 P(N+2*JT,4)=0.5D0*P(ID,5)
18546 CALL PYROBO(N+2*JT-1,N+2*JT,ACOS(CTHE(JT)),PHI(JT),
18547 & P(ID,1)/P(ID,4),P(ID,2)/P(ID,4),P(ID,3)/P(ID,4))
18548 470 CONTINUE
18549
18550C...Store incoming and outgoing momenta, with random rotation to
18551C...avoid accidental zeroes in HA expressions.
18552 IF(ISUB.NE.0) THEN
18553 DO 490 I=IMIN,IMAX
18554 K(N+4+I,1)=1
18555 P(N+4+I,4)=SQRT(P(ILIN(I),1)**2+P(ILIN(I),2)**2+
18556 & P(ILIN(I),3)**2+P(ILIN(I),5)**2)
18557 P(N+4+I,5)=P(ILIN(I),5)
18558 DO 480 J=1,3
18559 P(N+4+I,J)=P(ILIN(I),J)
18560 480 CONTINUE
18561 490 CONTINUE
18562 500 THERR=ACOS(2D0*PYR(0)-1D0)
18563 PHIRR=PARU(2)*PYR(0)
18564 CALL PYROBO(N+4+IMIN,N+4+IMAX,THERR,PHIRR,0D0,0D0,0D0)
18565 DO 520 I=IMIN,IMAX
18566 IF(P(N+4+I,1)**2+P(N+4+I,2)**2.LT.1D-4*(P(N+4+I,1)**2+
18567 & P(N+4+I,2)**2+P(N+4+I,3)**2)) GOTO 500
18568 DO 510 J=1,4
18569 PK(I,J)=P(N+4+I,J)
18570 510 CONTINUE
18571 520 CONTINUE
18572 ENDIF
18573
18574C...Calculate internal products.
18575 IF(ISUB.EQ.22.OR.ISUB.EQ.23.OR.ISUB.EQ.25.OR.ISUB.EQ.141.OR.
18576 & ISUB.EQ.142) THEN
18577 DO 540 I1=IMIN,IMAX-1
18578 DO 530 I2=I1+1,IMAX
18579 HA(I1,I2)=SNGL(SQRT((PK(I1,4)-PK(I1,3))*(PK(I2,4)+
18580 & PK(I2,3))/(1D-20+PK(I1,1)**2+PK(I1,2)**2)))*
18581 & CMPLX(SNGL(PK(I1,1)),SNGL(PK(I1,2)))-
18582 & SNGL(SQRT((PK(I1,4)+PK(I1,3))*(PK(I2,4)-PK(I2,3))/
18583 & (1D-20+PK(I2,1)**2+PK(I2,2)**2)))*
18584 & CMPLX(SNGL(PK(I2,1)),SNGL(PK(I2,2)))
18585 HC(I1,I2)=CONJG(HA(I1,I2))
18586 IF(I1.LE.2) HA(I1,I2)=CMPLX(0.,1.)*HA(I1,I2)
18587 IF(I1.LE.2) HC(I1,I2)=CMPLX(0.,1.)*HC(I1,I2)
18588 HA(I2,I1)=-HA(I1,I2)
18589 HC(I2,I1)=-HC(I1,I2)
18590 530 CONTINUE
18591 540 CONTINUE
18592 ENDIF
18593
18594C...Calculate four-products.
18595 IF(ISUB.NE.0) THEN
18596 DO 560 I=1,2
18597 DO 550 J=1,4
18598 PK(I,J)=-PK(I,J)
18599 550 CONTINUE
18600 560 CONTINUE
18601 DO 580 I1=IMIN,IMAX-1
18602 DO 570 I2=I1+1,IMAX
18603 PKK(I1,I2)=2D0*(PK(I1,4)*PK(I2,4)-PK(I1,1)*PK(I2,1)-
18604 & PK(I1,2)*PK(I2,2)-PK(I1,3)*PK(I2,3))
18605 PKK(I2,I1)=PKK(I1,I2)
18606 570 CONTINUE
18607 580 CONTINUE
18608 ENDIF
18609 ENDIF
18610
18611 KFAGM=IABS(IREF(IP,7))
18612 IF(MSTP(47).LE.0.OR.NINH.NE.0) THEN
18613C...Isotropic decay selected by user.
18614 WT=1D0
18615 WTMAX=1D0
18616
18617 ELSEIF(JTMAX.EQ.3) THEN
18618C...Isotropic decay when three mother particles.
18619 WT=1D0
18620 WTMAX=1D0
18621
18622 ELSEIF(IT4.GE.1) THEN
18623C... Isotropic decay t -> b + W etc for 4th generation q and l.
18624 WT=1D0
18625 WTMAX=1D0
18626
18627 ELSEIF(IREF(IP,7).EQ.25.OR.IREF(IP,7).EQ.35.OR.
18628 & IREF(IP,7).EQ.36) THEN
18629C...Angular weight for h0/A0 -> Z0 + Z0 or W+ + W- -> 4 quarks/leptons.
18630C...CP-odd case added by Kari Ertresvag Myklevoll.
18631C...Now also with mixed Higgs CP-states
18632 ETA=PARP(25)
18633 IF(IP.EQ.1) WTMAX=SH**2
18634 IF(IP.GE.2) WTMAX=P(IREF(IP,8),5)**4
18635 KFA=IABS(K(IREF(IP,1),2))
18636 KFT=IABS(K(IREF(IP,2),2))
18637
18638 IF((KFA.EQ.KFT).AND.(KFA.EQ.23.OR.KFA.EQ.24).AND.
18639 & MSTP(25).GE.3) THEN
18640C...For mixed CP states need epsilon product.
18641 P10=PK(3,4)
18642 P20=PK(4,4)
18643 P30=PK(5,4)
18644 P40=PK(6,4)
18645 P11=PK(3,1)
18646 P21=PK(4,1)
18647 P31=PK(5,1)
18648 P41=PK(6,1)
18649 P12=PK(3,2)
18650 P22=PK(4,2)
18651 P32=PK(5,2)
18652 P42=PK(6,2)
18653 P13=PK(3,3)
18654 P23=PK(4,3)
18655 P33=PK(5,3)
18656 P43=PK(6,3)
18657 EPSI=P10*P21*P32*P43-P10*P21*P33*P42-P10*P22*P31*P43+P10*P22*
18658 & P33*P41+P10*P23*P31*P42-P10*P23*P32*P41-P11*P20*P32*P43+P11*
18659 & P20*P33*P42+P11*P22*P30*P43-P11*P22*P33*P40-P11*P23*P30*P42+
18660 & P11*P23*P32*P40+P12*P20*P31*P43-P12*P20*P33*P41-P12*P21*P30*
18661 & P43+P12*P21*P33*P40+P12*P23*P30*P41-P12*P23*P31*P40-P13*P20*
18662 & P31*P42+P13*P20*P32*P41+P13*P21*P30*P42-P13*P21*P32*P40-P13*
18663 & P22*P30*P41+P13*P22*P31*P40
18664C...For mixed CP states need gauge boson masses.
18665 XMA=SQRT(MAX(0D0,(PK(3,4)+PK(4,4))**2-(PK(3,1)+PK(4,1))**2-
18666 & (PK(3,2)+PK(4,2))**2-(PK(3,3)+PK(4,3))**2))
18667 XMB=SQRT(MAX(0D0,(PK(5,4)+PK(6,4))**2-(PK(5,1)+PK(6,1))**2-
18668 & (PK(5,2)+PK(6,2))**2-(PK(5,3)+PK(6,3))**2))
18669 XMV=PMAS(KFA,1)
18670 ENDIF
18671
18672C...Z decay
18673 IF(KFA.EQ.23.AND.KFA.EQ.KFT) THEN
18674 KFLF1A=IABS(KFL1(1))
18675 EF1=KCHG(KFLF1A,1)/3D0
18676 AF1=SIGN(1D0,EF1+0.1D0)
18677 VF1=AF1-4D0*EF1*XWV
18678 KFLF2A=IABS(KFL1(2))
18679 EF2=KCHG(KFLF2A,1)/3D0
18680 AF2=SIGN(1D0,EF2+0.1D0)
18681 VF2=AF2-4D0*EF2*XWV
18682 VA12AS=4D0*VF1*AF1*VF2*AF2/((VF1**2+AF1**2)*(VF2**2+AF2**2))
18683 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18684 & THEN
18685C...CP-even decay
18686 WT=8D0*(1D0+VA12AS)*PKK(3,5)*PKK(4,6)+
18687 & 8D0*(1D0-VA12AS)*PKK(3,6)*PKK(4,5)
18688 ELSEIF(MSTP(25).LE.2) THEN
18689C...CP-odd decay
18690 WT=((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18691 & -2*PKK(3,4)*PKK(5,6)
18692 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18693 & (PKK(3,4)*PKK(5,6))
18694 & +VA12AS*(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18695 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))/(1+VA12AS)
18696 ELSE
18697C...Mixed CP states.
18698 WT=32D0*(0.25D0*((1D0+VA12AS)*PKK(3,5)*PKK(4,6)
18699 & +(1D0-VA12AS)*PKK(3,6)*PKK(4,5))
18700 & -0.5D0*ETA/XMV**2*EPSI*((1D0+VA12AS)*(PKK(3,5)+PKK(4,6))
18701 & -(1D0-VA12AS)*(PKK(3,6)+PKK(4,5)))
18702 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18703 & -2D0*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2
18704 & +PKK(3,4)*PKK(5,6)
18705 & *((PKK(3,5)+PKK(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18706 & +VA12AS*PKK(3,4)*PKK(5,6)
18707 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18708 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18709 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18710 & +2D0*(ETA*XMA*XMB/XMV**2)**2*(1D0+VA12AS))
18711 ENDIF
18712
18713C...W decay
18714 ELSEIF(KFA.EQ.24.AND.KFA.EQ.KFT) THEN
18715 IF((MSTP(25).EQ.0.AND.IREF(IP,7).NE.36).OR.MSTP(25).EQ.1)
18716 & THEN
18717C...CP-even decay
18718 WT=16D0*PKK(3,5)*PKK(4,6)
18719 ELSEIF(MSTP(25).LE.2) THEN
18720C...CP-odd decay
18721 WT=0.5D0*((PKK(3,5)+PKK(4,6))**2 +(PKK(3,6)+PKK(4,5))**2
18722 & -2*PKK(3,4)*PKK(5,6)
18723 & -2*(PKK(3,5)*PKK(4,6)-PKK(3,6)*PKK(4,5))**2/
18724 & (PKK(3,4)*PKK(5,6))
18725 & +(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))*
18726 & (PKK(3,5)+PKK(4,5)-PKK(3,6)-PKK(4,6)))
18727 ELSE
18728C...Mixed CP states.
18729 WT=32D0*(0.25D0*2D0*PKK(3,5)*PKK(4,6)
18730 & -0.5D0*ETA/XMV**2*EPSI*2D0*(PKK(3,5)+PKK(4,6))
18731 & +6.25D-2*ETA**2/XMV**4*(-2D0*PKK(3,4)**2*PKK(5,6)**2
18732 & -2D0*(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(4,6))**2+(PKK(3,6)+PKK(4,5))**2)
18735 & +PKK(3,4)*PKK(5,6)
18736 & *(PKK(3,5)+PKK(3,6)-PKK(4,5)-PKK(4,6))
18737 & *(PKK(3,5)-PKK(3,6)+PKK(4,5)-PKK(4,6))))
18738 & /(1D0 +2D0*ETA*XMA*XMB/XMV**2
18739 & +(2D0*ETA*XMA*XMB/XMV**2)**2)
18740 ENDIF
18741
18742C...No angular correlations in other Higgs decays.
18743 ELSE
18744 WT=WTMAX
18745 ENDIF
18746
18747 ELSEIF((KFAGM.EQ.6.OR.KFAGM.EQ.7.OR.KFAGM.EQ.8.OR.
18748 & KFAGM.EQ.17.OR.KFAGM.EQ.18).AND.IABS(K(IREF(IP,1),2)).EQ.24)
18749 & THEN
18750C...Angular correlation in f -> f' + W -> f' + 2 quarks/leptons.
18751 I1=IREF(IP,8)
18752 IF(MOD(KFAGM,2).EQ.0) THEN
18753 I2=N+1
18754 I3=N+2
18755 ELSE
18756 I2=N+2
18757 I3=N+1
18758 ENDIF
18759 I4=IREF(IP,2)
18760 WT=(P(I1,4)*P(I2,4)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
18761 & P(I1,3)*P(I2,3))*(P(I3,4)*P(I4,4)-P(I3,1)*P(I4,1)-
18762 & P(I3,2)*P(I4,2)-P(I3,3)*P(I4,3))
18763 WTMAX=(P(I1,5)**4-P(IREF(IP,1),5)**4)/8D0
18764
18765 ELSEIF(ISUB.EQ.1) THEN
18766C...Angular weight for gamma*/Z0 -> 2 quarks/leptons.
18767 EI=KCHG(IABS(MINT(15)),1)/3D0
18768 AI=SIGN(1D0,EI+0.1D0)
18769 VI=AI-4D0*EI*XWV
18770 EF=KCHG(IABS(KFL1(1)),1)/3D0
18771 AF=SIGN(1D0,EF+0.1D0)
18772
18773 VF=AF-4D0*EF*XWV
18774 RMF=MIN(1D0,4D0*PMAS(IABS(KFL1(1)),1)**2/SH)
18775 WT1=EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18776 & (VI**2+AI**2)*VINT(114)*(VF**2+(1D0-RMF)*AF**2)
18777 WT2=RMF*(EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18778 & (VI**2+AI**2)*VINT(114)*VF**2)
18779 WT3=SQRT(1D0-RMF)*(EI*AI*VINT(112)*EF*AF+
18780 & 4D0*VI*AI*VINT(114)*VF*AF)
18781 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
18782 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
18783 WTMAX=2D0*(WT1+ABS(WT3))
18784
18785 ELSEIF(ISUB.EQ.2) THEN
18786C...Angular weight for W+/- -> 2 quarks/leptons.
18787 RM3=PMAS(IABS(KFL1(1)),1)**2/SH
18788 RM4=PMAS(IABS(KFL2(1)),1)**2/SH
18789 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
18790 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
18791 WTMAX=4D0
18792
18793 ELSEIF(ISUB.EQ.15.OR.ISUB.EQ.19) THEN
18794C...Angular weight for f + fbar -> gluon/gamma + (gamma*/Z0) ->
18795C...-> gluon/gamma + 2 quarks/leptons.
18796 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18797 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18798 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18799 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18800 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18801 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18802 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18803 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18804 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18805 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18806 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18807 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18808 WT=(CLILF+CRIRF)*(PKK(1,3)**2+PKK(2,4)**2)+
18809 & (CLIRF+CRILF)*(PKK(1,4)**2+PKK(2,3)**2)
18810 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18811 & ((PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2)
18812
18813 ELSEIF(ISUB.EQ.16.OR.ISUB.EQ.20) THEN
18814C...Angular weight for f + fbar' -> gluon/gamma + W+/- ->
18815C...-> gluon/gamma + 2 quarks/leptons.
18816 WT=PKK(1,3)**2+PKK(2,4)**2
18817 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(2,3)+PKK(2,4))**2
18818
18819 ELSEIF(ISUB.EQ.22) THEN
18820C...Angular weight for f + fbar -> Z0 + Z0 -> 4 quarks/leptons.
18821 S34=P(IREF(IP,IORD),5)**2
18822 S56=P(IREF(IP,3-IORD),5)**2
18823 TI=PKK(1,3)+PKK(1,4)+S34
18824 UI=PKK(1,5)+PKK(1,6)+S56
18825 TIR=REAL(TI)
18826 UIR=REAL(UI)
18827 FGK135=ABS(FGK(1,2,3,4,5,6)/TIR+FGK(1,2,5,6,3,4)/UIR)**2
18828 FGK145=ABS(FGK(1,2,4,3,5,6)/TIR+FGK(1,2,5,6,4,3)/UIR)**2
18829 FGK136=ABS(FGK(1,2,3,4,6,5)/TIR+FGK(1,2,6,5,3,4)/UIR)**2
18830 FGK146=ABS(FGK(1,2,4,3,6,5)/TIR+FGK(1,2,6,5,4,3)/UIR)**2
18831 FGK253=ABS(FGK(2,1,5,6,3,4)/TIR+FGK(2,1,3,4,5,6)/UIR)**2
18832 FGK263=ABS(FGK(2,1,6,5,3,4)/TIR+FGK(2,1,3,4,6,5)/UIR)**2
18833 FGK254=ABS(FGK(2,1,5,6,4,3)/TIR+FGK(2,1,4,3,5,6)/UIR)**2
18834 FGK264=ABS(FGK(2,1,6,5,4,3)/TIR+FGK(2,1,4,3,6,5)/UIR)**2
18835
18836 WT=
18837 & CORL(1,1,1)*CORL(2,1,1)*FGK135+CORL(1,1,2)*CORL(2,1,1)*FGK145+
18838 & CORL(1,1,1)*CORL(2,1,2)*FGK136+CORL(1,1,2)*CORL(2,1,2)*FGK146+
18839 & CORL(1,2,1)*CORL(2,2,1)*FGK253+CORL(1,2,2)*CORL(2,2,1)*FGK263+
18840 & CORL(1,2,1)*CORL(2,2,2)*FGK254+CORL(1,2,2)*CORL(2,2,2)*FGK264
18841 WTMAX=16D0*((CORL(1,1,1)+CORL(1,1,2))*(CORL(2,1,1)+CORL(2,1,2))+
18842 & (CORL(1,2,1)+CORL(1,2,2))*(CORL(2,2,1)+CORL(2,2,2)))*S34*S56*
18843 & ((TI**2+UI**2+2D0*SH*(S34+S56))/(TI*UI)-S34*S56*(1D0/TI**2+
18844 & 1D0/UI**2))
18845
18846 ELSEIF(ISUB.EQ.23) THEN
18847C...Angular weight for f + fbar' -> Z0 + W+/- -> 4 quarks/leptons.
18848 D34=P(IREF(IP,IORD),5)**2
18849 D56=P(IREF(IP,3-IORD),5)**2
18850 DT=PKK(1,3)+PKK(1,4)+D34
18851 DU=PKK(1,5)+PKK(1,6)+D56
18852 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
18853 CAWZ=COUP(2,3)/DT-2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18854 CBWZ=COUP(1,3)/DU+2D0*XW1*COUP(1,2)*(SH-SQMW)*FACBW
18855 FGK135=ABS(REAL(CAWZ)*FGK(1,2,3,4,5,6)+
18856
18857 & REAL(CBWZ)*FGK(1,2,5,6,3,4))
18858 FGK136=ABS(REAL(CAWZ)*FGK(1,2,3,4,6,5)+
18859 & REAL(CBWZ)*FGK(1,2,6,5,3,4))
18860 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
18861 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*(CAWZ**2*
18862 & DIGK(DT,DU)+CBWZ**2*DIGK(DU,DT)+CAWZ*CBWZ*DJGK(DT,DU))
18863
18864 ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.171.OR.ISUB.EQ.176) THEN
18865C...Angular weight for f + fbar -> Z0 + h0 -> 2 quarks/leptons + h0
18866C...(or H0, or A0).
18867 WT=((COUP(1,3)*COUP(3,3))**2+(COUP(1,4)*COUP(3,4))**2)*
18868 & PKK(1,3)*PKK(2,4)+((COUP(1,3)*COUP(3,4))**2+(COUP(1,4)*
18869 & COUP(3,3))**2)*PKK(1,4)*PKK(2,3)
18870 WTMAX=(COUP(1,3)**2+COUP(1,4)**2)*(COUP(3,3)**2+COUP(3,4)**2)*
18871 & (PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18872
18873 ELSEIF(ISUB.EQ.25) THEN
18874C...Angular weight for f + fbar -> W+ + W- -> 4 quarks/leptons.
18875 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
18876 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
18877 D34=P(IREF(IP,IORD),5)**2
18878 D56=P(IREF(IP,3-IORD),5)**2
18879 DT=PKK(1,3)+PKK(1,4)+D34
18880 DU=PKK(1,5)+PKK(1,6)+D56
18881 FACBW=1D0/((SH-SQMZ)**2+SQMZ*PMAS(23,2)**2)
18882 CDWW=(COUP(1,3)*SQMZ*(SH-SQMZ)*FACBW+COUP(1,2))/SH
18883 CAWW=CDWW+0.5D0*(COUP(1,2)+1D0)/DT
18884 CBWW=CDWW+0.5D0*(COUP(1,2)-1D0)/DU
18885 CCWW=COUP(1,4)*SQMZ*(SH-SQMZ)*FACBW/SH
18886 FGK135=ABS(REAL(CAWW)*FGK(1,2,3,4,5,6)-
18887 & REAL(CBWW)*FGK(1,2,5,6,3,4))
18888 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
18889 IF(MSTP(50).LE.0) THEN
18890 WT=FGK135**2+(CCWW*FGK253)**2
18891 WTMAX=4D0*D34*D56*(CAWW**2*DIGK(DT,DU)+CBWW**2*DIGK(DU,DT)-
18892 & CAWW*CBWW*DJGK(DT,DU)+CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-
18893 & DJGK(DT,DU)))
18894 ELSE
18895 WT=POLL*FGK135**2+POLR*(CCWW*FGK253)**2
18896 WTMAX=4D0*D34*D56*(POLL*(CAWW**2*DIGK(DT,DU)+
18897 & CBWW**2*DIGK(DU,DT)-CAWW*CBWW*DJGK(DT,DU))+
18898 & POLR*CCWW**2*(DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU)))
18899 ENDIF
18900
18901 ELSEIF(ISUB.EQ.26.OR.ISUB.EQ.172.OR.ISUB.EQ.177) THEN
18902C...Angular weight for f + fbar' -> W+/- + h0 -> 2 quarks/leptons + h0
18903C...(or H0, or A0).
18904 WT=PKK(1,3)*PKK(2,4)
18905 WTMAX=(PKK(1,3)+PKK(1,4))*(PKK(2,3)+PKK(2,4))
18906
18907 ELSEIF(ISUB.EQ.30.OR.ISUB.EQ.35) THEN
18908C...Angular weight for f + g/gamma -> f + (gamma*/Z0)
18909C...-> f + 2 quarks/leptons.
18910 CLILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18911 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18912 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,3)**2
18913 CLIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18914 & COUP(1,1)*COUP(1,3)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18915 & COUP(1,3)**2*HGZ(JTZ,3)*COUP(3,4)**2
18916 CRILF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18917 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,3)/4D0+
18918 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,3)**2
18919 CRIRF=COUP(1,1)**2*HGZ(JTZ,1)*COUP(3,1)**2/16D0+
18920 & COUP(1,1)*COUP(1,4)*HGZ(JTZ,2)*COUP(3,1)*COUP(3,4)/4D0+
18921 & COUP(1,4)**2*HGZ(JTZ,3)*COUP(3,4)**2
18922 IF(K(ILIN(1),2).GT.0) WT=(CLILF+CRIRF)*(PKK(1,4)**2+
18923 & PKK(3,5)**2)+(CLIRF+CRILF)*(PKK(1,3)**2+PKK(4,5)**2)
18924 IF(K(ILIN(1),2).LT.0) WT=(CLILF+CRIRF)*(PKK(1,3)**2+
18925 & PKK(4,5)**2)+(CLIRF+CRILF)*(PKK(1,4)**2+PKK(3,5)**2)
18926 WTMAX=(CLILF+CLIRF+CRILF+CRIRF)*
18927 & ((PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2)
18928
18929 ELSEIF(ISUB.EQ.31.OR.ISUB.EQ.36) THEN
18930C...Angular weight for f + g/gamma -> f' + W+/- -> f' + 2 fermions.
18931 IF(K(ILIN(1),2).GT.0) WT=PKK(1,4)**2+PKK(3,5)**2
18932 IF(K(ILIN(1),2).LT.0) WT=PKK(1,3)**2+PKK(4,5)**2
18933 WTMAX=(PKK(1,3)+PKK(1,4))**2+(PKK(3,5)+PKK(4,5))**2
18934
18935 ELSEIF(ISUB.EQ.71.OR.ISUB.EQ.72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.
18936 & ISUB.EQ.77) THEN
18937C...Angular weight for V_L1 + V_L2 -> V_L3 + V_L4 (V = Z/W).
18938 WT=16D0*PKK(3,5)*PKK(4,6)
18939 WTMAX=SH**2
18940
18941 ELSEIF(ISUB.EQ.110) THEN
18942C...Angular weight for f + fbar -> gamma + h0 -> gamma + X is isotropic.
18943 WT=1D0
18944 WTMAX=1D0
18945
18946 ELSEIF(ISUB.EQ.141) THEN
18947C...Special case: if only branching ratios known then isotropic decay.
18948 IF(MWID(32).EQ.2) THEN
18949 WT=1D0
18950 WTMAX=1D0
18951 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
18952C...Angular weight for f + fbar -> gamma*/Z0/Z'0 -> 2 quarks/leptons.
18953C...Couplings of incoming flavour.
18954 KFAI=IABS(MINT(15))
18955 EI=KCHG(KFAI,1)/3D0
18956 AI=SIGN(1D0,EI+0.1D0)
18957 VI=AI-4D0*EI*XWV
18958 KFAIC=1
18959 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
18960 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
18961 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
18962 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
18963 VPI=PARU(119+2*KFAIC)
18964 API=PARU(120+2*KFAIC)
18965 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
18966 VPI=PARJ(178+2*KFAIC)
18967 API=PARJ(179+2*KFAIC)
18968 ELSE
18969 VPI=PARJ(186+2*KFAIC)
18970 API=PARJ(187+2*KFAIC)
18971 ENDIF
18972C...Couplings of final flavour.
18973 KFAF=IABS(KFL1(1))
18974 EF=KCHG(KFAF,1)/3D0
18975 AF=SIGN(1D0,EF+0.1D0)
18976 VF=AF-4D0*EF*XWV
18977 KFAFC=1
18978 IF(KFAF.LE.10.AND.MOD(KFAF,2).EQ.0) KFAFC=2
18979 IF(KFAF.GT.10.AND.MOD(KFAF,2).NE.0) KFAFC=3
18980 IF(KFAF.GT.10.AND.MOD(KFAF,2).EQ.0) KFAFC=4
18981 IF(KFAF.LE.2.OR.KFAF.EQ.11.OR.KFAF.EQ.12) THEN
18982 VPF=PARU(119+2*KFAFC)
18983 APF=PARU(120+2*KFAFC)
18984 ELSEIF(KFAF.LE.4.OR.KFAF.EQ.13.OR.KFAF.EQ.14) THEN
18985 VPF=PARJ(178+2*KFAFC)
18986 APF=PARJ(179+2*KFAFC)
18987 ELSE
18988 VPF=PARJ(186+2*KFAFC)
18989 APF=PARJ(187+2*KFAFC)
18990 ENDIF
18991C...Asymmetry and weight.
18992 ASYM=2D0*(EI*AI*VINT(112)*EF*AF+EI*API*VINT(113)*EF*APF+
18993 & 4D0*VI*AI*VINT(114)*VF*AF+(VI*API+VPI*AI)*VINT(115)*
18994 & (VF*APF+VPF*AF)+4D0*VPI*API*VINT(116)*VPF*APF)/
18995 & (EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*EF*VF+
18996 & EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
18997 & (VF**2+AF**2)+(VI*VPI+AI*API)*VINT(115)*(VF*VPF+AF*APF)+
18998 & (VPI**2+API**2)*VINT(116)*(VPF**2+APF**2))
18999 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
19000 WTMAX=2D0+ABS(ASYM)
19001 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).EQ.24) THEN
19002C...Angular weight for f + fbar -> Z' -> W+ + W-.
19003 RM1=P(NSD(1)+1,5)**2/SH
19004 RM2=P(NSD(1)+2,5)**2/SH
19005 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
19006 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
19007 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
19008 & (RM2-RM1)**2)
19009 WT=CFLAT+CCOS2*CTHE(1)**2
19010 WTMAX=CFLAT+MAX(0D0,CCOS2)
19011 ELSEIF(IP.EQ.1.AND.(KFL1(1).EQ.25.OR.KFL1(1).EQ.35.OR.
19012 & IABS(KFL1(1)).EQ.37)) THEN
19013C...Angular weight for f + fbar -> Z' -> h0 + A0, H0 + A0, H+ + H-.
19014 WT=1D0-CTHE(1)**2
19015 WTMAX=1D0
19016 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
19017C...Angular weight for f + fbar -> Z' -> Z0 + h0.
19018 RM1=P(NSD(1)+1,5)**2/SH
19019 RM2=P(NSD(1)+2,5)**2/SH
19020 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
19021 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
19022 WTMAX=1D0+FLAM2/(8D0*RM1)
19023 ELSEIF(MZPWP.EQ.0) THEN
19024C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
19025C...(W:s like if intermediate Z).
19026 D34=P(IREF(IP,IORD),5)**2
19027 D56=P(IREF(IP,3-IORD),5)**2
19028 DT=PKK(1,3)+PKK(1,4)+D34
19029 DU=PKK(1,5)+PKK(1,6)+D56
19030 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
19031 FGK253=ABS(FGK(2,1,5,6,3,4)-FGK(2,1,3,4,5,6))
19032 WT=(COUP(1,3)*FGK135)**2+(COUP(1,4)*FGK253)**2
19033 WTMAX=4D0*D34*D56*(COUP(1,3)**2+COUP(1,4)**2)*
19034 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
19035 ELSEIF(MZPWP.EQ.1) THEN
19036C...Angular weight for f + fbar -> Z' -> W+ + W- -> 4 quarks/leptons
19037C...(W:s approximately longitudinal, like if intermediate H).
19038 WT=16D0*PKK(3,5)*PKK(4,6)
19039 WTMAX=SH**2
19040 ELSE
19041C...Angular weight for f + fbar -> Z' -> H+ + H-, Z0 + h0, h0 + A0,
19042C...H0 + A0 -> 4 quarks/leptons, t + tbar -> b + W+ + bbar + W- .
19043 WT=1D0
19044 WTMAX=1D0
19045 ENDIF
19046
19047 ELSEIF(ISUB.EQ.142) THEN
19048C...Special case: if only branching ratios known then isotropic decay.
19049 IF(MWID(34).EQ.2) THEN
19050 WT=1D0
19051 WTMAX=1D0
19052 ELSEIF(IP.EQ.1.AND.IABS(KFL1(1)).LT.20) THEN
19053C...Angular weight for f + fbar' -> W'+/- -> 2 quarks/leptons.
19054 KFAI=IABS(MINT(15))
19055 KFAIC=1
19056 IF(KFAI.GT.10) KFAIC=2
19057 VI=PARU(129+2*KFAIC)
19058 AI=PARU(130+2*KFAIC)
19059 KFAF=IABS(KFL1(1))
19060 KFAFC=1
19061 IF(KFAF.GT.10) KFAFC=2
19062 VF=PARU(129+2*KFAFC)
19063 AF=PARU(130+2*KFAFC)
19064 ASYM=8D0*VI*AI*VF*AF/((VI**2+AI**2)*(VF**2+AF**2))
19065 WT=1D0+ASYM*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))+CTHE(1)**2
19066 WTMAX=2D0+ABS(ASYM)
19067 ELSEIF(IP.EQ.1.AND.IABS(KFL2(1)).EQ.23) THEN
19068C...Angular weight for f + fbar' -> W'+/- -> W+/- + Z0.
19069 RM1=P(NSD(1)+1,5)**2/SH
19070 RM2=P(NSD(1)+2,5)**2/SH
19071 CCOS2=-(1D0/16D0)*((1D0-RM1-RM2)**2-4D0*RM1*RM2)*
19072 & (1D0-2D0*RM1-2D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
19073 CFLAT=-CCOS2+0.5D0*(RM1+RM2)*(1D0-2D0*RM1-2D0*RM2+
19074 & (RM2-RM1)**2)
19075 WT=CFLAT+CCOS2*CTHE(1)**2
19076 WTMAX=CFLAT+MAX(0D0,CCOS2)
19077 ELSEIF(IP.EQ.1.AND.KFL2(1).EQ.25) THEN
19078C...Angular weight for f + fbar -> W'+/- -> W+/- + h0.
19079 RM1=P(NSD(1)+1,5)**2/SH
19080 RM2=P(NSD(1)+2,5)**2/SH
19081 FLAM2=MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2)
19082 WT=1D0+FLAM2*(1D0-CTHE(1)**2)/(8D0*RM1)
19083 WTMAX=1D0+FLAM2/(8D0*RM1)
19084 ELSEIF(MZPWP.EQ.0) THEN
19085C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
19086C...(W/Z like if intermediate W).
19087 D34=P(IREF(IP,IORD),5)**2
19088 D56=P(IREF(IP,3-IORD),5)**2
19089 DT=PKK(1,3)+PKK(1,4)+D34
19090 DU=PKK(1,5)+PKK(1,6)+D56
19091 FGK135=ABS(FGK(1,2,3,4,5,6)-FGK(1,2,5,6,3,4))
19092 FGK136=ABS(FGK(1,2,3,4,6,5)-FGK(1,2,6,5,3,4))
19093 WT=(COUP(5,3)*FGK135)**2+(COUP(5,4)*FGK136)**2
19094 WTMAX=4D0*D34*D56*(COUP(5,3)**2+COUP(5,4)**2)*
19095 & (DIGK(DT,DU)+DIGK(DU,DT)-DJGK(DT,DU))
19096 ELSEIF(MZPWP.EQ.1) THEN
19097C...Angular weight for f + fbar' -> W' -> W + Z0 -> 4 quarks/leptons
19098C...(W/Z approximately longitudinal, like if intermediate H).
19099 WT=16D0*PKK(3,5)*PKK(4,6)
19100 WTMAX=SH**2
19101 ELSE
19102C...Angular weight for f + fbar -> W' -> W + h0 -> whatever,
19103C...t + bbar -> t + W + bbar.
19104 WT=1D0
19105 WTMAX=1D0
19106 ENDIF
19107
19108 ELSEIF(ISUB.EQ.145.OR.ISUB.EQ.162.OR.ISUB.EQ.163.OR.ISUB.EQ.164)
19109 & THEN
19110C...Isotropic decay of leptoquarks (assumed spin 0).
19111 WT=1D0
19112 WTMAX=1D0
19113
19114 ELSEIF(ISUB.GE.146.AND.ISUB.LE.148) THEN
19115C...Decays of (spin 1/2) q*/e* -> q/e + (g,gamma) or (Z0,W+-).
19116 SIDE=1D0
19117 IF(MINT(16).EQ.21.OR.MINT(16).EQ.22) SIDE=-1D0
19118 IF(IP.EQ.1.AND.(KFL1(1).EQ.21.OR.KFL1(1).EQ.22)) THEN
19119 WT=1D0+SIDE*CTHE(1)
19120 WTMAX=2D0
19121 ELSEIF(IP.EQ.1) THEN
19122
19123 RM1=P(NSD(1)+1,5)**2/SH
19124 WT=1D0+SIDE*CTHE(1)*(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
19125 WTMAX=1D0+(1D0-0.5D0*RM1)/(1D0+0.5D0*RM1)
19126 ELSE
19127C...W/Z decay assumed isotropic, since not known.
19128 WT=1D0
19129 WTMAX=1D0
19130 ENDIF
19131
19132 ELSEIF(ISUB.EQ.149) THEN
19133C...Isotropic decay of techni-eta.
19134 WT=1D0
19135 WTMAX=1D0
19136
19137 ELSEIF(ISUB.EQ.191) THEN
19138 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
19139C...Angular weight for f + fbar -> rho_tc0 -> W+ W-,
19140C...W+ pi_tc-, pi_tc+ W- or pi_tc+ pi_tc-.
19141 WT=1D0-CTHE(1)**2
19142 WTMAX=1D0
19143 ELSEIF(IP.EQ.1) THEN
19144C...Angular weight for f + fbar -> rho_tc0 -> f fbar.
19145 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
19146 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
19147 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19148 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19149 KFAI=IABS(MINT(15))
19150 EI=KCHG(KFAI,1)/3D0
19151 AI=SIGN(1D0,EI+0.1D0)
19152 VI=AI-4D0*EI*XWV
19153 VALI=0.5D0*(VI+AI)
19154 VARI=0.5D0*(VI-AI)
19155 ALEFTI=(EI+VALI*BWZR)**2+(VALI*BWZI)**2
19156 ARIGHI=(EI+VARI*BWZR)**2+(VARI*BWZI)**2
19157 KFAF=IABS(KFL1(1))
19158 EF=KCHG(KFAF,1)/3D0
19159 AF=SIGN(1D0,EF+0.1D0)
19160 VF=AF-4D0*EF*XWV
19161 VALF=0.5D0*(VF+AF)
19162 VARF=0.5D0*(VF-AF)
19163 ALEFTF=(EF+VALF*BWZR)**2+(VALF*BWZI)**2
19164 ARIGHF=(EF+VARF*BWZR)**2+(VARF*BWZI)**2
19165 ASAME=ALEFTI*ALEFTF+ARIGHI*ARIGHF
19166 AFLIP=ALEFTI*ARIGHF+ARIGHI*ALEFTF
19167 WT=ASAME*(1D0+CTHESG)**2+AFLIP*(1D0-CTHESG)**2
19168 WTMAX=4D0*MAX(ASAME,AFLIP)
19169 ELSE
19170C...Isotropic decay of W/pi_tc produced in rho_tc decay.
19171 WT=1D0
19172 WTMAX=1D0
19173 ENDIF
19174
19175 ELSEIF(ISUB.EQ.192) THEN
19176 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
19177C...Angular weight for f + fbar' -> rho_tc+ -> W+ Z0,
19178C...W+ pi_tc0, pi_tc+ Z0 or pi_tc+ pi_tc0.
19179 WT=1D0-CTHE(1)**2
19180 WTMAX=1D0
19181 ELSEIF(IP.EQ.1) THEN
19182C...Angular weight for f + fbar' -> rho_tc+ -> f fbar'.
19183 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
19184 WT=(1D0+CTHESG)**2
19185 WTMAX=4D0
19186 ELSE
19187C...Isotropic decay of W/Z/pi_tc produced in rho_tc+ decay.
19188 WT=1D0
19189 WTMAX=1D0
19190 ENDIF
19191
19192 ELSEIF(ISUB.EQ.193) THEN
19193 IF(IP.EQ.1.AND.IABS(KFL1(1)).GT.21) THEN
19194C...Angular weight for f + fbar -> omega_tc0 ->
19195C...gamma pi_tc0 or Z0 pi_tc0.
19196 WT=1D0+CTHE(1)**2
19197 WTMAX=2D0
19198 ELSEIF(IP.EQ.1) THEN
19199C...Angular weight for f + fbar -> omega_tc0 -> f fbar.
19200 CTHESG=CTHE(1)*ISIGN(1,MINT(15))
19201 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
19202 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
19203 KFAI=IABS(MINT(15))
19204 EI=KCHG(KFAI,1)/3D0
19205 AI=SIGN(1D0,EI+0.1D0)
19206 VI=AI-4D0*EI*XWV
19207 VALI=0.5D0*(VI+AI)
19208 VARI=0.5D0*(VI-AI)
19209 BLEFTI=(EI-VALI*BWZR)**2+(VALI*BWZI)**2
19210 BRIGHI=(EI-VARI*BWZR)**2+(VARI*BWZI)**2
19211 KFAF=IABS(KFL1(1))
19212 EF=KCHG(KFAF,1)/3D0
19213 AF=SIGN(1D0,EF+0.1D0)
19214 VF=AF-4D0*EF*XWV
19215 VALF=0.5D0*(VF+AF)
19216 VARF=0.5D0*(VF-AF)
19217 BLEFTF=(EF-VALF*BWZR)**2+(VALF*BWZI)**2
19218 BRIGHF=(EF-VARF*BWZR)**2+(VARF*BWZI)**2
19219 BSAME=BLEFTI*BLEFTF+BRIGHI*BRIGHF
19220 BFLIP=BLEFTI*BRIGHF+BRIGHI*BLEFTF
19221 WT=BSAME*(1D0+CTHESG)**2+BFLIP*(1D0-CTHESG)**2
19222 WTMAX=4D0*MAX(BSAME,BFLIP)
19223 ELSE
19224C...Isotropic decay of Z/pi_tc produced in omega_tc decay.
19225 WT=1D0
19226 WTMAX=1D0
19227 ENDIF
19228
19229 ELSEIF(ISUB.EQ.353) THEN
19230C...Angular weight for Z_R0 -> 2 quarks/leptons.
19231 EI=KCHG(IABS(MINT(15)),1)/3D0
19232 AI=SIGN(1D0,EI+0.1D0)
19233 VI=AI-4D0*EI*XWV
19234 EF=KCHG(PYCOMP(KFL1(1)),1)/3D0
19235 AF=SIGN(1D0,EF+0.1D0)
19236 VF=AF-4D0*EF*XWV
19237 RMF=MIN(1D0,4D0*PMAS(PYCOMP(KFL1(1)),1)**2/SH)
19238 WT1=(VI**2+AI**2)*(VF**2+(1D0-RMF)*AF**2)
19239 WT2=RMF*(VI**2+AI**2)*VF**2
19240 WT3=SQRT(1D0-RMF)*4D0*VI*AI*VF*AF
19241 WT=WT1*(1D0+CTHE(1)**2)+WT2*(1D0-CTHE(1)**2)+
19242 & 2D0*WT3*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1))
19243 WTMAX=2D0*(WT1+ABS(WT3))
19244
19245 ELSEIF(ISUB.EQ.354) THEN
19246C...Angular weight for W_R+/- -> 2 quarks/leptons.
19247 RM3=PMAS(PYCOMP(KFL1(1)),1)**2/SH
19248 RM4=PMAS(PYCOMP(KFL2(1)),1)**2/SH
19249 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19250 WT=(1D0+BE34*CTHE(1)*ISIGN(1,MINT(15)*KFL1(1)))**2-(RM3-RM4)**2
19251 WTMAX=4D0
19252
19253 ELSEIF(ISUB.EQ.391) THEN
19254C...Angular weight for f + fbar -> G* -> f + fbar
19255 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
19256 WT=1D0-3D0*CTHE(1)**2+4D0*CTHE(1)**4
19257 WTMAX=2D0
19258C...Angular weight for f + fbar -> G* -> gamma + gamma or g + g
19259C...implemented by M.-C. Lemaire
19260 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
19261 & IABS(KFL1(1)).EQ.22)) THEN
19262 WT=1D0-CTHE(1)**4
19263 WTMAX=1D0
19264C...Other G* decays not yet implemented angular distributions.
19265 ELSE
19266 WT=1D0
19267 WTMAX=1D0
19268 ENDIF
19269
19270 ELSEIF(ISUB.EQ.392) THEN
19271C...Angular weight for g + g -> G* -> f + fbar
19272 IF(IP.EQ.1.AND.IABS(KFL1(1)).LE.18) THEN
19273 WT=1D0-CTHE(1)**4
19274 WTMAX=1D0
19275C...Angular weight for g + g -> G* -> gamma +gamma or g + g
19276C...implemented by M.-C. Lemaire
19277 ELSEIF(IP.EQ.1.AND.(IABS(KFL1(1)).EQ.21.OR.
19278 & IABS(KFL1(1)).EQ.22)) THEN
19279 WT=1D0+6D0*CTHE(1)**2+CTHE(1)**4
19280 WTMAX=8D0
19281C...Other G* decays not yet implemented angular distributions.
19282 ELSE
19283 WT=1D0
19284 WTMAX=1D0
19285 ENDIF
19286
19287C...Obtain correct angular distribution by rejection techniques.
19288 ELSE
19289 WT=1D0
19290 WTMAX=1D0
19291 ENDIF
19292 IF(WT.LT.PYR(0)*WTMAX) GOTO 430
19293
19294C...Construct massive four-vectors using angles chosen.
19295 590 DO 690 JT=1,JTMAX
19296 IF(KDCY(JT).EQ.0) GOTO 690
19297 ID=IREF(IP,JT)
19298 DO 600 J=1,5
19299 DPMO(J)=P(ID,J)
19300 600 CONTINUE
19301 DPMO(4)=SQRT(DPMO(1)**2+DPMO(2)**2+DPMO(3)**2+DPMO(5)**2)
19302CMRENNA++
19303 NPROD=2
19304 IF(KFL3(JT).NE.0) NPROD=3
19305 IF(KFL4(JT).NE.0) NPROD=4
19306 CALL PYROBO(NSD(JT)+1,NSD(JT)+NPROD,ACOS(CTHE(JT)),PHI(JT),
19307 & DPMO(1)/DPMO(4),DPMO(2)/DPMO(4),DPMO(3)/DPMO(4))
19308 N0=NSD(JT)+NPROD
19309
19310 DO 610 J=1,4
19311 VDCY(J)=V(ID,J)+V(ID,5)*P(ID,J)/P(ID,5)
19312 610 CONTINUE
19313C...Fill in position of decay vertex.
19314 DO 630 I=NSD(JT)+1,N0
19315 DO 620 J=1,4
19316 V(I,J)=VDCY(J)
19317 620 CONTINUE
19318 V(I,5)=0D0
19319
19320 630 CONTINUE
19321CMRENNA--
19322
19323C...Mark decayed resonances; trace history.
19324 K(ID,1)=K(ID,1)+10
19325 KFA=IABS(K(ID,2))
19326 KCA=PYCOMP(KFA)
19327 IF(KCQM(JT).NE.0) THEN
19328C...Do not kill colour flow through coloured resonance!
19329 ELSE
19330 K(ID,4)=NSD(JT)+1
19331 K(ID,5)=NSD(JT)+NPROD
19332 IF(ITJUNC(JT).NE.0) K(ID,5)=K(ID,5)+1
19333C...If 3-body or 2-body with junction:
19334c IF(KFL3(JT).NE.0.OR.ITJUNC(JT).NE.0) K(ID,5)=NSD(JT)+3
19335C...If 3-body with junction:
19336c IF(ITJUNC(JT).NE.0.AND.KFL3(JT).NE.0) K(ID,5)=NSD(JT)+4
19337 ENDIF
19338
19339C...Add documentation lines.
19340 ISUBRG=MAX(1,MIN(500,MINT(1)))
19341 IF(IRES.EQ.0.OR.ISET(ISUBRG).EQ.11) THEN
19342 IDOC=MINT(83)+MINT(4)
19343CMRENNA+++
19344 IHI=NSD(JT)+NPROD
19345c IF(KFL3(JT).NE.0) IHI=IHI+1
19346 DO 650 I=NSD(JT)+1,IHI
19347CMRENNA---
19348 I1=MINT(83)+MINT(4)+1
19349 K(I,3)=I1
19350 IF(MSTP(128).GE.1) K(I,3)=ID
19351 IF(MSTP(128).LE.1.AND.MINT(4).LT.MSTP(126)) THEN
19352 MINT(4)=MINT(4)+1
19353 K(I1,1)=21
19354 K(I1,2)=K(I,2)
19355 K(I1,3)=IREF(IP,JT+3)
19356 DO 640 J=1,5
19357 P(I1,J)=P(I,J)
19358 640 CONTINUE
19359 ENDIF
19360 650 CONTINUE
19361 ELSE
19362 K(NSD(JT)+1,3)=ID
19363 K(NSD(JT)+2,3)=ID
19364C...If 3-body or 2-body with junction:
19365 IF(KFL3(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+3,3)=ID
19366C...If 3-body with junction:
19367 IF(KFL3(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
19368C...If 4-body or 3-body with junction:
19369 IF(KFL4(JT).NE.0.OR.ITJUNC(JT).GT.0) K(NSD(JT)+4,3)=ID
19370C...If 4-body with junction:
19371 IF(KFL4(JT).NE.0.AND.ITJUNC(JT).GT.0) K(NSD(JT)+5,3)=ID
19372 ENDIF
19373
19374C...Do showering of two or three objects.
19375 NSHBEF=N
19376 IF(MSTP(71).GE.1.AND.MINT(35).LE.1) THEN
19377 IF(KFL3(JT).EQ.0) THEN
19378 CALL PYSHOW(NSD(JT)+1,NSD(JT)+2,P(ID,5))
19379 ELSE
19380 CALL PYSHOW(NSD(JT)+1,-NPROD,P(ID,5))
19381 ENDIF
19382
19383c...For pT-ordered shower need set up first, especially colour tags.
19384C...(Need to set up colour tags even if MSTP(71) = 0)
19385 ELSEIF(MINT(35).GE.2) THEN
19386 NPART=NPROD
19387c IF(KFL3(JT).NE.0) NPART=3
19388 IPART(1)=NSD(JT)+1
19389 IPART(2)=NSD(JT)+2
19390 IPART(3)=NSD(JT)+3
19391 IPART(4)=NSD(JT)+4
19392 PTPART(1)=0.5D0*P(ID,5)
19393 PTPART(2)=PTPART(1)
19394 PTPART(3)=PTPART(1)
19395 PTPART(4)=PTPART(1)
19396 IF(KCQ1(JT).EQ.1.OR.KCQ1(JT).EQ.2) THEN
19397 MOTHER=K(NSD(JT)+1,4)/MSTU(5)
19398 IF(MOTHER.LE.NSD(JT)) THEN
19399 MCT(NSD(JT)+1,1)=MCT(MOTHER,1)
19400 ELSE
19401 NCT=NCT+1
19402 MCT(NSD(JT)+1,1)=NCT
19403 MCT(MOTHER,2)=NCT
19404 ENDIF
19405 ENDIF
19406 IF(KCQ1(JT).EQ.-1.OR.KCQ1(JT).EQ.2) THEN
19407 MOTHER=K(NSD(JT)+1,5)/MSTU(5)
19408 IF(MOTHER.LE.NSD(JT)) THEN
19409 MCT(NSD(JT)+1,2)=MCT(MOTHER,2)
19410 ELSE
19411 NCT=NCT+1
19412 MCT(NSD(JT)+1,2)=NCT
19413 MCT(MOTHER,1)=NCT
19414 ENDIF
19415 ENDIF
19416 IF(MCT(NSD(JT)+2,1).EQ.0.AND.(KCQ2(JT).EQ.1.OR.
19417 & KCQ2(JT).EQ.2)) THEN
19418 MOTHER=K(NSD(JT)+2,4)/MSTU(5)
19419 IF(MOTHER.LE.NSD(JT)) THEN
19420 MCT(NSD(JT)+2,1)=MCT(MOTHER,1)
19421 ELSE
19422 NCT=NCT+1
19423 MCT(NSD(JT)+2,1)=NCT
19424 MCT(MOTHER,2)=NCT
19425 ENDIF
19426 ENDIF
19427 IF(MCT(NSD(JT)+2,2).EQ.0.AND.(KCQ2(JT).EQ.-1.OR.
19428 & KCQ2(JT).EQ.2)) THEN
19429 MOTHER=K(NSD(JT)+2,5)/MSTU(5)
19430 IF(MOTHER.LE.NSD(JT)) THEN
19431 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
19432 ELSE
19433 NCT=NCT+1
19434 MCT(NSD(JT)+2,2)=NCT
19435 MCT(MOTHER,1)=NCT
19436 ENDIF
19437 ENDIF
19438 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,1).EQ.0.AND.
19439 & (KCQ3(JT).EQ.1.OR. KCQ3(JT).EQ.2)) THEN
19440 MOTHER=K(NSD(JT)+3,4)/MSTU(5)
19441 MCT(NSD(JT)+3,1)=MCT(MOTHER,1)
19442 ENDIF
19443 IF(NPART.EQ.3.AND.MCT(NSD(JT)+3,2).EQ.0.AND.
19444 & (KCQ3(JT).EQ.-1.OR.KCQ3(JT).EQ.2)) THEN
19445 MOTHER=K(NSD(JT)+3,5)/MSTU(5)
19446 MCT(NSD(JT)+2,2)=MCT(MOTHER,2)
19447 ENDIF
19448 IF(NPART.EQ.4.AND.MCT(NSD(JT)+4,1).EQ.0.AND.
19449 & (KCQ4(JT).EQ.1.OR. KCQ4(JT).EQ.2)) THEN
19450 MOTHER=K(NSD(JT)+4,4)/MSTU(5)
19451 MCT(NSD(JT)+4,1)=MCT(MOTHER,1)
19452 ENDIF
19453 IF(NPART.EQ.4.AND.MCT(NSD(JT)+4,2).EQ.0.AND.
19454 & (KCQ4(JT).EQ.-1.OR.KCQ4(JT).EQ.2)) THEN
19455 MOTHER=K(NSD(JT)+4,5)/MSTU(5)
19456 MCT(NSD(JT)+4,2)=MCT(MOTHER,2)
19457 ENDIF
19458
19459 IF (MSTP(71).GE.1) CALL PYPTFS(2,0.5D0*P(ID,5),0D0,PTGEN)
19460 ENDIF
19461 NSHAFT=N
19462 IF(JT.EQ.1) NAFT1=N
19463
19464C...Check if decay products moved by shower.
19465 NSD1=NSD(JT)+1
19466 NSD2=NSD(JT)+2
19467 NSD3=NSD(JT)+3
19468 NSD4=NSD(JT)+4
19469C...4-body decays will only work if one of the products is "inert"
19470 IF(NSHAFT.GT.NSHBEF) THEN
19471 IF(K(NSD1,1).GT.10) THEN
19472 DO 660 I=NSHBEF+1,NSHAFT
19473 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD1,2)) NSD1=I
19474 660 CONTINUE
19475 ENDIF
19476 IF(K(NSD2,1).GT.10) THEN
19477 DO 670 I=NSHBEF+1,NSHAFT
19478 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD2,2).AND.
19479 & I.NE.NSD1) NSD2=I
19480 670 CONTINUE
19481 ENDIF
19482 IF(KFL3(JT).NE.0.AND.K(NSD3,1).GT.10) THEN
19483 DO 680 I=NSHBEF+1,NSHAFT
19484 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD3,2).AND.
19485 & I.NE.NSD1.AND.I.NE.NSD2) NSD3=I
19486 680 CONTINUE
19487 ENDIF
19488 IF(KFL4(JT).NE.0.AND.K(NSD4,1).GT.10) THEN
19489 DO 685 I=NSHBEF+1,NSHAFT
19490 IF(K(I,1).LT.10.AND.K(I,2).EQ.K(NSD4,2).AND.
19491 & I.NE.NSD1.AND.I.NE.NSD2.AND.I.NE.NSD3) NSD4=I
19492 685 CONTINUE
19493 ENDIF
19494 ENDIF
19495
19496C...Store decay products for further treatment.
19497 IF(KFL4(JT).EQ.0) THEN
19498 NP=NP+1
19499 IREF(NP,1)=NSD1
19500 IREF(NP,2)=NSD2
19501 IREF(NP,3)=0
19502 IF(KFL3(JT).NE.0) IREF(NP,3)=NSD3
19503 IREF(NP,4)=IDOC+1
19504 IREF(NP,5)=IDOC+2
19505 IREF(NP,6)=0
19506 IF(KFL3(JT).NE.0) IREF(NP,6)=IDOC+3
19507 IREF(NP,7)=K(IREF(IP,JT),2)
19508 IREF(NP,8)=IREF(IP,JT)
19509 ELSE
19510 NSDA=NSD1
19511 NSDB=NSD2
19512 NSDC=NSD3
19513 NP=NP+1
19514 IREF(NP,4)=IDOC+1
19515 IREF(NP,5)=IDOC+2
19516 IREF(NP,6)=IDOC+3
19517 IF(K(NSD1,1).EQ.1) THEN
19518 NSDA=NSD4
19519 IREF(NP,4)=IDOC+4
19520 ELSEIF(K(NSD2,1).EQ.1) THEN
19521 NSDB=NSD4
19522 IREF(NP,5)=IDOC+4
19523 ELSEIF(K(NSD3,1).EQ.1) THEN
19524 NSDC=NSD4
19525 IREF(NP,6)=IDOC+4
19526 ENDIF
19527 IREF(NP,1)=NSDA
19528 IREF(NP,2)=NSDB
19529 IREF(NP,3)=NSDC
19530 IREF(NP,7)=K(IREF(IP,JT),2)
19531 IREF(NP,8)=IREF(IP,JT)
19532 ENDIF
19533 690 CONTINUE
19534
19535
19536C...Fill information for 2 -> 1 -> 2.
19537 700 IF(JTMAX.EQ.1.AND.KDCY(1).NE.0.AND.ISUB.NE.0) THEN
19538 MINT(7)=MINT(83)+6+2*ISET(ISUB)
19539 MINT(8)=MINT(83)+7+2*ISET(ISUB)
19540 MINT(25)=KFL1(1)
19541 MINT(26)=KFL2(1)
19542 VINT(23)=CTHE(1)
19543 RM3=P(N-1,5)**2/SH
19544 RM4=P(N,5)**2/SH
19545 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
19546 VINT(45)=-0.5D0*SH*(1D0-RM3-RM4-BE34*CTHE(1))
19547 VINT(46)=-0.5D0*SH*(1D0-RM3-RM4+BE34*CTHE(1))
19548 VINT(48)=0.25D0*SH*BE34**2*MAX(0D0,1D0-CTHE(1)**2)
19549 VINT(47)=SQRT(VINT(48))
19550 ENDIF
19551
19552C...Possibility of colour rearrangement in W+W- events.
19553 IF((ISUB.EQ.25.OR.ISUB.EQ.22).AND.MSTP(115).GE.1) THEN
19554 IAKF1=IABS(KFL1(1))
19555 IAKF2=IABS(KFL1(2))
19556 IAKF3=IABS(KFL2(1))
19557 IAKF4=IABS(KFL2(2))
19558 IF(MIN(IAKF1,IAKF2,IAKF3,IAKF4).GE.1.AND.
19559 & MAX(IAKF1,IAKF2,IAKF3,IAKF4).LE.5) CALL
19560 & PYRECO(IREF(1,1),IREF(1,2),NSD(1),NAFT1)
19561 IF(MINT(51).NE.0) RETURN
19562 ENDIF
19563
19564C...Loop back if needed.
19565 710 IF(IP.LT.NP) GOTO 170
19566
19567C...Boost back to standard frame.
19568 720 IF(IBST.EQ.1) CALL PYROBO(MINT(83)+7,N,THEIN,PHIIN,BEXIN,BEYIN,
19569 &BEZIN)
19570
19571
19572 RETURN
19573 END
19574
19575C*********************************************************************
19576
19577C...PYMULT
19578C...Initializes treatment of multiple interactions, selects kinematics
19579C...of hardest interaction if low-pT physics included in run, and
19580C...generates all non-hardest interactions.
19581
19582 SUBROUTINE PYMULT(MMUL)
19583
19584C...Double precision and integer declarations.
19585 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
19586 IMPLICIT INTEGER(I-N)
19587 INTEGER PYK,PYCHGE,PYCOMP
19588C...Commonblocks.
19589 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
19590 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
19591 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
19592 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
19593 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
19594 COMMON/PYINT1/MINT(400),VINT(400)
19595 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
19596 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
19597 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
19598 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
19599 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,
19600 &/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/
19601C...Local arrays and saved variables.
19602 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80)
19603 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
19604 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
19605 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
19606
19607C...Initialization of multiple interaction treatment.
19608 IF(MMUL.EQ.1) THEN
19609 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
19610 ISUB=96
19611 MINT(1)=96
19612 VINT(63)=0D0
19613 VINT(64)=0D0
19614 VINT(143)=1D0
19615 VINT(144)=1D0
19616
19617C...Loop over phase space points: xT2 choice in 20 bins.
19618 100 SIGSUM=0D0
19619 DO 120 IXT2=1,20
19620 NMUL(IXT2)=MSTP(83)
19621 SIGM(IXT2)=0D0
19622 DO 110 ITRY=1,MSTP(83)
19623 RSCA=0.05D0*((21-IXT2)-PYR(0))
19624 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
19625 XT2=MAX(0.01D0*VINT(149),XT2)
19626 VINT(25)=XT2
19627
19628C...Choose tau and y*. Calculate cos(theta-hat).
19629 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19630 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19631 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19632 ELSE
19633 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19634 ENDIF
19635 VINT(21)=TAU
19636 CALL PYKLIM(2)
19637 RYST=PYR(0)
19638 MYST=1
19639 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19640 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19641 CALL PYKMAP(2,MYST,PYR(0))
19642 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19643
19644C...Calculate differential cross-section.
19645 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
19646 CALL PYSIGH(NCHN,SIGS)
19647 SIGM(IXT2)=SIGM(IXT2)+SIGS
19648 110 CONTINUE
19649 SIGSUM=SIGSUM+SIGM(IXT2)
19650 120 CONTINUE
19651 SIGSUM=SIGSUM/(20D0*MSTP(83))
19652
19653C...Reject result if sigma(parton-parton) is smaller than hadronic one.
19654 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
19655 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
19656 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
19657 PARP(82)=0.9D0*PARP(82)
19658 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
19659 & VINT(2)
19660 GOTO 100
19661 ENDIF
19662 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
19663 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
19664
19665C...Start iteration to find k factor.
19666 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
19667 P83A=(1D0-PARP(83))**2
19668 P83B=2D0*PARP(83)*(1D0-PARP(83))
19669 P83C=PARP(83)**2
19670 CQ2I=1D0/PARP(84)**2
19671 CQ2R=2D0/(1D0+PARP(84)**2)
19672 SO=0.5D0
19673 XI=0D0
19674 YI=0D0
19675 XF=0D0
19676 YF=0D0
19677 XK=0.5D0
19678 IIT=0
19679 130 IF(IIT.EQ.0) THEN
19680 XK=2D0*XK
19681 ELSEIF(IIT.EQ.1) THEN
19682 XK=0.5D0*XK
19683 ELSE
19684 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
19685 ENDIF
19686
19687C...Evaluate overlap integrals. Find where to divide the b range.
19688 IF(MSTP(82).EQ.2) THEN
19689 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
19690 SOP=SP/PARU(1)
19691 ELSE
19692 IF(MSTP(82).EQ.3) THEN
19693 DELTAB=0.02D0
19694 ELSEIF(MSTP(82).EQ.4) THEN
19695 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
19696 ELSE
19697 POWIP=MAX(0.4D0,PARP(83))
19698 RPWIP=2D0/POWIP-1D0
19699 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
19700 SO=0D0
19701 ENDIF
19702 SP=0D0
19703 SOP=0D0
19704 BSP=0D0
19705 SOHIGH=0D0
19706 IBDIV=0
19707 B=-0.5D0*DELTAB
19708 140 B=B+DELTAB
19709 IF(MSTP(82).EQ.3) THEN
19710 OV=EXP(-B**2)/PARU(2)
19711 ELSEIF(MSTP(82).EQ.4) THEN
19712 OV=(P83A*EXP(-MIN(50D0,B**2))+
19713 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19714 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19715 ELSE
19716 OV=EXP(-B**POWIP)/PARU(2)
19717 SO=SO+PARU(2)*B*DELTAB*OV
19718 ENDIF
19719 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
19720 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
19721 SP=SP+PARU(2)*B*DELTAB*PACC
19722 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
19723 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
19724 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
19725 IBDIV=1
19726 BDIV=B+0.5D0*DELTAB
19727 ENDIF
19728 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
19729 ENDIF
19730 YK=PARU(1)*XK*SO/SP
19731
19732C...Continue iteration until convergence.
19733 IF(YK.LT.YKE) THEN
19734 XI=XK
19735 YI=YK
19736 IF(IIT.EQ.1) IIT=2
19737 ELSE
19738 XF=XK
19739 YF=YK
19740 IF(IIT.EQ.0) IIT=1
19741 ENDIF
19742 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
19743
19744C...Store some results for subsequent use.
19745 BAVG=BSP/SP
19746 VINT(145)=SIGSUM
19747 VINT(146)=SOP/SO
19748 VINT(147)=SOP/SP
19749 VNT145=VINT(145)
19750 VNT146=VINT(146)
19751 VNT147=VINT(147)
19752C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
19753 PIK=(VNT146/VNT147)*YKE
19754
19755C...Find relative weight for low and high impact parameter.
19756 PLOWB=PARU(1)*BDIV**2
19757 IF(MSTP(82).EQ.3) THEN
19758 PHIGHB=PIK*0.5*EXP(-BDIV**2)
19759 ELSEIF(MSTP(82).EQ.4) THEN
19760 S4A=P83A*EXP(-BDIV**2)
19761 S4B=P83B*EXP(-BDIV**2*CQ2R)
19762 S4C=P83C*EXP(-BDIV**2*CQ2I)
19763 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
19764 ELSEIF(PARP(83).GE.1.999D0) THEN
19765 PHIGHB=PIK*SOHIGH
19766 B2RPDV=BDIV**POWIP
19767 ELSE
19768 PHIGHB=PIK*SOHIGH
19769 B2RPDV=BDIV**POWIP
19770 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
19771 ENDIF
19772 PALLB=PLOWB+PHIGHB
19773
19774C...Initialize iteration in xT2 for hardest interaction.
19775 ELSEIF(MMUL.EQ.2) THEN
19776 VINT(145)=VNT145
19777 VINT(146)=VNT146
19778 VINT(147)=VNT147
19779 IF(MSTP(82).LE.0) THEN
19780 ELSEIF(MSTP(82).EQ.1) THEN
19781 XT2=1D0
19782 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
19783 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
19784 & VINT(317)/(VINT(318)*VINT(320))
19785 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
19786 ELSEIF(MSTP(82).EQ.2) THEN
19787 XT2=1D0
19788 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19789 & VINT(149)*(1D0+VINT(149))
19790 ELSE
19791 XC2=4D0*CKIN(3)**2/VINT(2)
19792 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
19793 ENDIF
19794
19795C...Select impact parameter for hardest interaction.
19796 IF(MSTP(82).LE.2) RETURN
19797 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
19798C...Treatment in low b region.
19799 MINT(39)=1
19800 B=BDIV*SQRT(PYR(0))
19801 IF(MSTP(82).EQ.3) THEN
19802 OV=EXP(-B**2)/PARU(2)
19803 ELSEIF(MSTP(82).EQ.4) THEN
19804 OV=(P83A*EXP(-MIN(50D0,B**2))+
19805 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19806 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19807 ELSE
19808 OV=EXP(-B**POWIP)/PARU(2)
19809 ENDIF
19810 VINT(148)=OV/VNT147
19811 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
19812 XT2=1D0
19813 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
19814 & VINT(149)*(1D0+VINT(149))
19815 ELSE
19816C...Treatment in high b region.
19817 MINT(39)=2
19818 IF(MSTP(82).EQ.3) THEN
19819 B=SQRT(BDIV**2-LOG(PYR(0)))
19820 OV=EXP(-B**2)/PARU(2)
19821 ELSEIF(MSTP(82).EQ.4) THEN
19822 S4RNDM=PYR(0)*(S4A+S4B+S4C)
19823 IF(S4RNDM.LT.S4A) THEN
19824 B=SQRT(BDIV**2-LOG(PYR(0)))
19825 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
19826 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
19827 ELSE
19828 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
19829 ENDIF
19830 OV=(P83A*EXP(-MIN(50D0,B**2))+
19831 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
19832 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
19833 ELSEIF(PARP(83).GE.1.999D0) THEN
19834 144 B2RPW=B2RPDV-LOG(PYR(0))
19835 ACCIP=(B2RPW/B2RPDV)**RPWIP
19836 IF(ACCIP.LT.PYR(0)) GOTO 144
19837 OV=EXP(-B2RPW)/PARU(2)
19838 B=B2RPW**(1D0/POWIP)
19839 ELSE
19840 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
19841 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
19842 IF(ACCIP.LT.PYR(0)) GOTO 146
19843 OV=EXP(-B2RPW)/PARU(2)
19844 B=B2RPW**(1D0/POWIP)
19845 ENDIF
19846 VINT(148)=OV/VNT147
19847 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
19848 ENDIF
19849 IF(PACC.LT.PYR(0)) GOTO 142
19850 VINT(139)=B/BAVG
19851
19852 ELSEIF(MMUL.EQ.3) THEN
19853C...Low-pT or multiple interactions (first semihard interaction):
19854C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
19855C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
19856 ISUB=MINT(1)
19857 VINT(145)=VNT145
19858 VINT(146)=VNT146
19859 VINT(147)=VNT147
19860 IF(MSTP(82).LE.0) THEN
19861 XT2=0D0
19862 ELSEIF(MSTP(82).EQ.1) THEN
19863 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
19864C...Use with "Sudakov" for low b values when impact parameter dependence.
19865 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
19866 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
19867 & VINT(149)))).GT.PYR(0)) XT2=1D0
19868 IF(XT2.GE.1D0) THEN
19869 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
19870 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
19871 & VINT(149)
19872 ELSE
19873 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
19874 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
19875 & VINT(149)
19876 ENDIF
19877 XT2=MAX(0.01D0*VINT(149),XT2)
19878C...Use without "Sudakov" for high b values when impact parameter dep.
19879 ELSE
19880 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
19881 & PYR(0)*(1D0-XC2))-VINT(149)
19882 XT2=MAX(0.01D0*VINT(149),XT2)
19883 ENDIF
19884 VINT(25)=XT2
19885
19886C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
19887 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
19888 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
19889 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
19890 ISUB=95
19891 MINT(1)=ISUB
19892 VINT(21)=0.01D0*VINT(149)
19893 VINT(22)=0D0
19894 VINT(23)=0D0
19895 VINT(25)=0.01D0*VINT(149)
19896
19897 ELSE
19898C...Multiple interactions (first semihard interaction).
19899C...Choose tau and y*. Calculate cos(theta-hat).
19900 IF(PYR(0).LE.COEF(ISUB,1)) THEN
19901 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
19902 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
19903 ELSE
19904 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
19905 ENDIF
19906 VINT(21)=TAU
19907 CALL PYKLIM(2)
19908 RYST=PYR(0)
19909 MYST=1
19910 IF(RYST.GT.COEF(ISUB,8)) MYST=2
19911 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
19912 CALL PYKMAP(2,MYST,PYR(0))
19913 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
19914 ENDIF
19915 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
19916
19917C...Store results of cross-section calculation.
19918 ELSEIF(MMUL.EQ.4) THEN
19919 ISUB=MINT(1)
19920 VINT(145)=VNT145
19921 VINT(146)=VNT146
19922 VINT(147)=VNT147
19923 XTS=VINT(25)
19924 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
19925 IF(ISET(ISUB).EQ.2)
19926 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
19927 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
19928 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
19929 & (XTS+VINT(149))))
19930 IRBIN=INT(1D0+20D0*RBIN)
19931 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
19932 NMUL(IRBIN)=NMUL(IRBIN)+1
19933 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
19934 ENDIF
19935
19936C...Choose impact parameter if not already done.
19937 ELSEIF(MMUL.EQ.5) THEN
19938 ISUB=MINT(1)
19939 VINT(145)=VNT145
19940 VINT(146)=VNT146
19941 VINT(147)=VNT147
19942 150 IF(MINT(39).GT.0) THEN
19943 ELSEIF(MSTP(82).EQ.3) THEN
19944 EXPB2=PYR(0)
19945 B2=-LOG(PYR(0))
19946 VINT(148)=EXPB2/(PARU(2)*VNT147)
19947 VINT(139)=SQRT(B2)/BAVG
19948 ELSEIF(MSTP(82).EQ.4) THEN
19949 RTYPE=PYR(0)
19950 IF(RTYPE.LT.P83A) THEN
19951 B2=-LOG(PYR(0))
19952 ELSEIF(RTYPE.LT.P83A+P83B) THEN
19953 B2=-LOG(PYR(0))/CQ2R
19954 ELSE
19955 B2=-LOG(PYR(0))/CQ2I
19956 ENDIF
19957 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
19958 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
19959 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
19960 VINT(139)=SQRT(B2)/BAVG
19961 ELSEIF(PARP(83).GE.1.999D0) THEN
19962 POWIP=MAX(2D0,PARP(83))
19963 RPWIP=2D0/POWIP-1D0
19964 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
19965 160 IF(PYR(0).LT.PROB1) THEN
19966 B2RPW=PYR(0)**(0.5D0*POWIP)
19967 ACCIP=EXP(-B2RPW)
19968 ELSE
19969 B2RPW=1D0-LOG(PYR(0))
19970 ACCIP=B2RPW**RPWIP
19971 ENDIF
19972 IF(ACCIP.LT.PYR(0)) GOTO 160
19973 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19974 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19975 ELSE
19976 POWIP=MAX(0.4D0,PARP(83))
19977 RPWIP=2D0/POWIP-1D0
19978 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
19979 170 IF(PYR(0).LT.PROB1) THEN
19980 B2RPW=2D0*RPWIP*PYR(0)
19981 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
19982 ELSE
19983 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
19984 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
19985 ENDIF
19986 IF(ACCIP.LT .PYR(0)) GOTO 170
19987 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
19988 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
19989 ENDIF
19990
19991C...Multiple interactions (variable impact parameter) : reject with
19992C...probability exp(-overlap*cross-section above pT/normalization).
19993C...Does not apply to low-b region, where "Sudakov" already included.
19994 VINT(150)=1D0
19995 IF(MINT(39).NE.1) THEN
19996 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
19997 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
19998 DO 180 IBIN=IRBIN+1,20
19999 RNCOR=RNCOR+NMUL(IBIN)
20000 SIGCOR=SIGCOR+SIGM(IBIN)
20001 180 CONTINUE
20002 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
20003 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
20004 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
20005 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
20006 ENDIF
20007 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
20008 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
20009 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
20010 IF(VINT(150).LT.PYR(0)) GOTO 150
20011 VINT(150)=1D0
20012 ENDIF
20013
20014C...Generate additional multiple semihard interactions.
20015 ELSEIF(MMUL.EQ.6) THEN
20016 ISUBSV=MINT(1)
20017 VINT(145)=VNT145
20018 VINT(146)=VNT146
20019 VINT(147)=VNT147
20020 DO 190 J=11,80
20021 VINTSV(J)=VINT(J)
20022 190 CONTINUE
20023 ISUB=96
20024 MINT(1)=96
20025 VINT(151)=0D0
20026 VINT(152)=0D0
20027
20028C...Reconstruct strings in hard scattering.
20029 NMAX=MINT(84)+4
20030 IF(ISET(ISUBSV).EQ.1) NMAX=MINT(84)+2
20031 IF(ISET(ISUBSV).EQ.11) NMAX=MINT(84)+2+MINT(3)
20032 NSTR=0
20033 DO 210 I=MINT(84)+1,NMAX
20034 KCS=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
20035 IF(KCS.EQ.0) GOTO 210
20036 DO 200 J=1,4
20037 IF(KCS.EQ.1.AND.(J.EQ.2.OR.J.EQ.4)) GOTO 200
20038 IF(KCS.EQ.-1.AND.(J.EQ.1.OR.J.EQ.3)) GOTO 200
20039 IF(J.LE.2) THEN
20040 IST=MOD(K(I,J+3)/MSTU(5),MSTU(5))
20041 ELSE
20042 IST=MOD(K(I,J+1),MSTU(5))
20043 ENDIF
20044 IF(IST.LT.MINT(84).OR.IST.GT.I) GOTO 200
20045 IF(KCHG(PYCOMP(K(IST,2)),2).EQ.0) GOTO 200
20046 NSTR=NSTR+1
20047 IF(J.EQ.1.OR.J.EQ.4) THEN
20048 KSTR(NSTR,1)=I
20049 KSTR(NSTR,2)=IST
20050 ELSE
20051 KSTR(NSTR,1)=IST
20052 KSTR(NSTR,2)=I
20053 ENDIF
20054 200 CONTINUE
20055 210 CONTINUE
20056
20057C...Set up starting values for iteration in xT2.
20058 XT2=4D0*VINT(62)/VINT(2)
20059 IF(MSTP(82).LE.1) THEN
20060 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
20061 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
20062 & VINT(317)/(VINT(318)*VINT(320))
20063 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
20064 ELSE
20065 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
20066 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
20067 ENDIF
20068 VINT(63)=0D0
20069 VINT(64)=0D0
20070 VINT(143)=1D0-VINT(141)
20071 VINT(144)=1D0-VINT(142)
20072
20073C...Iterate downwards in xT2.
20074 220 IF(MSTP(82).LE.1) THEN
20075 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
20076 IF(XT2.LT.VINT(149)) GOTO 270
20077 ELSE
20078 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 270
20079 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
20080 & LOG(PYR(0)))-VINT(149)
20081 IF(XT2.LE.0D0) GOTO 270
20082 XT2=MAX(0.01D0*VINT(149),XT2)
20083 ENDIF
20084 VINT(25)=XT2
20085
20086C...Choose tau and y*. Calculate cos(theta-hat).
20087 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20088 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20089 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20090 ELSE
20091 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20092 ENDIF
20093 VINT(21)=TAU
20094 CALL PYKLIM(2)
20095 RYST=PYR(0)
20096 MYST=1
20097 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20098 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20099 CALL PYKMAP(2,MYST,PYR(0))
20100 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20101
20102C...Check that x not used up. Accept or reject kinematical variables.
20103 X1M=SQRT(TAU)*EXP(VINT(22))
20104 X2M=SQRT(TAU)*EXP(-VINT(22))
20105 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 220
20106 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
20107 CALL PYSIGH(NCHN,SIGS)
20108 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
20109 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 220
20110
20111C...Reset K, P and V vectors. Select some variables.
20112 DO 240 I=N+1,N+2
20113 DO 230 J=1,5
20114 K(I,J)=0
20115 P(I,J)=0D0
20116 V(I,J)=0D0
20117 230 CONTINUE
20118 240 CONTINUE
20119 RFLAV=PYR(0)
20120 PT=0.5D0*VINT(1)*SQRT(XT2)
20121 PHI=PARU(2)*PYR(0)
20122 CTH=VINT(23)
20123
20124C...Add first parton to event record.
20125 K(N+1,1)=3
20126 K(N+1,2)=21
20127 IF(RFLAV.GE.MAX(PARP(85),PARP(86))) K(N+1,2)=
20128 & 1+INT((2D0+PARJ(2))*PYR(0))
20129 P(N+1,1)=PT*COS(PHI)
20130 P(N+1,2)=PT*SIN(PHI)
20131 P(N+1,3)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)-VINT(42)*(1D0-CTH))
20132 P(N+1,4)=0.25D0*VINT(1)*(VINT(41)*(1D0+CTH)+VINT(42)*(1D0-CTH))
20133 P(N+1,5)=0D0
20134
20135C...Add second parton to event record.
20136 K(N+2,1)=3
20137 K(N+2,2)=21
20138 IF(K(N+1,2).NE.21) K(N+2,2)=-K(N+1,2)
20139 P(N+2,1)=-P(N+1,1)
20140 P(N+2,2)=-P(N+1,2)
20141 P(N+2,3)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)-VINT(42)*(1D0+CTH))
20142 P(N+2,4)=0.25D0*VINT(1)*(VINT(41)*(1D0-CTH)+VINT(42)*(1D0+CTH))
20143 P(N+2,5)=0D0
20144
20145 IF(RFLAV.LT.PARP(85).AND.NSTR.GE.1) THEN
20146C....Choose relevant string pieces to place gluons on.
20147 DO 260 I=N+1,N+2
20148 DMIN=1D8
20149 DO 250 ISTR=1,NSTR
20150 I1=KSTR(ISTR,1)
20151 I2=KSTR(ISTR,2)
20152 DIST=(P(I,4)*P(I1,4)-P(I,1)*P(I1,1)-P(I,2)*P(I1,2)-
20153 & P(I,3)*P(I1,3))*(P(I,4)*P(I2,4)-P(I,1)*P(I2,1)-
20154 & P(I,2)*P(I2,2)-P(I,3)*P(I2,3))/MAX(1D0,P(I1,4)*P(I2,4)-
20155 & P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-P(I1,3)*P(I2,3))
20156 IF(ISTR.EQ.1.OR.DIST.LT.DMIN) THEN
20157 DMIN=DIST
20158 IST1=I1
20159 IST2=I2
20160 ISTM=ISTR
20161 ENDIF
20162 250 CONTINUE
20163
20164C....Colour flow adjustments, new string pieces.
20165 IF(K(IST1,4)/MSTU(5).EQ.IST2) K(IST1,4)=MSTU(5)*I+
20166 & MOD(K(IST1,4),MSTU(5))
20167 IF(MOD(K(IST1,5),MSTU(5)).EQ.IST2) K(IST1,5)=
20168 & MSTU(5)*(K(IST1,5)/MSTU(5))+I
20169 K(I,5)=MSTU(5)*IST1
20170 K(I,4)=MSTU(5)*IST2
20171 IF(K(IST2,5)/MSTU(5).EQ.IST1) K(IST2,5)=MSTU(5)*I+
20172 & MOD(K(IST2,5),MSTU(5))
20173 IF(MOD(K(IST2,4),MSTU(5)).EQ.IST1) K(IST2,4)=
20174 & MSTU(5)*(K(IST2,4)/MSTU(5))+I
20175 KSTR(ISTM,2)=I
20176 KSTR(NSTR+1,1)=I
20177 KSTR(NSTR+1,2)=IST2
20178 NSTR=NSTR+1
20179 260 CONTINUE
20180
20181C...String drawing and colour flow for gluon loop.
20182 ELSEIF(K(N+1,2).EQ.21) THEN
20183 K(N+1,4)=MSTU(5)*(N+2)
20184 K(N+1,5)=MSTU(5)*(N+2)
20185 K(N+2,4)=MSTU(5)*(N+1)
20186 K(N+2,5)=MSTU(5)*(N+1)
20187 KSTR(NSTR+1,1)=N+1
20188 KSTR(NSTR+1,2)=N+2
20189 KSTR(NSTR+2,1)=N+2
20190 KSTR(NSTR+2,2)=N+1
20191 NSTR=NSTR+2
20192
20193C...String drawing and colour flow for qqbar pair.
20194 ELSE
20195 K(N+1,4)=MSTU(5)*(N+2)
20196 K(N+2,5)=MSTU(5)*(N+1)
20197 KSTR(NSTR+1,1)=N+1
20198 KSTR(NSTR+1,2)=N+2
20199 NSTR=NSTR+1
20200 ENDIF
20201
20202C...Global statistics.
20203 MINT(351)=MINT(351)+1
20204 VINT(351)=VINT(351)+PT
20205 IF (MINT(351).EQ.1) VINT(356)=PT
20206
20207C...Update remaining energy; iterate.
20208 N=N+2
20209 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
20210 CALL PYERRM(11,'(PYMULT:) no more memory left in PYJETS')
20211 MINT(51)=1
20212 RETURN
20213 ENDIF
20214 MINT(31)=MINT(31)+1
20215 VINT(151)=VINT(151)+VINT(41)
20216 VINT(152)=VINT(152)+VINT(42)
20217 VINT(143)=VINT(143)-VINT(41)
20218 VINT(144)=VINT(144)-VINT(42)
20219C...Allow FSR for UE (always handle with old showers)
20220 IF(MSTP(152).EQ.1) THEN
20221 M41SAV=MSTJ(41)
20222 IF (MSTJ(41).EQ.10) MSTJ(41)=2
20223 MSTJ(41)=MOD(MSTJ(41),10)
20224 CALL PYSHOW(N-1,N,SQRT(PARP(71))*PT)
20225 MSTJ(41)=M41SAV
20226 ENDIF
20227 IF(MINT(31).LT.240) GOTO 220
20228 270 CONTINUE
20229 MINT(1)=ISUBSV
20230 DO 280 J=11,80
20231 VINT(J)=VINTSV(J)
20232 280 CONTINUE
20233 ENDIF
20234
20235C...Format statements for printout.
20236 5000 FORMAT(/1X,'****** PYMULT: initialization of multiple inter',
20237 &'actions for MSTP(82) =',I2,' ******')
20238 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20239 &D9.2,' mb: rejected')
20240 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
20241 &D9.2,' mb: accepted')
20242
20243 RETURN
20244 END
20245
20246C*********************************************************************
20247
20248C...PYREMN
20249C...Adds on target remnants (one or two from each side) and
20250C...includes primordial kT for hadron beams.
20251
20252 SUBROUTINE PYREMN(IPU1,IPU2)
20253
20254C...Double precision and integer declarations.
20255 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20256 IMPLICIT INTEGER(I-N)
20257 INTEGER PYK,PYCHGE,PYCOMP
20258C...Commonblocks.
20259 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20260 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20261 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20262 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20263 COMMON/PYINT1/MINT(400),VINT(400)
20264 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
20265C...Local arrays.
20266 DIMENSION KFLCH(2),KFLSP(2),CHI(2),PMS(0:6),IS(2),ISN(2),ROBO(5),
20267 &PSYS(0:2,5),PMIN(0:2),QOLD(4),QNEW(4),DBE(3),PSUM(4)
20268
20269C...Find event type and remaining energy.
20270 ISUB=MINT(1)
20271 NS=N
20272 IF(MINT(50).EQ.0.OR.MOD(MSTP(81),10).LE.0) THEN
20273 VINT(143)=1D0-VINT(141)
20274 VINT(144)=1D0-VINT(142)
20275 ENDIF
20276
20277C...Define initial partons.
20278 NTRY=0
20279 100 NTRY=NTRY+1
20280 DO 130 JT=1,2
20281 I=MINT(83)+JT+2
20282 IF(JT.EQ.1) IPU=IPU1
20283 IF(JT.EQ.2) IPU=IPU2
20284 K(I,1)=21
20285 K(I,2)=K(IPU,2)
20286 K(I,3)=I-2
20287 PMS(JT)=0D0
20288 VINT(156+JT)=0D0
20289 VINT(158+JT)=0D0
20290 IF(MINT(47).EQ.1) THEN
20291 DO 110 J=1,5
20292 P(I,J)=P(I-2,J)
20293 110 CONTINUE
20294 ELSEIF(ISUB.EQ.95) THEN
20295 K(I,2)=21
20296 ELSE
20297 P(I,5)=P(IPU,5)
20298
20299C...No primordial kT, or chosen according to truncated Gaussian or
20300C...exponential, or (for photon) predetermined or power law.
20301 120 IF(MINT(40+JT).EQ.2.AND.MINT(10+JT).NE.22) THEN
20302 IF(MSTP(91).LE.0) THEN
20303 PT=0D0
20304 ELSEIF(MSTP(91).EQ.1) THEN
20305 PT=PARP(91)*SQRT(-LOG(PYR(0)))
20306 ELSE
20307 RPT1=PYR(0)
20308 RPT2=PYR(0)
20309 PT=-PARP(92)*LOG(RPT1*RPT2)
20310 ENDIF
20311 IF(PT.GT.PARP(93)) GOTO 120
20312 ELSEIF(MINT(106+JT).EQ.3) THEN
20313 PTA=SQRT(VINT(282+JT))
20314 PTB=0D0
20315 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
20316 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
20317 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
20318 RPT1=PYR(0)
20319 RPT2=PYR(0)
20320 PTB=-PARP(99)*LOG(RPT1*RPT2)
20321 ENDIF
20322 IF(PTB.GT.PARP(100)) GOTO 120
20323 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
20324 PT=PT*0.8D0**MINT(57)
20325 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
20326 ELSEIF(IABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) THEN
20327 IF(MSTP(93).LE.0) THEN
20328 PT=0D0
20329 ELSEIF(MSTP(93).EQ.1) THEN
20330 PT=PARP(99)*SQRT(-LOG(PYR(0)))
20331 ELSEIF(MSTP(93).EQ.2) THEN
20332 RPT1=PYR(0)
20333 RPT2=PYR(0)
20334 PT=-PARP(99)*LOG(RPT1*RPT2)
20335 ELSEIF(MSTP(93).EQ.3) THEN
20336 HA=PARP(99)**2
20337 HB=PARP(100)**2
20338 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
20339 ELSE
20340 HA=PARP(99)**2
20341 HB=PARP(100)**2
20342 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
20343 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
20344 ENDIF
20345 IF(PT.GT.PARP(100)) GOTO 120
20346 ELSE
20347 PT=0D0
20348 ENDIF
20349 VINT(156+JT)=PT
20350 PHI=PARU(2)*PYR(0)
20351 P(I,1)=PT*COS(PHI)
20352 P(I,2)=PT*SIN(PHI)
20353 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20354 ENDIF
20355 130 CONTINUE
20356 IF(MINT(47).EQ.1) RETURN
20357
20358C...Kinematics construction for initial partons.
20359 I1=MINT(83)+3
20360 I2=MINT(83)+4
20361 IF(ISUB.EQ.95) THEN
20362 SHS=0D0
20363 SHR=0D0
20364 ELSE
20365 SHS=VINT(141)*VINT(142)*VINT(2)+(P(I1,1)+P(I2,1))**2+
20366 & (P(I1,2)+P(I2,2))**2
20367 SHR=SQRT(MAX(0D0,SHS))
20368 IF((SHS-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2).LE.0D0) GOTO 100
20369 P(I1,4)=0.5D0*(SHR+(PMS(1)-PMS(2))/SHR)
20370 P(I1,3)=SQRT(MAX(0D0,P(I1,4)**2-PMS(1)))
20371 P(I2,4)=SHR-P(I1,4)
20372 P(I2,3)=-P(I1,3)
20373
20374C...Transform partons to overall CM-frame.
20375 ROBO(3)=(P(I1,1)+P(I2,1))/SHR
20376 ROBO(4)=(P(I1,2)+P(I2,2))/SHR
20377 CALL PYROBO(I1,I2,0D0,0D0,-ROBO(3),-ROBO(4),0D0)
20378 ROBO(2)=PYANGL(P(I1,1),P(I1,2))
20379 CALL PYROBO(I1,I2,0D0,-ROBO(2),0D0,0D0,0D0)
20380 ROBO(1)=PYANGL(P(I1,3),P(I1,1))
20381 CALL PYROBO(I1,I2,-ROBO(1),0D0,0D0,0D0,0D0)
20382 CALL PYROBO(I2+1,MINT(52),0D0,-ROBO(2),0D0,0D0,0D0)
20383 CALL PYROBO(I1,MINT(52),ROBO(1),ROBO(2),ROBO(3),ROBO(4),0D0)
20384 ROBO(5)=(VINT(141)-VINT(142))/(VINT(141)+VINT(142))
20385 CALL PYROBO(I1,MINT(52),0D0,0D0,0D0,0D0,ROBO(5))
20386 ENDIF
20387
20388C...Optionally fix up x and Q2 definitions for leptoproduction.
20389 IDISXQ=0
20390 IF((MINT(43).EQ.2.OR.MINT(43).EQ.3).AND.((ISUB.EQ.10.AND.
20391 &MSTP(23).GE.1).OR.(ISUB.EQ.83.AND.MSTP(23).GE.2))) IDISXQ=1
20392 IF(IDISXQ.EQ.1) THEN
20393
20394C...Find where incoming and outgoing leptons/partons are sitting.
20395 LESD=1
20396 IF(MINT(42).EQ.1) LESD=2
20397 LPIN=MINT(83)+3-LESD
20398 LEIN=MINT(84)+LESD
20399 LQIN=MINT(84)+3-LESD
20400 LEOUT=MINT(84)+2+LESD
20401 LQOUT=MINT(84)+5-LESD
20402 IF(K(LEIN,3).GT.LEIN) LEIN=K(LEIN,3)
20403 IF(K(LQIN,3).GT.LQIN) LQIN=K(LQIN,3)
20404 LSCMS=0
20405 DO 140 I=MINT(84)+5,N
20406 IF(K(I,2).EQ.94) THEN
20407 LSCMS=I
20408 LEOUT=I+LESD
20409 LQOUT=I+3-LESD
20410 ENDIF
20411 140 CONTINUE
20412 LQBG=IPU1
20413 IF(LESD.EQ.1) LQBG=IPU2
20414
20415C...Calculate actual and wanted momentum transfer.
20416 XNOM=VINT(43-LESD)
20417 Q2NOM=-VINT(45)
20418 HPK=2D0*(P(LPIN,4)*P(LEIN,4)-P(LPIN,1)*P(LEIN,1)-
20419 & P(LPIN,2)*P(LEIN,2)-P(LPIN,3)*P(LEIN,3))*
20420 & (P(MINT(83)+LESD,4)*VINT(40+LESD)/P(LEIN,4))
20421 HPT2=MAX(0D0,Q2NOM*(1D0-Q2NOM/(XNOM*HPK)))
20422 FAC=SQRT(HPT2/(P(LEOUT,1)**2+P(LEOUT,2)**2))
20423 P(N+1,1)=FAC*P(LEOUT,1)
20424 P(N+1,2)=FAC*P(LEOUT,2)
20425 P(N+1,3)=0.25D0*((HPK-Q2NOM/XNOM)/P(LPIN,4)-
20426 & Q2NOM/(P(MINT(83)+LESD,4)*VINT(40+LESD)))*(-1)**(LESD+1)
20427 P(N+1,4)=SQRT(P(LEOUT,5)**2+P(N+1,1)**2+P(N+1,2)**2+
20428 & P(N+1,3)**2)
20429 DO 150 J=1,4
20430 QOLD(J)=P(LEIN,J)-P(LEOUT,J)
20431 QNEW(J)=P(LEIN,J)-P(N+1,J)
20432 150 CONTINUE
20433
20434C...Boost outgoing electron and daughters.
20435 IF(LSCMS.EQ.0) THEN
20436 DO 160 J=1,4
20437 P(LEOUT,J)=P(N+1,J)
20438 160 CONTINUE
20439 ELSE
20440 DO 170 J=1,3
20441 P(N+2,J)=(P(N+1,J)-P(LEOUT,J))/(P(N+1,4)+P(LEOUT,4))
20442 170 CONTINUE
20443 PINV=2D0/(1D0+P(N+2,1)**2+P(N+2,2)**2+P(N+2,3)**2)
20444 DO 180 J=1,3
20445 DBE(J)=PINV*P(N+2,J)
20446 180 CONTINUE
20447 DO 200 I=LSCMS+1,N
20448 IORIG=I
20449 190 IORIG=K(IORIG,3)
20450 IF(IORIG.GT.LEOUT) GOTO 190
20451 IF(I.EQ.LEOUT.OR.IORIG.EQ.LEOUT)
20452 & CALL PYROBO(I,I,0D0,0D0,DBE(1),DBE(2),DBE(3))
20453 200 CONTINUE
20454 ENDIF
20455
20456C...Copy shower initiator and all outgoing partons.
20457 NCOP=N+1
20458 K(NCOP,3)=LQBG
20459 DO 210 J=1,5
20460 P(NCOP,J)=P(LQBG,J)
20461 210 CONTINUE
20462 DO 240 I=MINT(84)+1,N
20463 ICOP=0
20464 IF(K(I,1).GT.10) GOTO 240
20465 IF(I.EQ.LQBG.OR.I.EQ.LQOUT) THEN
20466 ICOP=I
20467 ELSE
20468 IORIG=I
20469 220 IORIG=K(IORIG,3)
20470 IF(IORIG.EQ.LQBG.OR.IORIG.EQ.LQOUT) THEN
20471 ICOP=IORIG
20472 ELSEIF(IORIG.GT.MINT(84).AND.IORIG.LE.N) THEN
20473 GOTO 220
20474 ENDIF
20475 ENDIF
20476 IF(ICOP.NE.0) THEN
20477 NCOP=NCOP+1
20478 K(NCOP,3)=I
20479 DO 230 J=1,5
20480 P(NCOP,J)=P(I,J)
20481 230 CONTINUE
20482 ENDIF
20483 240 CONTINUE
20484
20485C...Calculate relative rescaling factors.
20486 SLC=3-2*LESD
20487 PLCSUM=0D0
20488 DO 250 I=N+2,NCOP
20489 PLCSUM=PLCSUM+(P(I,4)+SLC*P(I,3))
20490 250 CONTINUE
20491 DO 260 I=N+2,NCOP
20492 V(I,1)=(P(I,4)+SLC*P(I,3))/PLCSUM
20493 260 CONTINUE
20494
20495C...Transfer extra three-momentum of current.
20496 DO 280 I=N+2,NCOP
20497 DO 270 J=1,3
20498 P(I,J)=P(I,J)+V(I,1)*(QNEW(J)-QOLD(J))
20499 270 CONTINUE
20500 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20501 280 CONTINUE
20502
20503C...Iterate change of initiator momentum to get energy right.
20504 ITER=0
20505 290 ITER=ITER+1
20506 PEEX=-P(N+1,4)-QNEW(4)
20507 PEMV=-P(N+1,3)/P(N+1,4)
20508 DO 300 I=N+2,NCOP
20509 PEEX=PEEX+P(I,4)
20510 PEMV=PEMV+V(I,1)*P(I,3)/P(I,4)
20511 300 CONTINUE
20512 IF(ABS(PEMV).LT.1D-10) THEN
20513 MINT(51)=1
20514 MINT(57)=MINT(57)+1
20515 RETURN
20516 ENDIF
20517 PZCH=-PEEX/PEMV
20518 P(N+1,3)=P(N+1,3)+PZCH
20519 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)
20520 DO 310 I=N+2,NCOP
20521 P(I,3)=P(I,3)+V(I,1)*PZCH
20522 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
20523 310 CONTINUE
20524 IF(ITER.LT.10.AND.ABS(PEEX).GT.1D-6*P(N+1,4)) GOTO 290
20525
20526C...Modify momenta in event record.
20527 HBE=2D0*(P(N+1,4)+P(LQBG,4))*(P(N+1,3)-P(LQBG,3))/
20528 & ((P(N+1,4)+P(LQBG,4))**2+(P(N+1,3)-P(LQBG,3))**2)
20529 IF(ABS(HBE).GE.1D0) THEN
20530 MINT(51)=1
20531 MINT(57)=MINT(57)+1
20532 RETURN
20533 ENDIF
20534 I=MINT(83)+5-LESD
20535 CALL PYROBO(I,I,0D0,0D0,0D0,0D0,HBE)
20536 DO 330 I=N+1,NCOP
20537 ICOP=K(I,3)
20538 DO 320 J=1,4
20539 P(ICOP,J)=P(I,J)
20540 320 CONTINUE
20541 330 CONTINUE
20542 ENDIF
20543
20544C...Check minimum invariant mass of remnant system(s).
20545 PSYS(0,4)=P(I1,4)+P(I2,4)+0.5D0*VINT(1)*(VINT(151)+VINT(152))
20546 PSYS(0,3)=P(I1,3)+P(I2,3)+0.5D0*VINT(1)*(VINT(151)-VINT(152))
20547 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20548 PMIN(0)=SQRT(PMS(0))
20549 DO 340 JT=1,2
20550 PSYS(JT,4)=0.5D0*VINT(1)*VINT(142+JT)
20551 PSYS(JT,3)=PSYS(JT,4)*(-1)**(JT-1)
20552 PMIN(JT)=0D0
20553 IF(MINT(44+JT).EQ.1) GOTO 340
20554 MINT(105)=MINT(102+JT)
20555 MINT(109)=MINT(106+JT)
20556 CALL PYSPLI(MINT(10+JT),MINT(12+JT),KFLCH(JT),KFLSP(JT))
20557 IF(MINT(51).NE.0) THEN
20558 MINT(57)=MINT(57)+1
20559 RETURN
20560 ENDIF
20561 IF(KFLCH(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLCH(JT))
20562 IF(KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+PYMASS(KFLSP(JT))
20563 IF(KFLCH(JT)*KFLSP(JT).NE.0) PMIN(JT)=PMIN(JT)+0.5D0*PARP(111)
20564 PMIN(JT)=SQRT(PMIN(JT)**2+P(MINT(83)+JT+2,1)**2+
20565 & P(MINT(83)+JT+2,2)**2)
20566 340 CONTINUE
20567 IF(PMIN(0)+PMIN(1)+PMIN(2).GT.VINT(1).OR.(MINT(45).GE.2.AND.
20568 &PMIN(1).GT.PSYS(1,4)).OR.(MINT(46).GE.2.AND.PMIN(2).GT.
20569 &PSYS(2,4))) THEN
20570 MINT(51)=1
20571 MINT(57)=MINT(57)+1
20572 RETURN
20573 ENDIF
20574
20575C...Loop over two remnants; skip if none there.
20576 I=NS
20577 DO 410 JT=1,2
20578 ISN(JT)=0
20579 IF(MINT(44+JT).EQ.1) GOTO 410
20580 IF(JT.EQ.1) IPU=IPU1
20581 IF(JT.EQ.2) IPU=IPU2
20582
20583C...Store first remnant parton.
20584 I=I+1
20585 IS(JT)=I
20586 ISN(JT)=1
20587 DO 350 J=1,5
20588 K(I,J)=0
20589 P(I,J)=0D0
20590 V(I,J)=0D0
20591 350 CONTINUE
20592 K(I,1)=1
20593 K(I,2)=KFLSP(JT)
20594 K(I,3)=MINT(83)+JT
20595 P(I,5)=PYMASS(K(I,2))
20596
20597C...First parton colour connections and kinematics.
20598 KCOL=KCHG(PYCOMP(KFLSP(JT)),2)
20599 IF(KCOL.EQ.2) THEN
20600 K(I,1)=3
20601 K(I,4)=MSTU(5)*IPU+IPU
20602 K(I,5)=MSTU(5)*IPU+IPU
20603 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20604 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20605 ELSEIF(KCOL.NE.0) THEN
20606 K(I,1)=3
20607 KFLS=(3-KCOL*ISIGN(1,KFLSP(JT)))/2
20608 K(I,KFLS+3)=IPU
20609 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20610 ENDIF
20611 IF(KFLCH(JT).EQ.0) THEN
20612 P(I,1)=-P(MINT(83)+JT+2,1)
20613 P(I,2)=-P(MINT(83)+JT+2,2)
20614 PMS(JT)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20615 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20616 P(I,3)=PSYS(JT,3)
20617 P(I,4)=PSYS(JT,4)
20618
20619C...When extra remnant parton or hadron: store extra remnant.
20620 ELSE
20621 I=I+1
20622 ISN(JT)=2
20623 DO 360 J=1,5
20624 K(I,J)=0
20625 P(I,J)=0D0
20626 V(I,J)=0D0
20627 360 CONTINUE
20628 K(I,1)=1
20629 K(I,2)=KFLCH(JT)
20630 K(I,3)=MINT(83)+JT
20631 P(I,5)=PYMASS(K(I,2))
20632
20633C...Find parton colour connections of extra remnant.
20634 KCOL=KCHG(PYCOMP(KFLCH(JT)),2)
20635 IF(KCOL.EQ.2) THEN
20636 K(I,1)=3
20637 K(I,4)=MSTU(5)*IPU+IPU
20638 K(I,5)=MSTU(5)*IPU+IPU
20639 K(IPU,4)=MOD(K(IPU,4),MSTU(5))+MSTU(5)*I
20640 K(IPU,5)=MOD(K(IPU,5),MSTU(5))+MSTU(5)*I
20641 ELSEIF(KCOL.NE.0) THEN
20642 K(I,1)=3
20643 KFLS=(3-KCOL*ISIGN(1,KFLCH(JT)))/2
20644 K(I,KFLS+3)=IPU
20645 K(IPU,6-KFLS)=MOD(K(IPU,6-KFLS),MSTU(5))+MSTU(5)*I
20646 ENDIF
20647
20648C...Relative transverse momentum when two remnants.
20649 LOOP=0
20650 370 LOOP=LOOP+1
20651 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
20652 IF(IABS(MINT(10+JT)).LT.20) THEN
20653 P(I-1,1)=0D0
20654 P(I-1,2)=0D0
20655 ELSE
20656 P(I-1,1)=P(I-1,1)-0.5D0*P(MINT(83)+JT+2,1)
20657 P(I-1,2)=P(I-1,2)-0.5D0*P(MINT(83)+JT+2,2)
20658 ENDIF
20659 PMS(JT+2)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
20660 P(I,1)=-P(MINT(83)+JT+2,1)-P(I-1,1)
20661 P(I,2)=-P(MINT(83)+JT+2,2)-P(I-1,2)
20662 PMS(JT+4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
20663
20664C...Meson or baryon; photon as meson. For splitup below.
20665 IMB=1
20666 IF(MOD(MINT(10+JT)/1000,10).NE.0) IMB=2
20667
20668C***Relative distribution for electron into two electrons. Temporary!
20669 IF(IABS(MINT(10+JT)).LT.20.AND.MINT(14+JT).EQ.-MINT(10+JT))
20670 & THEN
20671 CHI(JT)=PYR(0)
20672
20673C...Relative distribution of electron energy into electron plus parton.
20674 ELSEIF(IABS(MINT(10+JT)).LT.20) THEN
20675 XHRD=VINT(140+JT)
20676 XE=VINT(154+JT)
20677 CHI(JT)=(XE-XHRD)/(1D0-XHRD)
20678
20679C...Relative distribution of energy for particle into two jets.
20680 ELSEIF(IABS(KFLCH(JT)).LE.10.OR.KFLCH(JT).EQ.21) THEN
20681 CHIK=PARP(92+2*IMB)
20682 IF(MSTP(92).LE.1) THEN
20683 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20684 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20685 ELSEIF(MSTP(92).EQ.2) THEN
20686 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+CHIK))
20687 ELSEIF(MSTP(92).EQ.3) THEN
20688 CUT=2D0*0.3D0/VINT(1)
20689 380 CHI(JT)=PYR(0)**2
20690 IF((CHI(JT)**2/(CHI(JT)**2+CUT**2))**0.25D0*
20691 & (1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 380
20692 ELSEIF(MSTP(92).EQ.4) THEN
20693 CUT=2D0*0.3D0/VINT(1)
20694 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
20695 390 CHIR=CUT*CUTR**PYR(0)
20696 CHI(JT)=(CHIR**2-CUT**2)/(2D0*CHIR)
20697 IF((1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 390
20698 ELSE
20699 CUT=2D0*0.3D0/VINT(1)
20700 CUTA=CUT**(1D0-PARP(98))
20701 CUTB=(1D0+CUT)**(1D0-PARP(98))
20702 400 CHI(JT)=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
20703 IF(((CHI(JT)+CUT)**2/(2D0*(CHI(JT)**2+CUT**2)))**
20704 & (0.5D0*PARP(98))*(1D0-CHI(JT))**CHIK.LT.PYR(0)) GOTO 400
20705 ENDIF
20706
20707C...Relative distribution of energy for particle into jet plus particle.
20708 ELSE
20709 IF(MSTP(94).LE.1) THEN
20710 IF(IMB.EQ.1) CHI(JT)=PYR(0)
20711 IF(IMB.EQ.2) CHI(JT)=1D0-SQRT(PYR(0))
20712 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20713 ELSEIF(MSTP(94).EQ.2) THEN
20714 CHI(JT)=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
20715 IF(MOD(KFLCH(JT)/1000,10).NE.0) CHI(JT)=1D0-CHI(JT)
20716 ELSEIF(MSTP(94).EQ.3) THEN
20717 CALL PYZDIS(1,0,PMS(JT+4),ZZ)
20718 CHI(JT)=ZZ
20719 ELSE
20720 CALL PYZDIS(1000,0,PMS(JT+4),ZZ)
20721 CHI(JT)=ZZ
20722 ENDIF
20723 ENDIF
20724
20725C...Construct total transverse mass; reject if too large.
20726 CHI(JT)=MAX(1D-8,MIN(1D0-1D-8,CHI(JT)))
20727 PMS(JT)=PMS(JT+4)/CHI(JT)+PMS(JT+2)/(1D0-CHI(JT))
20728 IF(PMS(JT).GT.PSYS(JT,4)**2) THEN
20729 IF(LOOP.LT.100) THEN
20730 GOTO 370
20731 ELSE
20732 MINT(51)=1
20733 MINT(57)=MINT(57)+1
20734 RETURN
20735 ENDIF
20736 ENDIF
20737 PSYS(JT,3)=SQRT(MAX(0D0,PSYS(JT,4)**2-PMS(JT)))*(-1)**(JT-1)
20738 VINT(158+JT)=CHI(JT)
20739
20740C...Subdivide longitudinal momentum according to value selected above.
20741 PW1=CHI(JT)*(PSYS(JT,4)+ABS(PSYS(JT,3)))
20742 P(IS(JT)+1,4)=0.5D0*(PW1+PMS(JT+4)/PW1)
20743 P(IS(JT)+1,3)=0.5D0*(PW1-PMS(JT+4)/PW1)*(-1)**(JT-1)
20744 P(IS(JT),4)=PSYS(JT,4)-P(IS(JT)+1,4)
20745 P(IS(JT),3)=PSYS(JT,3)-P(IS(JT)+1,3)
20746 ENDIF
20747 410 CONTINUE
20748 N=I
20749
20750C...Check if longitudinal boosts needed - if so pick two systems.
20751 PDEV=ABS(PSYS(0,4)+PSYS(1,4)+PSYS(2,4)-VINT(1))+
20752 &ABS(PSYS(0,3)+PSYS(1,3)+PSYS(2,3))
20753 IF(PDEV.LE.1D-6*VINT(1)) RETURN
20754 IF(ISN(1).EQ.0) THEN
20755 IR=0
20756 IL=2
20757 ELSEIF(ISN(2).EQ.0) THEN
20758 IR=1
20759 IL=0
20760 ELSEIF(VINT(143).GT.0.2D0.AND.VINT(144).GT.0.2D0) THEN
20761 IR=1
20762 IL=2
20763 ELSEIF(VINT(143).GT.0.2D0) THEN
20764 IR=1
20765 IL=0
20766 ELSEIF(VINT(144).GT.0.2D0) THEN
20767 IR=0
20768 IL=2
20769 ELSEIF(PMS(1)/PSYS(1,4)**2.GT.PMS(2)/PSYS(2,4)**2) THEN
20770 IR=1
20771 IL=0
20772 ELSE
20773 IR=0
20774 IL=2
20775 ENDIF
20776 IG=3-IR-IL
20777
20778C...E+-pL wanted for system to be modified.
20779 IF((IG.EQ.1.AND.ISN(1).EQ.0).OR.(IG.EQ.2.AND.ISN(2).EQ.0)) THEN
20780 PPB=VINT(1)
20781 PNB=VINT(1)
20782 ELSE
20783 PPB=VINT(1)-(PSYS(IG,4)+PSYS(IG,3))
20784 PNB=VINT(1)-(PSYS(IG,4)-PSYS(IG,3))
20785 ENDIF
20786
20787C...To keep x and Q2 in leptoproduction: do not count scattered lepton.
20788 IF(IDISXQ.EQ.1.AND.IG.NE.0) THEN
20789 PPB=PPB-(PSYS(0,4)+PSYS(0,3))
20790 PNB=PNB-(PSYS(0,4)-PSYS(0,3))
20791 DO 420 J=1,4
20792 PSYS(0,J)=0D0
20793 420 CONTINUE
20794 DO 450 I=MINT(84)+1,NS
20795 IF(K(I,1).GT.10) GOTO 450
20796 INCL=0
20797 IORIG=I
20798 430 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20799 IORIG=K(IORIG,3)
20800 IF(IORIG.GT.LPIN) GOTO 430
20801 IF(INCL.EQ.0) GOTO 450
20802 DO 440 J=1,4
20803 PSYS(0,J)=PSYS(0,J)+P(I,J)
20804 440 CONTINUE
20805 450 CONTINUE
20806 PMS(0)=MAX(0D0,PSYS(0,4)**2-PSYS(0,3)**2)
20807 PPB=PPB+(PSYS(0,4)+PSYS(0,3))
20808 PNB=PNB+(PSYS(0,4)-PSYS(0,3))
20809 ENDIF
20810
20811C...Construct longitudinal boosts.
20812 DPMTB=PPB*PNB
20813 DPMTR=PMS(IR)
20814 DPMTL=PMS(IL)
20815 DSQLAM=SQRT(MAX(0D0,(DPMTB-DPMTR-DPMTL)**2-4D0*DPMTR*DPMTL))
20816 IF(DSQLAM.LE.1D-6*DPMTB) THEN
20817 MINT(51)=1
20818 MINT(57)=MINT(57)+1
20819 RETURN
20820 ENDIF
20821 DSQSGN=SIGN(1D0,PSYS(IR,3)*PSYS(IL,4)-PSYS(IL,3)*PSYS(IR,4))
20822 DRKR=(DPMTB+DPMTR-DPMTL+DSQLAM*DSQSGN)/
20823 &(2D0*(PSYS(IR,4)+PSYS(IR,3))*PNB)
20824 DRKL=(DPMTB+DPMTL-DPMTR+DSQLAM*DSQSGN)/
20825 &(2D0*(PSYS(IL,4)-PSYS(IL,3))*PPB)
20826 DBER=(DRKR**2-1D0)/(DRKR**2+1D0)
20827 DBEL=-(DRKL**2-1D0)/(DRKL**2+1D0)
20828
20829C...Perform longitudinal boosts.
20830 IF(IR.EQ.1.AND.ISN(1).EQ.1.AND.DBER.LE.-0.99999999D0) THEN
20831 P(IS(1),3)=0D0
20832 P(IS(1),4)=SQRT(P(IS(1),5)**2+P(IS(1),1)**2+P(IS(1),2)**2)
20833 ELSEIF(IR.EQ.1) THEN
20834 CALL PYROBO(IS(1),IS(1)+ISN(1)-1,0D0,0D0,0D0,0D0,DBER)
20835 ELSEIF(IDISXQ.EQ.1) THEN
20836 DO 470 I=I1,NS
20837 INCL=0
20838 IORIG=I
20839 460 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20840 IORIG=K(IORIG,3)
20841 IF(IORIG.GT.LPIN) GOTO 460
20842 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBER)
20843 470 CONTINUE
20844 ELSE
20845 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBER)
20846 ENDIF
20847 IF(IL.EQ.2.AND.ISN(2).EQ.1.AND.DBEL.GE.0.99999999D0) THEN
20848 P(IS(2),3)=0D0
20849 P(IS(2),4)=SQRT(P(IS(2),5)**2+P(IS(2),1)**2+P(IS(2),2)**2)
20850 ELSEIF(IL.EQ.2) THEN
20851 CALL PYROBO(IS(2),IS(2)+ISN(2)-1,0D0,0D0,0D0,0D0,DBEL)
20852 ELSEIF(IDISXQ.EQ.1) THEN
20853 DO 490 I=I1,NS
20854 INCL=0
20855 IORIG=I
20856 480 IF(IORIG.EQ.LQOUT.OR.IORIG.EQ.LPIN+2) INCL=1
20857 IORIG=K(IORIG,3)
20858 IF(IORIG.GT.LPIN) GOTO 480
20859 IF(INCL.EQ.1) CALL PYROBO(I,I,0D0,0D0,0D0,0D0,DBEL)
20860 490 CONTINUE
20861 ELSE
20862 CALL PYROBO(I1,NS,0D0,0D0,0D0,0D0,DBEL)
20863 ENDIF
20864
20865C...Final check that energy-momentum conservation worked.
20866 PESUM=0D0
20867 PZSUM=0D0
20868 DO 500 I=MINT(84)+1,N
20869 IF(K(I,1).GT.10) GOTO 500
20870 PESUM=PESUM+P(I,4)
20871 PZSUM=PZSUM+P(I,3)
20872 500 CONTINUE
20873 PDEV=ABS(PESUM-VINT(1))+ABS(PZSUM)
20874 IF(PDEV.GT.1D-4*VINT(1)) THEN
20875 MINT(51)=1
20876 MINT(57)=MINT(57)+1
20877 RETURN
20878 ENDIF
20879
20880C...Calculate rotation and boost from overall CM frame to
20881C...hadronic CM frame in leptoproduction.
20882 MINT(91)=0
20883 IF(MINT(82).EQ.1.AND.(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
20884 MINT(91)=1
20885 LESD=1
20886 IF(MINT(42).EQ.1) LESD=2
20887 LPIN=MINT(83)+3-LESD
20888
20889C...Sum upp momenta of everything not lepton or photon to define boost.
20890 DO 510 J=1,4
20891 PSUM(J)=0D0
20892 510 CONTINUE
20893 DO 530 I=1,N
20894 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 530
20895 IF(IABS(K(I,2)).GE.11.AND.IABS(K(I,2)).LE.20) GOTO 530
20896 IF(K(I,2).EQ.22) GOTO 530
20897 DO 520 J=1,4
20898 PSUM(J)=PSUM(J)+P(I,J)
20899 520 CONTINUE
20900 530 CONTINUE
20901 VINT(223)=-PSUM(1)/PSUM(4)
20902 VINT(224)=-PSUM(2)/PSUM(4)
20903 VINT(225)=-PSUM(3)/PSUM(4)
20904
20905C...Boost incoming hadron to hadronic CM frame to determine rotations.
20906 K(N+1,1)=1
20907 DO 540 J=1,5
20908 P(N+1,J)=P(LPIN,J)
20909 V(N+1,J)=V(LPIN,J)
20910 540 CONTINUE
20911 CALL PYROBO(N+1,N+1,0D0,0D0,VINT(223),VINT(224),VINT(225))
20912 VINT(222)=-PYANGL(P(N+1,1),P(N+1,2))
20913 CALL PYROBO(N+1,N+1,0D0,VINT(222),0D0,0D0,0D0)
20914 IF(LESD.EQ.2) THEN
20915 VINT(221)=-PYANGL(P(N+1,3),P(N+1,1))
20916 ELSE
20917 VINT(221)=PYANGL(-P(N+1,3),P(N+1,1))
20918 ENDIF
20919 ENDIF
20920
20921 RETURN
20922 END
20923
20924C*********************************************************************
20925
20926C...PYMIGN
20927C...Initializes treatment of new multiple interactions scenario,
20928C...selects kinematics of hardest interaction if low-pT physics
20929C...included in run, and generates all non-hardest interactions.
20930
20931 SUBROUTINE PYMIGN(MMUL)
20932
20933C...Double precision and integer declarations.
20934 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
20935 IMPLICIT INTEGER(I-N)
20936 INTEGER PYK,PYCHGE,PYCOMP
20937 EXTERNAL PYALPS
20938 DOUBLE PRECISION PYALPS
20939C...Commonblocks.
20940 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
20941 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
20942 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
20943 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
20944 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
20945 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
20946 COMMON/PYINT1/MINT(400),VINT(400)
20947 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
20948 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
20949 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
20950 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
20951 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
20952 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
20953 & XMI(2,240),PT2MI(240),IMISEP(0:240)
20954 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
20955 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT5/,/PYINT7/,/PYINTM/
20956C...Local arrays and saved variables.
20957 DIMENSION NMUL(20),SIGM(20),KSTR(500,2),VINTSV(80),
20958 &WDTP(0:400),WDTE(0:400,0:5),XPQ(-25:25),KSAV(4,5),PSAV(4,5)
20959 SAVE XT2,XT2FAC,XC2,XTS,IRBIN,RBIN,NMUL,SIGM,P83A,P83B,P83C,
20960 &CQ2I,CQ2R,PIK,BDIV,B,PLOWB,PHIGHB,PALLB,S4A,S4B,S4C,POWIP,
20961 &RPWIP,B2RPDV,B2RPMX,BAVG,VNT145,VNT146,VNT147
20962
20963C...Initialization of multiple interaction treatment.
20964 IF(MMUL.EQ.1) THEN
20965 IF(MSTP(122).GE.1) WRITE(MSTU(11),5000) MSTP(82)
20966 ISUB=96
20967 MINT(1)=96
20968 VINT(63)=0D0
20969 VINT(64)=0D0
20970 VINT(143)=1D0
20971 VINT(144)=1D0
20972
20973C...Loop over phase space points: xT2 choice in 20 bins.
20974 100 SIGSUM=0D0
20975 DO 120 IXT2=1,20
20976 NMUL(IXT2)=MSTP(83)
20977 SIGM(IXT2)=0D0
20978 DO 110 ITRY=1,MSTP(83)
20979 RSCA=0.05D0*((21-IXT2)-PYR(0))
20980 XT2=VINT(149)*(1D0+VINT(149))/(VINT(149)+RSCA)-VINT(149)
20981 XT2=MAX(0.01D0*VINT(149),XT2)
20982 VINT(25)=XT2
20983
20984C...Choose tau and y*. Calculate cos(theta-hat).
20985 IF(PYR(0).LE.COEF(ISUB,1)) THEN
20986 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
20987 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
20988 ELSE
20989 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
20990 ENDIF
20991 VINT(21)=TAU
20992 CALL PYKLIM(2)
20993 RYST=PYR(0)
20994 MYST=1
20995 IF(RYST.GT.COEF(ISUB,8)) MYST=2
20996 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
20997 CALL PYKMAP(2,MYST,PYR(0))
20998 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
20999
21000C...Calculate differential cross-section.
21001 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
21002 CALL PYSIGH(NCHN,SIGS)
21003 SIGM(IXT2)=SIGM(IXT2)+SIGS
21004 110 CONTINUE
21005 SIGSUM=SIGSUM+SIGM(IXT2)
21006 120 CONTINUE
21007 SIGSUM=SIGSUM/(20D0*MSTP(83))
21008
21009C...Reject result if sigma(parton-parton) is smaller than hadronic one.
21010 IF(SIGSUM.LT.1.1D0*SIGT(0,0,5)) THEN
21011 IF(MSTP(122).GE.1) WRITE(MSTU(11),5100)
21012 & PARP(82)*(VINT(1)/PARP(89))**PARP(90),SIGSUM
21013 PARP(82)=0.9D0*PARP(82)
21014 VINT(149)=4D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
21015 & VINT(2)
21016 GOTO 100
21017 ENDIF
21018 IF(MSTP(122).GE.1) WRITE(MSTU(11),5200)
21019 & PARP(82)*(VINT(1)/PARP(89))**PARP(90), SIGSUM
21020
21021C...Start iteration to find k factor.
21022 YKE=SIGSUM/MAX(1D-10,SIGT(0,0,5))
21023 P83A=(1D0-PARP(83))**2
21024 P83B=2D0*PARP(83)*(1D0-PARP(83))
21025 P83C=PARP(83)**2
21026 CQ2I=1D0/PARP(84)**2
21027 CQ2R=2D0/(1D0+PARP(84)**2)
21028 SO=0.5D0
21029 XI=0D0
21030 YI=0D0
21031 XF=0D0
21032 YF=0D0
21033 XK=0.5D0
21034 IIT=0
21035 130 IF(IIT.EQ.0) THEN
21036 XK=2D0*XK
21037 ELSEIF(IIT.EQ.1) THEN
21038 XK=0.5D0*XK
21039 ELSE
21040 XK=XI+(YKE-YI)*(XF-XI)/(YF-YI)
21041 ENDIF
21042
21043C...Evaluate overlap integrals. Find where to divide the b range.
21044 IF(MSTP(82).EQ.2) THEN
21045 SP=0.5D0*PARU(1)*(1D0-EXP(-XK))
21046 SOP=SP/PARU(1)
21047 ELSE
21048 IF(MSTP(82).EQ.3) THEN
21049 DELTAB=0.02D0
21050 ELSEIF(MSTP(82).EQ.4) THEN
21051 DELTAB=MIN(0.01D0,0.05D0*PARP(84))
21052 ELSE
21053 POWIP=MAX(0.4D0,PARP(83))
21054 RPWIP=2D0/POWIP-1D0
21055 DELTAB=MAX(0.02D0,0.02D0*(2D0/POWIP)**(1D0/POWIP))
21056 SO=0D0
21057 ENDIF
21058 SP=0D0
21059 SOP=0D0
21060 BSP=0D0
21061 SOHIGH=0D0
21062 IBDIV=0
21063 B=-0.5D0*DELTAB
21064 140 B=B+DELTAB
21065 IF(MSTP(82).EQ.3) THEN
21066 OV=EXP(-B**2)/PARU(2)
21067 ELSEIF(MSTP(82).EQ.4) THEN
21068 OV=(P83A*EXP(-MIN(50D0,B**2))+
21069 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
21070 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
21071 ELSE
21072 OV=EXP(-B**POWIP)/PARU(2)
21073 SO=SO+PARU(2)*B*DELTAB*OV
21074 ENDIF
21075 IF(IBDIV.EQ.1) SOHIGH=SOHIGH+PARU(2)*B*DELTAB*OV
21076 PACC=1D0-EXP(-MIN(50D0,PARU(1)*XK*OV))
21077 SP=SP+PARU(2)*B*DELTAB*PACC
21078 SOP=SOP+PARU(2)*B*DELTAB*OV*PACC
21079 BSP=BSP+B*PARU(2)*B*DELTAB*PACC
21080 IF(IBDIV.EQ.0.AND.PARU(1)*XK*OV.LT.1D0) THEN
21081 IBDIV=1
21082 BDIV=B+0.5D0*DELTAB
21083 ENDIF
21084 IF(B.LT.1D0.OR.B*PACC.GT.1D-6) GOTO 140
21085 ENDIF
21086 YK=PARU(1)*XK*SO/SP
21087
21088C...Continue iteration until convergence.
21089 IF(YK.LT.YKE) THEN
21090 XI=XK
21091 YI=YK
21092 IF(IIT.EQ.1) IIT=2
21093 ELSE
21094 XF=XK
21095 YF=YK
21096 IF(IIT.EQ.0) IIT=1
21097 ENDIF
21098 IF(ABS(YK-YKE).GE.1D-5*YKE) GOTO 130
21099
21100C...Store some results for subsequent use.
21101 BAVG=BSP/SP
21102 VINT(145)=SIGSUM
21103 VINT(146)=SOP/SO
21104 VINT(147)=SOP/SP
21105 VNT145=VINT(145)
21106 VNT146=VINT(146)
21107 VNT147=VINT(147)
21108C...PIK = PARU(1)*XK = (VINT(146)/VINT(147))*sigma_jet/sigma_nondiffr.
21109 PIK=(VNT146/VNT147)*YKE
21110
21111C...Find relative weight for low and high impact parameter..
21112 PLOWB=PARU(1)*BDIV**2
21113 IF(MSTP(82).EQ.3) THEN
21114 PHIGHB=PIK*0.5*EXP(-BDIV**2)
21115 ELSEIF(MSTP(82).EQ.4) THEN
21116 S4A=P83A*EXP(-BDIV**2)
21117 S4B=P83B*EXP(-BDIV**2*CQ2R)
21118 S4C=P83C*EXP(-BDIV**2*CQ2I)
21119 PHIGHB=PIK*0.5*(S4A+S4B+S4C)
21120 ELSEIF(PARP(83).GE.1.999D0) THEN
21121 PHIGHB=PIK*SOHIGH
21122 B2RPDV=BDIV**POWIP
21123 ELSE
21124 PHIGHB=PIK*SOHIGH
21125 B2RPDV=BDIV**POWIP
21126 B2RPMX=MAX(2D0*RPWIP,B2RPDV)
21127 ENDIF
21128 PALLB=PLOWB+PHIGHB
21129
21130C...Initialize iteration in xT2 for hardest interaction.
21131 ELSEIF(MMUL.EQ.2) THEN
21132 VINT(145)=VNT145
21133 VINT(146)=VNT146
21134 VINT(147)=VNT147
21135 IF(MSTP(82).LE.0) THEN
21136 ELSEIF(MSTP(82).EQ.1) THEN
21137 XT2=1D0
21138 SIGRAT=XSEC(96,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
21139 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
21140 & VINT(317)/(VINT(318)*VINT(320))
21141 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
21142 ELSEIF(MSTP(82).EQ.2) THEN
21143 XT2=1D0
21144 XT2FAC=VNT146*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
21145 & VINT(149)*(1D0+VINT(149))
21146 ELSE
21147 XC2=4D0*CKIN(3)**2/VINT(2)
21148 IF(CKIN(3).LE.CKIN(5).OR.MINT(82).GE.2) XC2=0D0
21149 ENDIF
21150
21151C...Select impact parameter for hardest interaction.
21152 IF(MSTP(82).LE.2) RETURN
21153 142 IF(PYR(0)*PALLB.LT.PLOWB) THEN
21154C...Treatment in low b region.
21155 MINT(39)=1
21156 B=BDIV*SQRT(PYR(0))
21157 IF(MSTP(82).EQ.3) THEN
21158 OV=EXP(-B**2)/PARU(2)
21159 ELSEIF(MSTP(82).EQ.4) THEN
21160 OV=(P83A*EXP(-MIN(50D0,B**2))+
21161 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
21162 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
21163 ELSE
21164 OV=EXP(-B**POWIP)/PARU(2)
21165 ENDIF
21166 VINT(148)=OV/VNT147
21167 PACC=1D0-EXP(-MIN(50D0,PIK*OV))
21168 XT2=1D0
21169 XT2FAC=VNT146*VINT(148)*XSEC(96,1)/MAX(1D-10,SIGT(0,0,5))*
21170 & VINT(149)*(1D0+VINT(149))
21171 ELSE
21172C...Treatment in high b region.
21173 MINT(39)=2
21174 IF(MSTP(82).EQ.3) THEN
21175 B=SQRT(BDIV**2-LOG(PYR(0)))
21176 OV=EXP(-B**2)/PARU(2)
21177 ELSEIF(MSTP(82).EQ.4) THEN
21178 S4RNDM=PYR(0)*(S4A+S4B+S4C)
21179 IF(S4RNDM.LT.S4A) THEN
21180 B=SQRT(BDIV**2-LOG(PYR(0)))
21181 ELSEIF(S4RNDM.LT.S4A+S4B) THEN
21182 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2R)
21183 ELSE
21184 B=SQRT(BDIV**2-LOG(PYR(0))/CQ2I)
21185 ENDIF
21186 OV=(P83A*EXP(-MIN(50D0,B**2))+
21187 & P83B*CQ2R*EXP(-MIN(50D0,B**2*CQ2R))+
21188 & P83C*CQ2I*EXP(-MIN(50D0,B**2*CQ2I)))/PARU(2)
21189 ELSEIF(PARP(83).GE.1.999D0) THEN
21190 144 B2RPW=B2RPDV-LOG(PYR(0))
21191 ACCIP=(B2RPW/B2RPDV)**RPWIP
21192 IF(ACCIP.LT.PYR(0)) GOTO 144
21193 OV=EXP(-B2RPW)/PARU(2)
21194 B=B2RPW**(1D0/POWIP)
21195 ELSE
21196 146 B2RPW=B2RPDV-2D0*LOG(PYR(0))
21197 ACCIP=(B2RPW/B2RPMX)**RPWIP*EXP(-0.5D0*(B2RPW-B2RPMX))
21198 IF(ACCIP.LT.PYR(0)) GOTO 146
21199 OV=EXP(-B2RPW)/PARU(2)
21200 B=B2RPW**(1D0/POWIP)
21201 ENDIF
21202 VINT(148)=OV/VNT147
21203 PACC=(1D0-EXP(-MIN(50D0,PIK*OV)))/(PIK*OV)
21204 ENDIF
21205 IF(PACC.LT.PYR(0)) GOTO 142
21206 VINT(139)=B/BAVG
21207
21208 ELSEIF(MMUL.EQ.3) THEN
21209C...Low-pT or multiple interactions (first semihard interaction):
21210C...choose xT2 according to dpT2/pT2**2*exp(-(sigma above pT2)/norm)
21211C...or (MSTP(82)>=2) dpT2/(pT2+pT0**2)**2*exp(-....).
21212 ISUB=MINT(1)
21213 VINT(145)=VNT145
21214 VINT(146)=VNT146
21215 VINT(147)=VNT147
21216 IF(MSTP(82).LE.0) THEN
21217 XT2=0D0
21218 ELSEIF(MSTP(82).EQ.1) THEN
21219 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
21220C...Use with "Sudakov" for low b values when impact parameter dependence.
21221 ELSEIF(MSTP(82).EQ.2.OR.MINT(39).EQ.1) THEN
21222 IF(XT2.LT.1D0.AND.EXP(-XT2FAC*XT2/(VINT(149)*(XT2+
21223 & VINT(149)))).GT.PYR(0)) XT2=1D0
21224 IF(XT2.GE.1D0) THEN
21225 XT2=(1D0+VINT(149))*XT2FAC/(XT2FAC-(1D0+VINT(149))*LOG(1D0-
21226 & PYR(0)*(1D0-EXP(-XT2FAC/(VINT(149)*(1D0+VINT(149)))))))-
21227 & VINT(149)
21228 ELSE
21229 XT2=-XT2FAC/LOG(EXP(-XT2FAC/(XT2+VINT(149)))+PYR(0)*
21230 & (EXP(-XT2FAC/VINT(149))-EXP(-XT2FAC/(XT2+VINT(149)))))-
21231 & VINT(149)
21232 ENDIF
21233 XT2=MAX(0.01D0*VINT(149),XT2)
21234C...Use without "Sudakov" for high b values when impact parameter dep.
21235 ELSE
21236 XT2=(XC2+VINT(149))*(1D0+VINT(149))/(1D0+VINT(149)-
21237 & PYR(0)*(1D0-XC2))-VINT(149)
21238 XT2=MAX(0.01D0*VINT(149),XT2)
21239 ENDIF
21240 VINT(25)=XT2
21241
21242C...Low-pT: choose xT2, tau, y* and cos(theta-hat) fixed.
21243 IF(MSTP(82).LE.1.AND.XT2.LT.VINT(149)) THEN
21244 IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)-MINT(143)
21245 IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)-MINT(143)
21246 ISUB=95
21247 MINT(1)=ISUB
21248 VINT(21)=1D-12*VINT(149)
21249 VINT(22)=0D0
21250 VINT(23)=0D0
21251 VINT(25)=1D-12*VINT(149)
21252
21253 ELSE
21254C...Multiple interactions (first semihard interaction).
21255C...Choose tau and y*. Calculate cos(theta-hat).
21256 IF(PYR(0).LE.COEF(ISUB,1)) THEN
21257 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
21258 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
21259 ELSE
21260 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
21261 ENDIF
21262 VINT(21)=TAU
21263 CALL PYKLIM(2)
21264 RYST=PYR(0)
21265 MYST=1
21266 IF(RYST.GT.COEF(ISUB,8)) MYST=2
21267 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21268 CALL PYKMAP(2,MYST,PYR(0))
21269 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21270 ENDIF
21271 VINT(71)=0.5D0*VINT(1)*SQRT(VINT(25))
21272
21273C...Store results of cross-section calculation.
21274 ELSEIF(MMUL.EQ.4) THEN
21275 ISUB=MINT(1)
21276 VINT(145)=VNT145
21277 VINT(146)=VNT146
21278 VINT(147)=VNT147
21279 XTS=VINT(25)
21280 IF(ISET(ISUB).EQ.1) XTS=VINT(21)
21281 IF(ISET(ISUB).EQ.2)
21282 & XTS=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
21283 IF(ISET(ISUB).GE.3.AND.ISET(ISUB).LE.5) XTS=VINT(26)
21284 RBIN=MAX(0.000001D0,MIN(0.999999D0,XTS*(1D0+VINT(149))/
21285 & (XTS+VINT(149))))
21286 IRBIN=INT(1D0+20D0*RBIN)
21287 IF(ISUB.EQ.96.AND.MSTP(171).EQ.0) THEN
21288 NMUL(IRBIN)=NMUL(IRBIN)+1
21289 SIGM(IRBIN)=SIGM(IRBIN)+VINT(153)
21290 ENDIF
21291
21292C...Choose impact parameter if not already done.
21293 ELSEIF(MMUL.EQ.5) THEN
21294 ISUB=MINT(1)
21295 VINT(145)=VNT145
21296 VINT(146)=VNT146
21297 VINT(147)=VNT147
21298 150 IF(MINT(39).GT.0) THEN
21299 ELSEIF(MSTP(82).EQ.3) THEN
21300 EXPB2=PYR(0)
21301 B2=-LOG(PYR(0))
21302 VINT(148)=EXPB2/(PARU(2)*VNT147)
21303 VINT(139)=SQRT(B2)/BAVG
21304 ELSEIF(MSTP(82).EQ.4) THEN
21305 RTYPE=PYR(0)
21306 IF(RTYPE.LT.P83A) THEN
21307 B2=-LOG(PYR(0))
21308 ELSEIF(RTYPE.LT.P83A+P83B) THEN
21309 B2=-LOG(PYR(0))/CQ2R
21310 ELSE
21311 B2=-LOG(PYR(0))/CQ2I
21312 ENDIF
21313 VINT(148)=(P83A*EXP(-MIN(50D0,B2))+
21314 & P83B*CQ2R*EXP(-MIN(50D0,B2*CQ2R))+
21315 & P83C*CQ2I*EXP(-MIN(50D0,B2*CQ2I)))/(PARU(2)*VNT147)
21316 VINT(139)=SQRT(B2)/BAVG
21317 ELSEIF(PARP(83).GE.1.999D0) THEN
21318 POWIP=MAX(2D0,PARP(83))
21319 RPWIP=2D0/POWIP-1D0
21320 PROB1=POWIP/(2D0*EXP(-1D0)+POWIP)
21321 160 IF(PYR(0).LT.PROB1) THEN
21322 B2RPW=PYR(0)**(0.5D0*POWIP)
21323 ACCIP=EXP(-B2RPW)
21324 ELSE
21325 B2RPW=1D0-LOG(PYR(0))
21326 ACCIP=B2RPW**RPWIP
21327 ENDIF
21328 IF(ACCIP.LT.PYR(0)) GOTO 160
21329 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
21330 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
21331 ELSE
21332 POWIP=MAX(0.4D0,PARP(83))
21333 RPWIP=2D0/POWIP-1D0
21334 PROB1=RPWIP/(RPWIP+2D0**RPWIP*EXP(-RPWIP))
21335 170 IF(PYR(0).LT.PROB1) THEN
21336 B2RPW=2D0*RPWIP*PYR(0)
21337 ACCIP=(B2RPW/RPWIP)**RPWIP*EXP(RPWIP-B2RPW)
21338 ELSE
21339 B2RPW=2D0*(RPWIP-LOG(PYR(0)))
21340 ACCIP=(0.5D0*B2RPW/RPWIP)**RPWIP*EXP(RPWIP-0.5D0*B2RPW)
21341 ENDIF
21342 IF(ACCIP.LT .PYR(0)) GOTO 170
21343 VINT(148)=EXP(-B2RPW)/(PARU(2)*VNT147)
21344 VINT(139)=B2RPW**(1D0/POWIP)/BAVG
21345 ENDIF
21346
21347C...Multiple interactions (variable impact parameter) : reject with
21348C...probability exp(-overlap*cross-section above pT/normalization).
21349C...Does not apply to low-b region, where "Sudakov" already included.
21350 VINT(150)=1D0
21351 IF(MINT(39).NE.1) THEN
21352 RNCOR=(IRBIN-20D0*RBIN)*NMUL(IRBIN)
21353 SIGCOR=(IRBIN-20D0*RBIN)*SIGM(IRBIN)
21354 DO 180 IBIN=IRBIN+1,20
21355 RNCOR=RNCOR+NMUL(IBIN)
21356 SIGCOR=SIGCOR+SIGM(IBIN)
21357 180 CONTINUE
21358 SIGABV=(SIGCOR/RNCOR)*VINT(149)*(1D0-XTS)/(XTS+VINT(149))
21359 IF(MSTP(171).EQ.1) SIGABV=SIGABV*VINT(2)/VINT(289)
21360 VINT(150)=EXP(-MIN(50D0,VNT146*VINT(148)*
21361 & SIGABV/MAX(1D-10,SIGT(0,0,5))))
21362 ENDIF
21363 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUB.NE.11.AND.
21364 & ISUB.NE.12.AND.ISUB.NE.13.AND.ISUB.NE.28.AND.ISUB.NE.53
21365 & .AND.ISUB.NE.68.AND.ISUB.NE.95.AND.ISUB.NE.96)) THEN
21366 IF(VINT(150).LT.PYR(0)) GOTO 150
21367 VINT(150)=1D0
21368 ENDIF
21369
21370C...Generate additional multiple semihard interactions.
21371 ELSEIF(MMUL.EQ.6) THEN
21372
21373C...Save data for hardest initeraction, to be restored.
21374 ISUBSV=MINT(1)
21375 VINT(145)=VNT145
21376 VINT(146)=VNT146
21377 VINT(147)=VNT147
21378 M13SV=MINT(13)
21379 M14SV=MINT(14)
21380 M15SV=MINT(15)
21381 M16SV=MINT(16)
21382 M21SV=MINT(21)
21383 M22SV=MINT(22)
21384 DO 190 J=11,80
21385 VINTSV(J)=VINT(J)
21386 190 CONTINUE
21387 V141SV=VINT(141)
21388 V142SV=VINT(142)
21389
21390C...Store data on hardest interaction.
21391 XMI(1,1)=VINT(141)
21392 XMI(2,1)=VINT(142)
21393 PT2MI(1)=VINT(54)
21394 IMISEP(0)=MINT(84)
21395 IMISEP(1)=N
21396
21397C...Change process to generate; sum of x values so far.
21398 ISUB=96
21399 MINT(1)=96
21400 VINT(143)=1D0-VINT(141)
21401 VINT(144)=1D0-VINT(142)
21402 VINT(151)=0D0
21403 VINT(152)=0D0
21404
21405C...Initialize factors for PDF reshaping.
21406 DO 230 JS=1,2
21407 KFBEAM=MINT(10+JS)
21408 KFABM=IABS(KFBEAM)
21409 KFSBM=ISIGN(1,KFBEAM)
21410
21411C...Zero flavour content of incoming beam particle.
21412 KFIVAL(JS,1)=0
21413 KFIVAL(JS,2)=0
21414 KFIVAL(JS,3)=0
21415C...Flavour content of baryon.
21416 IF(KFABM.GT.1000) THEN
21417 KFIVAL(JS,1)=KFSBM*MOD(KFABM/1000,10)
21418 KFIVAL(JS,2)=KFSBM*MOD(KFABM/100,10)
21419 KFIVAL(JS,3)=KFSBM*MOD(KFABM/10,10)
21420C...Flavour content of pi+-, K+-.
21421 ELSEIF(KFABM.EQ.211) THEN
21422 KFIVAL(JS,1)=KFSBM*2
21423 KFIVAL(JS,2)=-KFSBM
21424 ELSEIF(KFABM.EQ.321) THEN
21425 KFIVAL(JS,1)=-KFSBM*3
21426 KFIVAL(JS,2)=KFSBM*2
21427C...Flavour content of pi0, gamma, K0S, K0L not defined yet.
21428 ENDIF
21429
21430C...Zero initial valence and companion content.
21431 DO 200 IFL=-6,6
21432 NVC(JS,IFL)=0
21433 200 CONTINUE
21434
21435C...Initiate listing of all incoming partons from two sides.
21436 NMI(JS)=0
21437 DO 210 I=MINT(84)+1,N
21438 IF(K(I,3).EQ.MINT(83)+2+JS) THEN
21439 IMI(JS,1,1)=I
21440 IMI(JS,1,2)=0
21441 ENDIF
21442 210 CONTINUE
21443
21444C...Decide whether quarks in hard scattering were valence or sea.
21445 IFL=K(IMI(JS,1,1),2)
21446 IF (IABS(IFL).GT.6) GOTO 230
21447
21448C...Get PDFs at X and Q2 of the parton shower initiator for the
21449C...hard scattering.
21450 X=VINT(140+JS)
21451 IF(MSTP(61).GE.1) THEN
21452 Q2=PARP(62)**2
21453 ELSE
21454 Q2=VINT(54)
21455 ENDIF
21456C...Note: XPSVC = x*pdf.
21457 MINT(30)=JS
21458C.... ALICE
21459C.... Store side in MINT(124)
21460 MINT(124) = JS
21461C....
21462 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
21463 SEA=XPSVC(IFL,-1)
21464 VAL=XPSVC(IFL,0)
21465
21466C...Decide (Extra factor x cancels in the division).
21467 RVCS=PYR(0)*(SEA+VAL)
21468 IVNOW=1
21469 220 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
21470C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21471 IVNOW=0
21472 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
21473 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
21474 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
21475 IF(KFIVAL(JS,1).EQ.0) THEN
21476 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
21477 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
21478 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
21479 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
21480 ENDIF
21481 IF(IVNOW.EQ.0) GOTO 220
21482C...Mark valence.
21483 IMI(JS,1,2)=0
21484C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21485 IF(KFIVAL(JS,1).EQ.0) THEN
21486 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21487 KFIVAL(JS,1)=IFL
21488 KFIVAL(JS,2)=-IFL
21489 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21490 KFIVAL(JS,1)=IFL
21491 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21492 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21493 ENDIF
21494 ENDIF
21495
21496C...If sea, add opposite sign companion parton. Store X and I.
21497 ELSE
21498 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21499 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21500C...Set pointer to companion
21501 IMI(JS,1,2)=-NVC(JS,-IFL)
21502 ENDIF
21503 230 CONTINUE
21504
21505C...Update counter number of multiple interactions.
21506 NMI(1)=1
21507 NMI(2)=1
21508
21509C...Set up starting values for iteration in xT2.
21510 IF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
21511 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
21512 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
21513 & ISUBSV.NE.96)) THEN
21514 XT2=(1D0-VINT(141))*(1D0-VINT(142))
21515 ELSE
21516 XT2=VINT(25)
21517 IF(ISET(ISUBSV).EQ.1) XT2=VINT(21)
21518 IF(ISET(ISUBSV).EQ.2)
21519 & XT2=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
21520 IF(ISET(ISUBSV).GE.3.AND.ISET(ISUBSV).LE.5) XT2=VINT(26)
21521 ENDIF
21522 IF(MSTP(82).LE.1) THEN
21523 SIGRAT=XSEC(ISUB,1)/MAX(1D-10,VINT(315)*VINT(316)*SIGT(0,0,5))
21524 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGRAT=SIGRAT*
21525 & VINT(317)/(VINT(318)*VINT(320))
21526 XT2FAC=SIGRAT*VINT(149)/(1D0-VINT(149))
21527 ELSE
21528 XT2FAC=VNT146*VINT(148)*XSEC(ISUB,1)/
21529 & MAX(1D-10,SIGT(0,0,5))*VINT(149)*(1D0+VINT(149))
21530 ENDIF
21531 VINT(63)=0D0
21532 VINT(64)=0D0
21533
21534C...Iterate downwards in xT2.
21535 240 IF((MINT(35).EQ.2.AND.MSTP(81).EQ.10).OR.ISUBSV.EQ.95) THEN
21536 XT2=0D0
21537 GOTO 440
21538 ELSEIF(MSTP(82).LE.1) THEN
21539 XT2=XT2FAC*XT2/(XT2FAC-XT2*LOG(PYR(0)))
21540 IF(XT2.LT.VINT(149)) GOTO 440
21541 ELSE
21542 IF(XT2.LE.0.01001D0*VINT(149)) GOTO 440
21543 XT2=XT2FAC*(XT2+VINT(149))/(XT2FAC-(XT2+VINT(149))*
21544 & LOG(PYR(0)))-VINT(149)
21545 IF(XT2.LE.0D0) GOTO 440
21546 XT2=MAX(0.01D0*VINT(149),XT2)
21547 ENDIF
21548 VINT(25)=XT2
21549
21550C...Choose tau and y*. Calculate cos(theta-hat).
21551 IF(PYR(0).LE.COEF(ISUB,1)) THEN
21552 TAUT=(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)**PYR(0)
21553 TAU=XT2*(1D0+TAUT)**2/(4D0*TAUT)
21554 ELSE
21555 TAU=XT2*(1D0+TAN(PYR(0)*ATAN(SQRT(1D0/XT2-1D0)))**2)
21556 ENDIF
21557 VINT(21)=TAU
21558C...New: require shat > 1.
21559 IF(TAU*VINT(2).LT.1D0) GOTO 240
21560 CALL PYKLIM(2)
21561 RYST=PYR(0)
21562 MYST=1
21563 IF(RYST.GT.COEF(ISUB,8)) MYST=2
21564 IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
21565 CALL PYKMAP(2,MYST,PYR(0))
21566 VINT(23)=SQRT(MAX(0D0,1D0-XT2/TAU))*(-1)**INT(1.5D0+PYR(0))
21567
21568C...Check that x not used up. Accept or reject kinematical variables.
21569 X1M=SQRT(TAU)*EXP(VINT(22))
21570 X2M=SQRT(TAU)*EXP(-VINT(22))
21571 IF(VINT(143)-X1M.LT.0.01D0.OR.VINT(144)-X2M.LT.0.01D0) GOTO 240
21572 VINT(71)=0.5D0*VINT(1)*SQRT(XT2)
21573 CALL PYSIGH(NCHN,SIGS)
21574 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS*VINT(320)
21575 IF(SIGS.LT.XSEC(ISUB,1)*PYR(0)) GOTO 240
21576 IF(MINT(141).NE.0.OR.MINT(142).NE.0) SIGS=SIGS/VINT(320)
21577
21578C...Reset K, P and V vectors.
21579 DO 260 I=N+1,N+4
21580 DO 250 J=1,5
21581 K(I,J)=0
21582 P(I,J)=0D0
21583 V(I,J)=0D0
21584 250 CONTINUE
21585 260 CONTINUE
21586 PT=0.5D0*VINT(1)*SQRT(XT2)
21587
21588C...Choose flavour of reacting partons (and subprocess).
21589 RSIGS=SIGS*PYR(0)
21590 DO 270 ICHN=1,NCHN
21591 KFL1=ISIG(ICHN,1)
21592 KFL2=ISIG(ICHN,2)
21593 ICONMI=ISIG(ICHN,3)
21594 RSIGS=RSIGS-SIGH(ICHN)
21595 IF(RSIGS.LE.0D0) GOTO 280
21596 270 CONTINUE
21597
21598C...Reassign to appropriate process codes.
21599 280 ISUBMI=ICONMI/10
21600 ICONMI=MOD(ICONMI,10)
21601
21602C...Choose new quark flavour for annihilation graphs
21603 IF(ISUBMI.EQ.12.OR.ISUBMI.EQ.53) THEN
21604 SH=TAU*VINT(2)
21605 CALL PYWIDT(21,SH,WDTP,WDTE)
21606 290 RKFL=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))*PYR(0)
21607 DO 300 I=1,MDCY(21,3)
21608 KFLF=KFDP(I+MDCY(21,2)-1,1)
21609 RKFL=RKFL-(WDTE(I,1)+WDTE(I,2)+WDTE(I,4))
21610 IF(RKFL.LE.0D0) GOTO 310
21611 300 CONTINUE
21612 310 IF(ISUBMI.EQ.53.AND.ICONMI.LE.2) THEN
21613 IF(KFLF.GE.4) GOTO 290
21614 ELSEIF(ISUBMI.EQ.53.AND.ICONMI.LE.4) THEN
21615 KFLF=4
21616 ICONMI=ICONMI-2
21617 ELSEIF(ISUBMI.EQ.53) THEN
21618 KFLF=5
21619 ICONMI=ICONMI-4
21620 ENDIF
21621 ENDIF
21622
21623C...Final state flavours and colour flow: default values
21624 JS=1
21625 KFL3=KFL1
21626 KFL4=KFL2
21627 KCC=20
21628 KCS=ISIGN(1,KFL1)
21629
21630 IF(ISUBMI.EQ.11) THEN
21631C...f + f' -> f + f' (g exchange); th = (p(f)-p(f))**2
21632 KCC=ICONMI
21633 IF(KFL1*KFL2.LT.0) KCC=KCC+2
21634
21635 ELSEIF(ISUBMI.EQ.12) THEN
21636C...f + fbar -> f' + fbar'; th = (p(f)-p(f'))**2
21637 KFL3=ISIGN(KFLF,KFL1)
21638 KFL4=-KFL3
21639 KCC=4
21640
21641 ELSEIF(ISUBMI.EQ.13) THEN
21642C...f + fbar -> g + g; th arbitrary
21643 KFL3=21
21644 KFL4=21
21645 KCC=ICONMI+4
21646
21647 ELSEIF(ISUBMI.EQ.28) THEN
21648C...f + g -> f + g; th = (p(f)-p(f))**2
21649 IF(KFL1.EQ.21) JS=2
21650 KCC=ICONMI+6
21651 IF(KFL1.EQ.21) KCC=KCC+2
21652 IF(KFL1.NE.21) KCS=ISIGN(1,KFL1)
21653 IF(KFL2.NE.21) KCS=ISIGN(1,KFL2)
21654
21655 ELSEIF(ISUBMI.EQ.53) THEN
21656C...g + g -> f + fbar; th arbitrary
21657 KCS=(-1)**INT(1.5D0+PYR(0))
21658 KFL3=ISIGN(KFLF,KCS)
21659 KFL4=-KFL3
21660 KCC=ICONMI+10
21661
21662 ELSEIF(ISUBMI.EQ.68) THEN
21663C...g + g -> g + g; th arbitrary
21664 KCC=ICONMI+12
21665 KCS=(-1)**INT(1.5D0+PYR(0))
21666 ENDIF
21667
21668C...Store flavours of scattering.
21669 MINT(13)=KFL1
21670 MINT(14)=KFL2
21671 MINT(15)=KFL1
21672 MINT(16)=KFL2
21673 MINT(21)=KFL3
21674 MINT(22)=KFL4
21675
21676C...Set flavours and mothers of scattering partons.
21677 K(N+1,1)=14
21678 K(N+2,1)=14
21679 K(N+3,1)=3
21680 K(N+4,1)=3
21681 K(N+1,2)=KFL1
21682 K(N+2,2)=KFL2
21683 K(N+3,2)=KFL3
21684 K(N+4,2)=KFL4
21685 K(N+1,3)=MINT(83)+1
21686 K(N+2,3)=MINT(83)+2
21687 K(N+3,3)=N+1
21688 K(N+4,3)=N+2
21689
21690C...Store colour connection indices.
21691 DO 320 J=1,2
21692 JC=J
21693 IF(KCS.EQ.-1) JC=3-J
21694 IF(ICOL(KCC,1,JC).NE.0) K(N+1,J+3)=N+ICOL(KCC,1,JC)
21695 IF(ICOL(KCC,2,JC).NE.0) K(N+2,J+3)=N+ICOL(KCC,2,JC)
21696 IF(ICOL(KCC,3,JC).NE.0) K(N+3,J+3)=MSTU(5)*(N+ICOL(KCC,3,JC))
21697 IF(ICOL(KCC,4,JC).NE.0) K(N+4,J+3)=MSTU(5)*(N+ICOL(KCC,4,JC))
21698 320 CONTINUE
21699
21700C...Store incoming and outgoing partons in their CM-frame.
21701 SHR=SQRT(TAU)*VINT(1)
21702 P(N+1,3)=0.5D0*SHR
21703 P(N+1,4)=0.5D0*SHR
21704 P(N+2,3)=-0.5D0*SHR
21705 P(N+2,4)=0.5D0*SHR
21706 P(N+3,5)=PYMASS(K(N+3,2))
21707 P(N+4,5)=PYMASS(K(N+4,2))
21708 IF(P(N+3,5)+P(N+4,5).GE.SHR) GOTO 240
21709 P(N+3,4)=0.5D0*(SHR+(P(N+3,5)**2-P(N+4,5)**2)/SHR)
21710 P(N+3,3)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,5)**2))
21711 P(N+4,4)=SHR-P(N+3,4)
21712 P(N+4,3)=-P(N+3,3)
21713
21714C...Rotate outgoing partons using cos(theta)=(th-uh)/lam(sh,sqm3,sqm4)
21715 PHI=PARU(2)*PYR(0)
21716 CALL PYROBO(N+3,N+4,ACOS(VINT(23)),PHI,0D0,0D0,0D0)
21717
21718C...Set up default values before showers.
21719 MINT(31)=MINT(31)+1
21720 IPU1=N+1
21721 IPU2=N+2
21722 IPU3=N+3
21723 IPU4=N+4
21724 VINT(141)=VINT(41)
21725 VINT(142)=VINT(42)
21726 N=N+4
21727
21728C...Showering of initial state partons (optional).
21729C...Note: no showering of final state partons here; it comes later.
21730 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21731 MINT(51)=0
21732 ALAMSV=PARJ(81)
21733 PARJ(81)=PARP(72)
21734 NSAV=N
21735 DO 340 I=1,4
21736 DO 330 J=1,5
21737 KSAV(I,J)=K(N-4+I,J)
21738 PSAV(I,J)=P(N-4+I,J)
21739 330 CONTINUE
21740 340 CONTINUE
21741 CALL PYSSPA(IPU1,IPU2)
21742 PARJ(81)=ALAMSV
21743C...If shower failed then restore to situation before shower.
21744 IF(MINT(51).GE.1) THEN
21745 N=NSAV
21746 DO 360 I=1,4
21747 DO 350 J=1,5
21748 K(N-4+I,J)=KSAV(I,J)
21749 P(N-4+I,J)=PSAV(I,J)
21750 350 CONTINUE
21751 360 CONTINUE
21752 IPU1=N-3
21753 IPU2=N-2
21754 VINT(141)=VINT(41)
21755 VINT(142)=VINT(42)
21756 ENDIF
21757 ENDIF
21758
21759C...Keep track of loose colour ends and information on scattering.
21760 370 IMI(1,MINT(31),1)=IPU1
21761 IMI(2,MINT(31),1)=IPU2
21762 IMI(1,MINT(31),2)=0
21763 IMI(2,MINT(31),2)=0
21764 XMI(1,MINT(31))=VINT(141)
21765 XMI(2,MINT(31))=VINT(142)
21766 PT2MI(MINT(31))=VINT(54)
21767 IMISEP(MINT(31))=N
21768
21769C...Decide whether quarks in last scattering were valence, companion or
21770C...sea.
21771 DO 430 JS=1,2
21772 KFBEAM=MINT(10+JS)
21773 KFSBM=ISIGN(1,MINT(10+JS))
21774 IFL=K(IMI(JS,MINT(31),1),2)
21775 IMI(JS,MINT(31),2)=0
21776 IF (IABS(IFL).GT.6) GOTO 430
21777
21778C...Get PDFs at X and Q2 of the parton shower initiator for the
21779C...last scattering. At this point VINT(143:144) do not yet
21780C...include the scattered x values VINT(141:142).
21781 X=VINT(140+JS)/VINT(142+JS)
21782 IF(MSTP(84).GE.1.AND.MSTP(61).GE.1) THEN
21783 Q2=PARP(62)**2
21784 ELSE
21785 Q2=VINT(54)
21786 ENDIF
21787C...Note: XPSVC = x*pdf.
21788 MINT(30)=JS
21789C.... ALICE
21790C.... Store side in MINT(124)
21791 MINT(124) = JS
21792C....
21793 CALL PYPDFU(KFBEAM,X,Q2,XPQ)
21794 SEA=XPSVC(IFL,-1)
21795 VAL=XPSVC(IFL,0)
21796 CMP=0D0
21797 DO 380 IVC=1,NVC(JS,IFL)
21798 CMP=CMP+XPSVC(IFL,IVC)
21799 380 CONTINUE
21800
21801C...Decide (Extra factor x cancels in the dvision).
21802 RVCS=PYR(0)*(SEA+VAL+CMP)
21803 IVNOW=1
21804 390 IF (RVCS.LE.VAL.AND.IVNOW.GE.1) THEN
21805C...Safety check that valence present; pi0/gamma/K0S/K0L special cases.
21806 IVNOW=0
21807 IF(KFIVAL(JS,1).EQ.IFL) IVNOW=IVNOW+1
21808 IF(KFIVAL(JS,2).EQ.IFL) IVNOW=IVNOW+1
21809 IF(KFIVAL(JS,3).EQ.IFL) IVNOW=IVNOW+1
21810 IF(KFIVAL(JS,1).EQ.0) THEN
21811 IF(KFBEAM.EQ.111.AND.IABS(IFL).LE.2) IVNOW=1
21812 IF(KFBEAM.EQ.22.AND.IABS(IFL).LE.5) IVNOW=1
21813 IF((KFBEAM.EQ.130.OR.KFBEAM.EQ.310).AND.
21814 & (IABS(IFL).EQ.1.OR.IABS(IFL).EQ.3)) IVNOW=1
21815 ELSE
21816 DO 400 I1=1,NMI(JS)
21817 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
21818 & IVNOW=IVNOW-1
21819 400 CONTINUE
21820 ENDIF
21821 IF(IVNOW.EQ.0) GOTO 390
21822C...Mark valence.
21823 IMI(JS,MINT(31),2)=0
21824C...Sets valence content of gamma, pi0, K0S, K0L if not done.
21825 IF(KFIVAL(JS,1).EQ.0) THEN
21826 IF(KFBEAM.EQ.111.OR.KFBEAM.EQ.22) THEN
21827 KFIVAL(JS,1)=IFL
21828 KFIVAL(JS,2)=-IFL
21829 ELSEIF(KFBEAM.EQ.130.OR.KFBEAM.EQ.310) THEN
21830 KFIVAL(JS,1)=IFL
21831 IF(IABS(IFL).EQ.1) KFIVAL(JS,2)=ISIGN(3,-IFL)
21832 IF(IABS(IFL).NE.1) KFIVAL(JS,2)=ISIGN(1,-IFL)
21833 ENDIF
21834 ENDIF
21835
21836 ELSEIF (RVCS.LE.VAL+SEA.OR.NVC(JS,IFL).EQ.0) THEN
21837C...If sea, add opposite sign companion parton. Store X and I.
21838 NVC(JS,-IFL)=NVC(JS,-IFL)+1
21839 XASSOC(JS,-IFL,NVC(JS,-IFL))=X
21840C...Set pointer to companion
21841 IMI(JS,MINT(31),2)=-NVC(JS,-IFL)
21842 ELSE
21843C...If companion, decide which one.
21844 CMPSUM=VAL+SEA
21845 ISEL=0
21846 410 ISEL=ISEL+1
21847 CMPSUM=CMPSUM+XPSVC(IFL,ISEL)
21848 IF (RVCS.GT.CMPSUM.AND.ISEL.LT.NVC(JS,IFL)) GOTO 410
21849C...Find original sea (anti-)quark:
21850 IASSOC=0
21851 DO 420 I1=1,NMI(JS)
21852 IF (K(IMI(JS,I1,1),2).NE.-IFL) GOTO 420
21853 IF (-IMI(JS,I1,2).EQ.ISEL) THEN
21854 IMI(JS,MINT(31),2)=IMI(JS,I1,1)
21855 IMI(JS,I1,2)=IMI(JS,MINT(31),1)
21856 ENDIF
21857 420 CONTINUE
21858C...Change X to what associated companion had, so that the correct
21859C...amount of momentum can be subtracted from the companion sum below.
21860 X=XASSOC(JS,IFL,ISEL)
21861C...Mark companion read.
21862 XASSOC(JS,IFL,ISEL)=0D0
21863 ENDIF
21864 430 CONTINUE
21865
21866C...Global statistics.
21867 MINT(351)=MINT(351)+1
21868 VINT(351)=VINT(351)+PT
21869 IF (MINT(351).EQ.1) VINT(356)=PT
21870
21871C...Update remaining energy and other counters.
21872 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
21873 CALL PYERRM(11,'(PYMIGN:) no more memory left in PYJETS')
21874 MINT(51)=1
21875 RETURN
21876 ENDIF
21877 NMI(1)=NMI(1)+1
21878 NMI(2)=NMI(2)+1
21879 VINT(151)=VINT(151)+VINT(41)
21880 VINT(152)=VINT(152)+VINT(42)
21881 VINT(143)=VINT(143)-VINT(141)
21882 VINT(144)=VINT(144)-VINT(142)
21883
21884C...Iterate, with more interactions allowed.
21885 IF(MINT(31).LT.240) GOTO 240
21886 440 CONTINUE
21887
21888C...Restore saved quantities for hardest interaction.
21889 MINT(1)=ISUBSV
21890 MINT(13)=M13SV
21891 MINT(14)=M14SV
21892 MINT(15)=M15SV
21893 MINT(16)=M16SV
21894 MINT(21)=M21SV
21895 MINT(22)=M22SV
21896 DO 450 J=11,80
21897 VINT(J)=VINTSV(J)
21898 450 CONTINUE
21899 VINT(141)=V141SV
21900 VINT(142)=V142SV
21901
21902 ENDIF
21903
21904C...Format statements for printout.
21905 5000 FORMAT(/1X,'****** PYMIGN: initialization of multiple inter',
21906 &'actions for MSTP(82) =',I2,' ******')
21907 5100 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21908 &D9.2,' mb: rejected')
21909 5200 FORMAT(8X,'pT0 =',F5.2,' GeV gives sigma(parton-parton) =',1P,
21910 &D9.2,' mb: accepted')
21911
21912 RETURN
21913 END
21914
21915C*********************************************************************
21916
21917C...PYMIHK
21918C...Finds left-behind remnant flavour content and hooks up
21919C...the colour flow between the hard scattering and remnants
21920
21921 SUBROUTINE PYMIHK
21922
21923C...Double precision and integer declarations.
21924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
21925 IMPLICIT INTEGER(I-N)
21926 INTEGER PYK,PYCHGE,PYCOMP
21927C...The event record
21928 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
21929C...Parameters
21930 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
21931 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
21932 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
21933 COMMON/PYINT1/MINT(400),VINT(400)
21934C...The common block of dangling ends
21935 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
21936 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
21937 & XMI(2,240),PT2MI(240),IMISEP(0:240)
21938 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINTM/
21939C...Local variables
21940 PARAMETER (NERSIZ=4000)
21941 COMMON /PYCBLS/MCO(NERSIZ,2),NCC,JCCO(NERSIZ,2),JCCN(NERSIZ,2)
21942 & ,MACCPT
21943 COMMON /PYCTAG/NCT,MCT(NERSIZ,2)
21944 SAVE /PYCBLS/,/PYCTAG/
21945 DIMENSION JST(2,3),IV(2,3),IDQ(3),NVSUM(2),NBRTOT(2),NG(2)
21946 & ,ITJUNC(2),MOUT(2),INSR(1000,3),ISTR(6),YMI(240)
21947 DATA NERRPR/0/
21948 SAVE NERRPR
21949 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)
21950
21951C...Set up error checkers
21952 IBOOST=0
21953
21954C...Initialize colour arrays: MCO (Original) and MCT (New)
21955 DO 110 I=MINT(84)+1,NERSIZ
21956 DO 100 JC=1,2
21957 MCT(I,JC)=0
21958 MCO(I,JC)=0
21959 100 CONTINUE
21960C...Also zero colour tracing information, if existed.
21961 IF (I.LE.N) THEN
21962 K(I,4)=MOD(K(I,4),MSTU(5)**2)
21963 K(I,5)=MOD(K(I,5),MSTU(5)**2)
21964 ENDIF
21965 110 CONTINUE
21966
21967C...Initialize colour tag collapse arrays:
21968C...JCCO (Original) and JCCN (New).
21969 DO 130 MG=MINT(84)+1,NERSIZ
21970 DO 120 JC=1,2
21971 JCCO(MG,JC)=0
21972 JCCN(MG,JC)=0
21973 120 CONTINUE
21974 130 CONTINUE
21975
21976C...Zero gluon insertion array
21977 DO 150 IM=1,1000
21978 DO 140 J=1,3
21979 INSR(IM,J)=0
21980 140 CONTINUE
21981 150 CONTINUE
21982
21983C...Compute hard scattering system rapidities
21984 IF (MSTP(89).EQ.1) THEN
21985 DO 160 IM=1,240
21986 IF (IM.LE.MINT(31)) THEN
21987 YMI(IM)=LOG(XMI(1,IM)/XMI(2,IM))
21988 ELSE
21989C...Set (unsigned) rapidity = 100 for beam remnant systems.
21990 YMI(IM)=100D0
21991 ENDIF
21992 160 CONTINUE
21993 ENDIF
21994
21995C...Treat each side separately
21996 DO 290 JS=1,2
21997
21998C...Initialize side.
21999 NG(JS)=0
22000 JV=0
22001 KFS=ISIGN(1,MINT(10+JS))
22002
22003C...Set valence content of pi0, gamma, K0S, K0L if not yet done.
22004 IF(KFIVAL(JS,1).EQ.0) THEN
22005 IF(MINT(10+JS).EQ.111) THEN
22006 KFIVAL(JS,1)=INT(1.5D0+PYR(0))
22007 KFIVAL(JS,2)=-KFIVAL(JS,1)
22008 ELSEIF(MINT(10+JS).EQ.22) THEN
22009 PYRKF=PYR(0)
22010 KFIVAL(JS,1)=1
22011 IF(PYRKF.GT.0.1D0) KFIVAL(JS,1)=2
22012 IF(PYRKF.GT.0.5D0) KFIVAL(JS,1)=3
22013 IF(PYRKF.GT.0.6D0) KFIVAL(JS,1)=4
22014 KFIVAL(JS,2)=-KFIVAL(JS,1)
22015 ELSEIF(MINT(10+JS).EQ.130.OR.MINT(10+JS).EQ.310) THEN
22016 IF(PYR(0).GT.0.5D0) THEN
22017 KFIVAL(JS,1)=1
22018 KFIVAL(JS,2)=-3
22019 ELSE
22020 KFIVAL(JS,1)=3
22021 KFIVAL(JS,2)=-1
22022 ENDIF
22023 ENDIF
22024 ENDIF
22025
22026C...Initialize beam remnant sea and valence content flavour by flavour.
22027 NVSUM(JS)=0
22028 NBRTOT(JS)=0
22029 DO 210 JFA=1,6
22030C...Count up original number of JFA valence quarks and antiquarks.
22031 NVALQ=0
22032 NVALQB=0
22033 NSEA=0
22034 DO 170 J=1,3
22035 IF(KFIVAL(JS,J).EQ.JFA) NVALQ=NVALQ+1
22036 IF(KFIVAL(JS,J).EQ.-JFA) NVALQB=NVALQB+1
22037 170 CONTINUE
22038 NVSUM(JS)=NVSUM(JS)+NVALQ+NVALQB
22039C...Subtract kicked out valence and determine sea from flavour cons.
22040 DO 180 IM=1,NMI(JS)
22041 IFL = K(IMI(JS,IM,1),2)
22042 IFA = IABS(IFL)
22043 IFS = ISIGN(1,IFL)
22044 IF (IFL.EQ.JFA.AND.IMI(JS,IM,2).EQ.0) THEN
22045C...Subtract K.O. valence quark from remainder.
22046 NVALQ=NVALQ-1
22047 JV=NVSUM(JS)-NVALQ-NVALQB
22048 IV(JS,JV)=IMI(JS,IM,1)
22049 ELSEIF (IFL.EQ.-JFA.AND.IMI(JS,IM,2).EQ.0) THEN
22050C...Subtract K.O. valence antiquark from remainder.
22051 NVALQB=NVALQB-1
22052 JV=NVSUM(JS)-NVALQ-NVALQB
22053 IV(JS,JV)=IMI(JS,IM,1)
22054 ELSEIF (IFA.EQ.JFA) THEN
22055C...Outside sea without companion: add opposite sea flavour inside.
22056 IF (IMI(JS,IM,2).LT.0) NSEA=NSEA-IFS
22057 ENDIF
22058 180 CONTINUE
22059C...Check if space left in PYJETS for additional BR flavours
22060 NFLSUM=IABS(NSEA)+NVALQ+NVALQB
22061 NBRTOT(JS)=NBRTOT(JS)+NFLSUM
22062 IF (N+NFLSUM+1.GT.MSTU(4)) THEN
22063 CALL PYERRM(11,'(PYMIHK:) no more memory left in PYJETS')
22064 MINT(51)=1
22065 RETURN
22066 ENDIF
22067C...Add required val+sea content to beam remnant.
22068 IF (NFLSUM.GT.0) THEN
22069 DO 200 IA=1,NFLSUM
22070C...Insert beam remnant quark as p.t. symbolic parton in ER.
22071 N=N+1
22072 DO 190 IX=1,5
22073 K(N,IX)=0
22074 P(N,IX)=0D0
22075 V(N,IX)=0D0
22076 190 CONTINUE
22077 K(N,1)=3
22078 K(N,2)=ISIGN(JFA,NSEA)
22079 IF (IA.LE.NVALQ) K(N,2)=JFA
22080 IF (IA.GT.NVALQ.AND.IA.LE.NVALQ+NVALQB) K(N,2)=-JFA
22081 K(N,3)=MINT(83)+JS
22082C...Also update NMI, IMI, and IV arrays.
22083 NMI(JS)=NMI(JS)+1
22084 IMI(JS,NMI(JS),1)=N
22085 IMI(JS,NMI(JS),2)=-1
22086 IF (IA.LE.NVALQ+NVALQB) THEN
22087 IMI(JS,NMI(JS),2)=0
22088 JV=JV+1
22089 IV(JS,JV)=IMI(JS,NMI(JS),1)
22090 ENDIF
22091 200 CONTINUE
22092 ENDIF
22093 210 CONTINUE
22094
22095 IM=0
22096 220 IM=IM+1
22097 IF (IM.LE.NMI(JS)) THEN
22098 IF (K(IMI(JS,IM,1),2).EQ.21) THEN
22099 NG(JS)=NG(JS)+1
22100C...Add fictitious parent gluons for companion pairs.
22101 ELSEIF (IMI(JS,IM,2).NE.0.AND.K(IMI(JS,IM,1),2).GT.0) THEN
22102C...Randomly assign companions to sea quarks which have none.
22103 IF (IMI(JS,IM,2).LT.0) THEN
22104 IMC=PYR(0)*NMI(JS)
22105 230 IMC=MOD(IMC,NMI(JS))+1
22106 IF (K(IMI(JS,IMC,1),2).NE.-K(IMI(JS,IM,1),2)) GOTO 230
22107 IF (IMI(JS,IMC,2).GE.0) GOTO 230
22108 IMI(JS, IM,2) = IMI(JS,IMC,1)
22109 IMI(JS,IMC,2) = IMI(JS, IM,1)
22110 ENDIF
22111C...Add fictitious parent gluon
22112 N=N+1
22113 DO 240 IX=1,5
22114 K(N,IX)=0
22115 P(N,IX)=0D0
22116 V(N,IX)=0D0
22117 240 CONTINUE
22118 K(N,1)=14
22119 K(N,2)=21
22120 K(N,3)=MINT(83)+JS
22121C...Set gluon (anti-)colour daughter pointers
22122 K(N,4)=IMI(JS, IM,1)
22123 K(N,5)=IMI(JS, IM,2)
22124C...Set quark (anti-)colour parent pointers
22125 K(IMI(JS, IM,2),5)=K(IMI(JS, IM,2),5)+MSTU(5)*N
22126 K(IMI(JS, IM,1),4)=K(IMI(JS, IM,1),4)+MSTU(5)*N
22127C...Add gluon to IMI
22128 NMI(JS)=NMI(JS)+1
22129 IMI(JS,NMI(JS),1)=N
22130 IMI(JS,NMI(JS),2)=0
22131 ENDIF
22132 GOTO 220
22133 ENDIF
22134
22135C...If incoming (anti-)baryon, insert inside (anti-)junction.
22136C...Set up initial v-v-j-v configuration. Otherwise set up
22137C...mesonic v-vbar configuration
22138 IF (IABS(MINT(10+JS)).GT.1000) THEN
22139C...Determine junction type (1: B=1 2: B=-1)
22140 ITJUNC(JS) = (3-KFS)/2
22141C...Insert junction.
22142 N=N+1
22143 DO 250 IX=1,5
22144 K(N,IX)=0
22145 P(N,IX)=0D0
22146 V(N,IX)=0D0
22147 250 CONTINUE
22148C...Set special junction codes:
22149 K(N,1)=42
22150 K(N,2)=88
22151C...Set parent to side.
22152 K(N,3)=MINT(83)+JS
22153 K(N,4)=ITJUNC(JS)*MSTU(5)
22154 K(N,5)=0
22155C...Connect valence quarks to junction.
22156 MOUT(JS)=0
22157 MANTI=ITJUNC(JS)-1
22158C...Set (anti)colour mother = junction.
22159 DO 260 JV=1,3
22160 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
22161 & +MSTU(5)*N
22162C...Keep track of partons adjacent to junction:
22163 JST(JS,JV)=IV(JS,JV)
22164 260 CONTINUE
22165 ELSE
22166C...Mesons: set up initial q-qbar topology
22167 ITJUNC(JS)=0
22168 IF (K(IV(JS,1),2).GT.0) THEN
22169 IQ=IV(JS,1)
22170 IQBAR=IV(JS,2)
22171 ELSE
22172 IQ=IV(JS,2)
22173 IQBAR=IV(JS,1)
22174 ENDIF
22175 IV(JS,3)=0
22176 JST(JS,1)=IQ
22177 JST(JS,2)=IQBAR
22178 JST(JS,3)=0
22179 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
22180 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
22181C...Special for mesons. Insert gluon if BR empty.
22182 IF (NBRTOT(JS).EQ.0) THEN
22183 N=N+1
22184 DO 270 IX=1,5
22185 K(N,IX)=0
22186 P(N,IX)=0D0
22187 V(N,IX)=0D0
22188 270 CONTINUE
22189 K(N,1)=3
22190 K(N,2)=21
22191 K(N,3)=MINT(83)+JS
22192 K(N,4)=0
22193 K(N,5)=0
22194 NBRTOT(JS)=1
22195 NG(JS)=NG(JS)+1
22196C...Add gluon to IMI
22197 NMI(JS)=NMI(JS)+1
22198 IMI(JS,NMI(JS),1)=N
22199 IMI(JS,NMI(JS),2)=0
22200 ENDIF
22201 MOUT(JS)=0
22202 ENDIF
22203
22204C...Count up number of valence quarks outside BR.
22205 DO 280 JV=1,3
22206 IF (JST(JS,JV).LE.MINT(53).AND.JST(JS,JV).GT.0)
22207 & MOUT(JS)=MOUT(JS)+1
22208 280 CONTINUE
22209
22210 290 CONTINUE
22211
22212C...Now both sides have been prepared in an initial vvjv (baryonic) or
22213C...v(g)vbar (mesonic) configuration.
22214
22215C...Create colour line tags starting from initiators.
22216 NCT=0
22217 DO 320 IM=1,MINT(31)
22218C...Consider each side in turn.
22219 DO 310 JS=1,2
22220 I1=IMI(JS,IM,1)
22221 I2=IMI(3-JS,IM,1)
22222 DO 300 JCS=4,5
22223 IF (K(I1,2).NE.21.AND.(9-2*JCS).NE.ISIGN(1,K(I1,2)))
22224 & GOTO 300
22225 IF (K(I1,JCS)/MSTU(5)**2.NE.0) GOTO 300
22226
22227 KCS=JCS
22228 CALL PYCTTR(I1,KCS,I2)
22229 IF(MINT(51).NE.0) RETURN
22230
22231 300 CONTINUE
22232 310 CONTINUE
22233 320 CONTINUE
22234
22235 DO 340 JS=1,2
22236C...Create colour tags for beam remnant partons.
22237 DO 330 IM=MINT(31)+1,NMI(JS)
22238 IP=IMI(JS,IM,1)
22239 IF (K(IP,2).NE.21) THEN
22240 JC=(3-ISIGN(1,K(IP,2)))/2
22241 IF (MCT(IP,JC).EQ.0) THEN
22242 NCT=NCT+1
22243 MCT(IP,JC)=NCT
22244 ENDIF
22245 ELSE
22246C...Gluons
22247 ICD=K(IP,4)
22248 IAD=K(IP,5)
22249 IF (ICD.NE.0) THEN
22250C...Fictituous gluons just inherit from their quark daughters.
22251 ICC=MCT(ICD,1)
22252 IAC=MCT(IAD,2)
22253 ELSE
22254C...Real beam remnant gluons get their own colours
22255 ICC=NCT+1
22256 IAC=NCT+2
22257 NCT=NCT+2
22258 ENDIF
22259 MCT(IP,1)=ICC
22260 MCT(IP,2)=IAC
22261 ENDIF
22262 330 CONTINUE
22263 340 CONTINUE
22264
22265C...Create colour tags for colour lines which are detached from the
22266C...initial state.
22267
22268 DO 360 MQGST=1,2
22269 DO 350 I=MINT(84)+1,N
22270
22271C...Look for coloured string endpoint, or (later) leftover gluon.
22272 IF (K(I,1).NE.3) GOTO 350
22273 KC=PYCOMP(K(I,2))
22274 IF(KC.EQ.0) GOTO 350
22275 KQ=KCHG(KC,2)
22276 IF(KQ.EQ.0.OR.(MQGST.EQ.1.AND.KQ.EQ.2)) GOTO 350
22277
22278C...Pick up loose string end with no previous tag.
22279 KCS=4
22280 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
22281 IF(MCT(I,KCS-3).NE.0) GOTO 350
22282
22283 CALL PYCTTR(I,KCS,I)
22284 IF(MINT(51).NE.0) RETURN
22285
22286 350 CONTINUE
22287 360 CONTINUE
22288
22289C...Store original colour tags
22290 DO 370 I=MINT(84)+1,N
22291 MCO(I,1)=MCT(I,1)
22292 MCO(I,2)=MCT(I,2)
22293 370 CONTINUE
22294
22295C...Iteratively add gluons to already existing string pieces, enforcing
22296C...various possible orderings, and rejecting insertions that would give
22297C...rise to singlet gluons.
22298C...<kappa tau> normalization.
22299 RM0=1.5D0
22300 MRETRY=0
22301 PARP80=PARP(80)
22302
22303C...Set up simplified kinematics.
22304C...Boost hard interaction systems.
22305 IBOOST=IBOOST+1
22306 DO 380 IM=1,MINT(31)
22307 BETA=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
22308 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
22309 380 CONTINUE
22310C...Assign preliminary beam remnant momenta.
22311 DO 390 I=MINT(53)+1,N
22312 JS=K(I,3)
22313 P(I,1)=0D0
22314 P(I,2)=0D0
22315 IF (K(I,2).NE.88) THEN
22316 P(I,4)=0.5D0*VINT(142+JS)*VINT(1)/MAX(1,NMI(JS)-MINT(31))
22317 P(I,3)=P(I,4)
22318 IF (JS.EQ.2) P(I,3)=-P(I,3)
22319 ELSE
22320C...Junctions are wildcards for the present.
22321 P(I,4)=0D0
22322 P(I,3)=0D0
22323 ENDIF
22324 390 CONTINUE
22325
22326C...Reset colour processing information.
22327 400 DO 410 I=MINT(84)+1,N
22328 K(I,4)=MOD(K(I,4),MSTU(5)**2)
22329 K(I,5)=MOD(K(I,5),MSTU(5)**2)
22330 410 CONTINUE
22331
22332 NCC=0
22333 DO 430 JS=1,2
22334C...If meson, without gluon in BR, collapse q-qbar colour tags:
22335 IF (ITJUNC(JS).EQ.0) THEN
22336 JC1=MCT(JST(JS,1),1)
22337 JC2=MCT(JST(JS,2),2)
22338 NCC=NCC+1
22339 JCCO(NCC,1)=MAX(JC1,JC2)
22340 JCCO(NCC,2)=MIN(JC1,JC2)
22341C...Collapse colour tags in event record
22342 DO 420 I=MINT(84)+1,N
22343 IF (MCT(I,1).EQ.JCCO(NCC,1)) MCT(I,1)=JCCO(NCC,2)
22344 IF (MCT(I,2).EQ.JCCO(NCC,1)) MCT(I,2)=JCCO(NCC,2)
22345 420 CONTINUE
22346 ENDIF
22347 430 CONTINUE
22348
22349 440 JS=1
22350 IF (PYR(0).GT.0.5D0.OR.NG(1).EQ.0) JS=2
22351 IF (NG(JS).GT.0) THEN
22352 NOPT=0
22353 RLOPT=1D9
22354C...Start at random gluon (optimizes speed for random attachments)
22355 NMGL=0
22356 IMGL=PYR(0)*NMI(JS)+1
22357 450 IMGL=MOD(IMGL,NMI(JS))+1
22358 NMGL=NMGL+1
22359C...Only loop through NMI once (with upper limit to save time)
22360 IF (NMGL.LE.NMI(JS).AND.NOPT.LE.3) THEN
22361 IGL = IMI(JS,IMGL,1)
22362C...If not gluon or if already connected, try next.
22363 IF (K(IGL,2).NE.21.OR.K(IGL,4)/MSTU(5).NE.0
22364 & .OR.K(IGL,5)/MSTU(5).NE.0) GOTO 450
22365C...Now loop through all possible insertions of this gluon.
22366 NMP1=0
22367 IMP1=PYR(0)*NMI(JS)+1
22368 460 IMP1=MOD(IMP1,NMI(JS))+1
22369 NMP1=NMP1+1
22370 IF (IMP1.EQ.IMGL) GOTO 460
22371C...Only loop through NMI once (with upper limit to save time).
22372 IF (NMP1.LE.NMI(JS).AND.NOPT.LE.3) THEN
22373 IP1 = IMI(JS,IMP1,1)
22374C...Try both colour mother and colour anti-mother.
22375C...Randomly select which one to try first.
22376 NANTI=0
22377 MANTI=PYR(0)*2
22378 470 MANTI=MOD(MANTI+1,2)
22379 NANTI=NANTI+1
22380 IF (NANTI.LE.2) THEN
22381 IP2 =MOD(K(IP1,4+MANTI)/MSTU(5),MSTU(5))
22382C...Reject if no appropriate mother (or if mother is fictitious
22383C...parent gluon.)
22384 IF (IP2.LE.0) GOTO 470
22385 IF (K(IP2,2).EQ.21.AND.IP2.GT.MINT(53)) GOTO 470
22386C...Also reject if this link has already been tried.
22387 IF (K(IP1,4+MANTI)/MSTU(5)**2.EQ.2) GOTO 470
22388 IF (K(IP2,5-MANTI)/MSTU(5)**2.EQ.2) GOTO 470
22389C...Set flag to indicate that this link has now been tried for this
22390C...gluon. IP2 may be junction, which has several mothers.
22391 K(IP1,4+MANTI)=K(IP1,4+MANTI)+2*MSTU(5)**2
22392 IF (K(IP2,2).NE.88) THEN
22393 K(IP2,5-MANTI)=K(IP2,5-MANTI)+2*MSTU(5)**2
22394 ENDIF
22395
22396C...JCG1: Original colour tag of gluon on IP1 side
22397C...JCG2: Original colour tag of gluon on IP2 side
22398C...JCP1: Original colour tag of IP1 on gluon side
22399C...JCP2: Original colour tag of IP2 on gluon side.
22400 JCG1=MCO(IGL,2-MANTI)
22401 JCG2=MCO(IGL,1+MANTI)
22402 JCP1=MCO(IP1,1+MANTI)
22403 JCP2=MCO(IP2,2-MANTI)
22404
22405 CALL PYMIHG(JCP1,JCG1,JCP2,JCG2)
22406C...Reject gluon attachments that give rise to singlet gluons.
22407 IF (MACCPT.EQ.0) GOTO 470
22408
22409C...Update colours
22410 JCG1=MCT(IGL,2-MANTI)
22411 JCG2=MCT(IGL,1+MANTI)
22412 JCP1=MCT(IP1,1+MANTI)
22413 JCP2=MCT(IP2,2-MANTI)
22414
22415C...Select whether to accept this insertion
22416 IF (MSTP(89).EQ.0) THEN
22417C...Random insertions: no measure.
22418 RL=1D0
22419C...For random ordering, we want to suppress beam remnant breakups
22420C...already at this point.
22421 IF (IP1.GT.MINT(53).AND.IP2.GT.MINT(53)
22422 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) THEN
22423 NMP1=0
22424 NMGL=0
22425 GOTO 470
22426 ENDIF
22427 ELSEIF (MSTP(89).EQ.1) THEN
22428C...Rapidity ordering:
22429C...YGL = Rapidity of gluon.
22430 YGL=YMI(IMGL)
22431C...If fictitious gluon
22432 IF (YGL.EQ.100D0) THEN
22433 YGL=(3-2*JS)*100D0
22434 IDA1=MOD(K(IGL,4),MSTU(5))
22435 IDA2=MOD(K(IGL,5),MSTU(5))
22436 DO 480 IMT=1,NMI(JS)
22437C...Select (arbitrarily) the most central daughter.
22438 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
22439 & THEN
22440 IF (ABS(YGL).GT.ABS(YMI(IMT))) YGL=YMI(IMT)
22441 ENDIF
22442 480 CONTINUE
22443 ENDIF
22444C...YP1 = Rapidity IP1
22445 YP1=YMI(IMP1)
22446C...If fictitious gluon
22447 IF (YP1.EQ.100D0) THEN
22448 YP1=(3-2*JS)*YP1
22449 IDA1=MOD(K(IP1,4),MSTU(5))
22450 IDA2=MOD(K(IP1,5),MSTU(5))
22451 DO 490 IMT=1,NMI(JS)
22452C...Select (arbitrarily) the most central daughter.
22453 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2)
22454 & THEN
22455 IF (ABS(YP1).GT.ABS(YMI(IMT))) YP1=YMI(IMT)
22456 ENDIF
22457 490 CONTINUE
22458 ENDIF
22459C...YP2 = Rapidity of mother system
22460 IF (K(IP2,2).NE.88) THEN
22461 DO 500 IMT=1,NMI(JS)
22462 IF (IMI(JS,IMT,1).EQ.IP2) YP2=YMI(IMT)
22463 500 CONTINUE
22464C...If fictitious gluon
22465 IF (YP2.EQ.100D0) THEN
22466 YP2=(3-2*JS)*YP2
22467 IDA1=MOD(K(IP2,4),MSTU(5))
22468 IDA2=MOD(K(IP2,5),MSTU(5))
22469 DO 510 IMT=1,NMI(JS)
22470C...Select (arbitrarily) the most central daughter.
22471 IF (IMI(JS,IMT,1).EQ.IDA1.OR.IMI(JS,IMT,1).EQ.IDA2
22472 & ) THEN
22473 IF (ABS(YP2).GT.ABS(YMI(IMT))) YP2=YMI(IMT)
22474 ENDIF
22475 510 CONTINUE
22476 ENDIF
22477C...Assign (arbitrarily) 100D0 to junction also
22478 ELSE
22479 YP2=(3-2*JS)*100D0
22480 ENDIF
22481 RL=ABS(YGL-YP1)+ABS(YGL-YP2)
22482 ELSEIF (MSTP(89).EQ.2) THEN
22483C...Lambda ordering:
22484C...Compute lambda measure for this insertion.
22485 RL=1D0
22486 DO 520 IST=1,6
22487 ISTR(IST)=0
22488 520 CONTINUE
22489C...If IP2 is junction, not caught below.
22490 IF (JCP2.EQ.0) THEN
22491 ITJU=MOD(K(IP2,4)/MSTU(5),MSTU(5))
22492C...Anti-junction is colour endpoint et vv., always on JCG2.
22493 ISTR(5-ITJU)=IP2
22494 ENDIF
22495 DO 530 I=MINT(84)+1,N
22496 IF (K(I,1).LT.10) THEN
22497C...The new string pieces
22498 IF (MCT(I,1).EQ.JCG1) ISTR(1)=I
22499 IF (MCT(I,2).EQ.JCG1) ISTR(2)=I
22500 IF (MCT(I,1).EQ.JCG2) ISTR(3)=I
22501 IF (MCT(I,2).EQ.JCG2) ISTR(4)=I
22502 ENDIF
22503 530 CONTINUE
22504C...Also identify junctions as string endpoints.
22505 DO 540 I=MINT(84)+1,N
22506 ICMO=MOD(K(I,4)/MSTU(5),MSTU(5))
22507 IAMO=MOD(K(I,5)/MSTU(5),MSTU(5))
22508C...Find partons adjacent to junctions.
22509 IF (ICMO.GT.0.AND.ICMO.LE.N) THEN
22510 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG1.AND.ISTR(2)
22511 & .EQ.0) ISTR(2) = ICMO
22512 IF (K(ICMO,1).EQ.42.AND.MCT(I,1).EQ.JCG2.AND.ISTR(4)
22513 & .EQ.0) ISTR(4) = ICMO
22514 ENDIF
22515 IF (IAMO.GT.0.AND.IAMO.LE.N) THEN
22516 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG1.AND.ISTR(1)
22517 & .EQ.0) ISTR(1) = IAMO
22518 IF (K(IAMO,1).EQ.42.AND.MCT(I,2).EQ.JCG2.AND.ISTR(3)
22519 & .EQ.0) ISTR(3) = IAMO
22520 ENDIF
22521 540 CONTINUE
22522C...The old string piece
22523 ISTR(5)=ISTR(1+2*MANTI)
22524 ISTR(6)=ISTR(4-2*MANTI)
22525 IF (ISTR(1).EQ.0.OR.ISTR(2).EQ.0.OR.ISTR(3).EQ.0.OR.
22526 & ISTR(4).EQ.0.OR.ISTR(5).EQ.0.OR.ISTR(6).EQ.0) THEN
22527C...If one or more of the colour tags for this connection is/are still
22528C...dangling, skip this attempt for the time being.
22529 RL=1D6
22530 ELSE
22531 RL=MAX(1D0,FOUR(ISTR(1),ISTR(2)))*MAX(1D0,FOUR(ISTR(3)
22532 & ,ISTR(4)))/MAX(1D0,FOUR(ISTR(5),ISTR(6)))
22533 RL=LOG(RL)
22534 ENDIF
22535 ENDIF
22536C...Allow some breadth to speed things up.
22537 IF (ABS(1D0-RL/RLOPT).LT.0.05D0) THEN
22538 NOPT=NOPT+1
22539 ELSEIF (RL.GT.RLOPT) THEN
22540 GOTO 470
22541 ELSE
22542 NOPT=1
22543 RLOPT=RL
22544 ENDIF
22545C...INSR(NOPT,1)=Gluon colour mother
22546C...INSR(NOPT,2)=Gluon
22547C...INSR(NOPT,3)=Gluon anticolour mother
22548 IF (NOPT.GT.1000) GOTO 470
22549 INSR(NOPT,1+2*MANTI)=IP2
22550 INSR(NOPT,2)=IGL
22551 INSR(NOPT,3-2*MANTI)=IP1
22552 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 470
22553 ENDIF
22554 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 460
22555 ENDIF
22556C...Reset link test information.
22557 DO 550 I=MINT(84)+1,N
22558 K(I,4)=MOD(K(I,4),MSTU(5)**2)
22559 K(I,5)=MOD(K(I,5),MSTU(5)**2)
22560 550 CONTINUE
22561 IF (MSTP(89).GT.0.OR.NOPT.EQ.0) GOTO 450
22562 ENDIF
22563C...Now we have a list of best gluon insertions, none of which cause
22564C...singlets to arise. If list is empty, try again a few times. Note:
22565C...this should never happen if we have a meson with a gluon inserted
22566C...in the beam remnant, since that breaks up the colour line.
22567 IF (NOPT.EQ.0) THEN
22568C...Abandon BR-g-BR suppression for retries. This is not serious, it
22569C...just means we happened to start with trying a bad sequence.
22570 PARP80=1D0
22571 IF (MRETRY.LE.10.AND.(ITJUNC(1).NE.0.OR.JST(1,3).EQ.0).AND
22572 & .(ITJUNC(2).NE.0.OR.JST(2,3).EQ.0)) THEN
22573 MRETRY=MRETRY+1
22574 DO 590 JS=1,2
22575 IF (ITJUNC(JS).NE.0) THEN
22576 JST(JS,1)=IV(JS,1)
22577 JST(JS,2)=IV(JS,2)
22578 JST(JS,3)=IV(JS,3)
22579C...Reset valence quark parent pointers
22580 DO 560 I=MINT(53)+1,N
22581 IF (K(I,2).EQ.88.AND.K(I,3).EQ.JS) IJU=I
22582 560 CONTINUE
22583 MANTI=ITJUNC(JS)-1
22584C...Set (anti)colour mother = junction.
22585 DO 570 JV=1,3
22586 K(IV(JS,JV),4+MANTI)=MOD(K(IV(JS,JV),4+MANTI),MSTU(5))
22587 & +MSTU(5)*IJU
22588 570 CONTINUE
22589 ELSE
22590C...Same for mesons. JST unchanged, so needn't be restored.
22591 IQ=JST(JS,1)
22592 IQBAR=JST(JS,2)
22593 K(IQ,4)=MOD(K(IQ,4),MSTU(5))+MSTU(5)*IQBAR
22594 K(IQBAR,5)=MOD(K(IQBAR,5),MSTU(5))+MSTU(5)*IQ
22595 ENDIF
22596C...Also reset gluon parent pointers.
22597 NG(JS)=0
22598 DO 580 IM=1,NMI(JS)
22599 I=IMI(JS,IM,1)
22600 IF (K(I,2).EQ.21) THEN
22601 K(I,4)=MOD(K(I,4),MSTU(5))
22602 K(I,5)=MOD(K(I,5),MSTU(5))
22603 NG(JS)=NG(JS)+1
22604 ENDIF
22605 580 CONTINUE
22606 590 CONTINUE
22607C...Reset colour tags
22608 DO 600 I=MINT(84)+1,N
22609 MCT(I,1)=MCO(I,1)
22610 MCT(I,2)=MCO(I,2)
22611 600 CONTINUE
22612 GOTO 400
22613 ELSE
22614 IF(NERRPR.LT.5) THEN
22615 NERRPR=NERRPR+1
22616 CALL PYLIST(4)
22617 CALL PYERRM(19,'(PYMIHK:) No physical colour flow found!')
22618 WRITE(MSTU(11),*) 'NG:', NG,' MOUT:', MOUT(JS)
22619 ENDIF
22620C...Kill event and start another.
22621 MINT(51)=1
22622 RETURN
22623 ENDIF
22624 ELSE
22625C...Select between insertions, suppressing insertions wholly in the BR.
22626 IIN=PYR(0)*NOPT+1
22627 610 IIN=MOD(IIN,NOPT)+1
22628 IF (INSR(IIN,1).GT.MINT(53).AND.INSR(IIN,3).GT.MINT(53)
22629 & .AND.MOUT(JS).NE.0.AND.PYR(0).GT.PARP80) GOTO 610
22630 ENDIF
22631
22632C...Now we know which gluon to insert where. Colour tags in JCCO and
22633C...colour connection information should be updated, NG(JS) should be
22634C...counted down, and a new loop performed if there are still gluons
22635C...left on any side.
22636 ICM=INSR(IIN,1)
22637 IACM=INSR(IIN,3)
22638 IGL=INSR(IIN,2)
22639C...JCG : Original gluon colour tag
22640C...JCAG: Original gluon anticolour tag.
22641C...JCM : Original anticolour tag of gluon colour mother
22642C...JACM: Original colour tag of gluon anticolour mother
22643 JCG=MCO(IGL,1)
22644 JCM=MCO(ICM,2)
22645 JACG=MCO(IGL,2)
22646 JACM=MCO(IACM,1)
22647
22648 CALL PYMIHG(JACM,JACG,JCM,JCG)
22649 IF (MACCPT.EQ.0) THEN
22650 IF(NERRPR.LT.5) THEN
22651 NERRPR=NERRPR+1
22652 CALL PYLIST(4)
22653 CALL PYERRM(11,'(PYMIHK:) Unphysical colour flow!')
22654 WRITE(MSTU(11),*) 'attaching', IGL,' between', ICM, IACM
22655 ENDIF
22656C...Kill event and start another.
22657 MINT(51)=1
22658 RETURN
22659 ELSE
22660C...If everything went fine, store new JCCN in JCCO.
22661 NCC=NCC+1
22662 DO 620 ICC=1,NCC
22663 JCCO(ICC,1)=JCCN(ICC,1)
22664 JCCO(ICC,2)=JCCN(ICC,2)
22665 620 CONTINUE
22666 ENDIF
22667
22668C...One gluon attached is counted as equivalent to one end outside.
22669 MOUT(JS)=1
22670C...Set IGL colour mother = ICM.
22671 K(IGL,4)=MOD(K(IGL,4),MSTU(5))+MSTU(5)*ICM
22672C...Set ICM anticolour mother = IGL colour.
22673 IF (K(ICM,2).NE.88) THEN
22674 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*IGL
22675 ELSE
22676C...If ICM is junction, just update JST array for now.
22677 DO 630 MSJ=1,3
22678 IF (JST(JS,MSJ).EQ.IACM) JST(JS,MSJ)=IGL
22679 630 CONTINUE
22680 ENDIF
22681C...Set IGL anticolour mother = IACM.
22682 K(IGL,5)=MOD(K(IGL,5),MSTU(5))+MSTU(5)*IACM
22683C...Set IACM anticolour mother = IGL anticolour.
22684 IF (K(IACM,2).NE.88) THEN
22685 K(IACM,4)=MOD(K(IACM,4),MSTU(5))+MSTU(5)*IGL
22686 ELSE
22687C...If IACM is junction, just update JST array for now.
22688 DO 640 MSJ=1,3
22689 IF (JST(JS,MSJ).EQ.ICM) JST(JS,MSJ)=IGL
22690 640 CONTINUE
22691 ENDIF
22692C...Count down # unconnected gluons.
22693 NG(JS)=NG(JS)-1
22694 ENDIF
22695 IF (NG(1).GT.0.OR.NG(2).GT.0) GOTO 440
22696
22697 DO 840 JS=1,2
22698C...Collapse fictitious gluons.
22699 DO 670 IGL=MINT(53)+1,N
22700 IF (K(IGL,2).EQ.21.AND.K(IGL,3).EQ.MINT(83)+JS.AND.
22701 & K(IGL,1).EQ.14) THEN
22702 ICM=K(IGL,4)/MSTU(5)
22703 IAM=K(IGL,5)/MSTU(5)
22704 ICD=MOD(K(IGL,4),MSTU(5))
22705 IAD=MOD(K(IGL,5),MSTU(5))
22706C...Set gluon daughters pointing to gluon mothers
22707 K(IAD,5)=MOD(K(IAD,5),MSTU(5))+MSTU(5)*IAM
22708 K(ICD,4)=MOD(K(ICD,4),MSTU(5))+MSTU(5)*ICM
22709C...Set gluon mothers pointing to gluon daughters.
22710 IF (K(ICM,2).NE.88) THEN
22711 K(ICM,5)=MOD(K(ICM,5),MSTU(5))+MSTU(5)*ICD
22712 ELSE
22713C...Special case: mother=junction. Just update JST array for now.
22714 DO 650 MSJ=1,3
22715 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=ICD
22716 650 CONTINUE
22717 ENDIF
22718 IF (K(IAM,2).NE.88) THEN
22719 K(IAM,4)=MOD(K(IAM,4),MSTU(5))+MSTU(5)*IAD
22720 ELSE
22721 DO 660 MSJ=1,3
22722 IF (JST(JS,MSJ).EQ.IGL) JST(JS,MSJ)=IAD
22723 660 CONTINUE
22724 ENDIF
22725 ENDIF
22726 670 CONTINUE
22727
22728C...Erase collapsed gluons from NMI and IMI (but keep them in ER)
22729 IM=NMI(JS)+1
22730 680 IM=IM-1
22731 IF (IM.GT.MINT(31).AND.K(IMI(JS,IM,1),2).NE.21) GOTO 680
22732 IF (IM.GT.MINT(31)) THEN
22733 NMI(JS)=NMI(JS)-1
22734 DO 690 IMR=IM,NMI(JS)
22735 IMI(JS,IMR,1)=IMI(JS,IMR+1,1)
22736 IMI(JS,IMR,2)=IMI(JS,IMR+1,2)
22737 690 CONTINUE
22738 GOTO 680
22739 ENDIF
22740
22741C...Finally, connect junction.
22742 IF (ITJUNC(JS).NE.0) THEN
22743 DO 700 I=MINT(53)+1,N
22744 IF (K(I,2).EQ.88.AND.K(I,3).EQ.MINT(83)+JS) IJU=I
22745 700 CONTINUE
22746C...NBRJQ counts # of jq, NBRVQ # of jv, inside BR.
22747 NBRJQ =0
22748 NBRVQ =0
22749 DO 720 MSJ=1,3
22750 IDQ(MSJ)=0
22751C...Find jq with no glue inbetween inside beam remnant.
22752 IF (JST(JS,MSJ).GT.MINT(53).AND.IABS(K(JST(JS,MSJ),2)).LE.5)
22753 & THEN
22754 NBRJQ=NBRJQ+1
22755C...Set IDQ = -I if q non-valence and = +I if q valence.
22756 IDQ(NBRJQ)=-JST(JS,MSJ)
22757 DO 710 JV=1,3
22758 IF (IV(JS,JV).EQ.JST(JS,MSJ)) THEN
22759 IDQ(NBRJQ)=JST(JS,MSJ)
22760 NBRVQ=NBRVQ+1
22761 ENDIF
22762 710 CONTINUE
22763 ENDIF
22764 I12=MOD(MSJ+1,2)
22765 I45=5
22766 IF (MSJ.EQ.3) I45=4
22767 K(IJU,I45)=K(IJU,I45)+(MSTU(5)**I12)*JST(JS,MSJ)
22768 720 CONTINUE
22769
22770C...Check if diquark can be formed.
22771 IF ((MSTP(88).GE.0.AND.NBRVQ.GE.2).OR.(NBRJQ.GE.2.AND.MSTP(88)
22772 & .GE.1)) THEN
22773C...If there is less than 2 valence quarks connected to junction
22774C...and MSTP(88)>1, use random non-valence quarks to fill up.
22775 IF (NBRVQ.LE.1) THEN
22776 NDIQ=NBRVQ
22777 730 JFLIP=NBRJQ*PYR(0)+1
22778 IF (IDQ(JFLIP).LT.0) THEN
22779 IDQ(JFLIP)=-IDQ(JFLIP)
22780 NDIQ=NDIQ+1
22781 ENDIF
22782 IF (NDIQ.LE.1) GOTO 730
22783 ENDIF
22784C...Place selected quarks first in IDQ, ordered in flavour.
22785 DO 740 JDQ=1,3
22786 IF (IDQ(JDQ).LE.0) THEN
22787 ITEMP1 = IDQ(JDQ)
22788 IDQ(JDQ)= IDQ(3)
22789 IDQ(3) = -ITEMP1
22790 IF (IABS(K(IDQ(1),2)).LT.IABS(K(IDQ(2),2))) THEN
22791 ITEMP1 = IDQ(1)
22792 IDQ(1) = IDQ(2)
22793 IDQ(2) = ITEMP1
22794 ENDIF
22795 ENDIF
22796 740 CONTINUE
22797C...Choose diquark spin.
22798 IF (NBRVQ.EQ.2) THEN
22799C...If the selected quarks are both valence, we may use SU(6) rules
22800C...to figure out which spin the diquark has, by a subdivision of the
22801C...original beam hadron into the selected diquark system plus a kicked
22802C...out quark, IKO.
22803 JKO=6
22804 DO 760 JDQ=1,2
22805 DO 750 JV=1,3
22806 IF (IDQ(JDQ).EQ.IV(JS,JV)) JKO=JKO-JV
22807 750 CONTINUE
22808 760 CONTINUE
22809 IKO=IV(JS,JKO)
22810 CALL PYSPLI(MINT(10+JS),K(IKO,2),KFDUM,KFDQ)
22811 ELSE
22812C...If one or more of the selected quarks are not valence, we cannot use
22813C...SU(6) subdivisions of the original beam hadron. Instead, with the
22814C...flavours of the diquark already selected, we assume for now
22815C...50:50 spin-1:spin-0 (where spin-0 possible).
22816 KFDQ=1000*K(IDQ(1),2)+100*K(IDQ(2),2)
22817 IS=3
22818 IF (K(IDQ(1),2).NE.K(IDQ(2),2).AND.
22819 & (1D0+3D0*PARJ(4))*PYR(0).LT.1D0) IS=1
22820 KFDQ=KFDQ+ISIGN(IS,KFDQ)
22821 ENDIF
22822
22823C...Collapse diquark-j-quark system to baryon, if allowed and possible.
22824C...Note: third quark can per definition not also be valence,
22825C...therefore we can only do this if we are allowed to use sea quarks.
22826 770 IF (IDQ(3).NE.0.AND.MSTP(88).GE.2) THEN
22827 NTRY=0
22828 780 NTRY=NTRY+1
22829 CALL PYKFDI(KFDQ,K(IABS(IDQ(3)),2),KFDUM,KFBAR)
22830 IF (KFBAR.EQ.0.AND.NTRY.LE.100) THEN
22831 GOTO 780
22832 ELSEIF(NTRY.GT.100) THEN
22833C...If no baryon can be found, give up and form diquark.
22834 IDQ(3)=0
22835 GOTO 770
22836 ELSE
22837C...Replace junction by baryon.
22838 K(IJU,1)=1
22839 K(IJU,2)=KFBAR
22840 K(IJU,3)=MINT(83)+JS
22841 K(IJU,4)=0
22842 K(IJU,5)=0
22843 P(IJU,5)=PYMASS(KFBAR)
22844 DO 790 MSJ=1,3
22845C...Prepare removal of participating quarks from ER.
22846 K(JST(JS,MSJ),1)=-1
22847 790 CONTINUE
22848 ENDIF
22849 ELSE
22850C...If collapse to baryon not possible or not allowed, replace junction
22851C...by diquark. This way, collapsed gluons that were pointing at the
22852C...junction will now point (correctly) at diquark.
22853 MANTI=ITJUNC(JS)-1
22854 K(IJU,1)=3
22855 K(IJU,2)=KFDQ
22856 K(IJU,3)=MINT(83)+JS
22857 K(IJU,4)=0
22858 K(IJU,5)=0
22859 DO 800 MSJ=1,3
22860 IP=JST(JS,MSJ)
22861 IF (IP.NE.IDQ(1).AND.IP.NE.IDQ(2)) THEN
22862 K(IJU,4+MANTI)=0
22863 K(IJU,5-MANTI)=IP*MSTU(5)
22864 K(IP,4+MANTI)=MOD(K(IP,4+MANTI),MSTU(5))+
22865 & MSTU(5)*IJU
22866 MCT(IJU,2-MANTI)=MCT(IP,1+MANTI)
22867 ELSE
22868C...Prepare removal of participating quarks from ER.
22869 K(IP,1)=-1
22870 ENDIF
22871 800 CONTINUE
22872 ENDIF
22873
22874C...Update so ER pointers to collapsed quarks
22875C...now go to collapsed object.
22876 DO 820 I=MINT(84)+1,N
22877 IF ((K(I,3).EQ.MINT(83)+JS.OR.K(I,3).EQ.MINT(83)+2+JS).AND
22878 & .K(I,1).GT.0) THEN
22879 DO 810 ISID=4,5
22880 IMO=K(I,ISID)/MSTU(5)
22881 IDA=MOD(K(I,ISID),MSTU(5))
22882 IF (IMO.GT.0) THEN
22883 IF (K(IMO,1).EQ.-1) IMO=IJU
22884 ENDIF
22885 IF (IDA.GT.0) THEN
22886 IF (K(IDA,1).EQ.-1) IDA=IJU
22887 ENDIF
22888 K(I,ISID)=IDA+MSTU(5)*IMO
22889 810 CONTINUE
22890 ENDIF
22891 820 CONTINUE
22892 ENDIF
22893 ENDIF
22894
22895C...Finally, if beam remnant is empty, insert a gluon in beam remnant.
22896C...(this only happens for baryons, where we want to force the gluon
22897C...to sit next to the junction. Mesons handled above.)
22898 IF (NBRTOT(JS).EQ.0) THEN
22899 N=N+1
22900 DO 830 IX=1,5
22901 K(N,IX)=0
22902 P(N,IX)=0D0
22903 V(N,IX)=0D0
22904 830 CONTINUE
22905 IGL=N
22906 K(IGL,1)=3
22907 K(IGL,2)=21
22908 K(IGL,3)=MINT(83)+JS
22909 IF (ITJUNC(JS).NE.0) THEN
22910C...Incoming baryons. Pick random leg in JST (NVSUM = 3 for baryons)
22911 JLEG=PYR(0)*NVSUM(JS)+1
22912 I1=JST(JS,JLEG)
22913 JST(JS,JLEG)=IGL
22914 JCT=MCT(I1,ITJUNC(JS))
22915 MCT(IGL,3-ITJUNC(JS))=JCT
22916 NCT=NCT+1
22917 MCT(IGL,ITJUNC(JS))=NCT
22918 MANTI=ITJUNC(JS)-1
22919 ELSE
22920C...Meson. Should not happen.
22921 CALL PYERRM(19,'(PYMIHK:) Empty meson beam remnant')
22922 IF(NERRPR.LT.5) THEN
22923 WRITE(MSTU(11),*) 'This should not have been possible!'
22924 CALL PYLIST(4)
22925 NERRPR=NERRPR+1
22926 ENDIF
22927 MINT(51)=1
22928 RETURN
22929 ENDIF
22930 I2=MOD(K(I1,4+MANTI)/MSTU(5),MSTU(5))
22931 K(I1,4+MANTI)=MOD(K(I1,4+MANTI),MSTU(5))+MSTU(5)*IGL
22932 K(IGL,5-MANTI)=MOD(K(IGL,5-MANTI),MSTU(5))+MSTU(5)*I1
22933 K(IGL,4+MANTI)=MOD(K(IGL,4+MANTI),MSTU(5))+MSTU(5)*I2
22934 IF (K(I2,2).NE.88) THEN
22935 K(I2,5-MANTI)=MOD(K(I2,5-MANTI),MSTU(5))+MSTU(5)*IGL
22936 ELSE
22937 IF (MOD(K(I2,4),MSTU(5)).EQ.I1) THEN
22938 K(I2,4)=(K(I2,4)/MSTU(5))*MSTU(5)+IGL
22939 ELSEIF(MOD(K(I2,5)/MSTU(5),MSTU(5)).EQ.I1) THEN
22940 K(I2,5)=MOD(K(I2,5),MSTU(5))+MSTU(5)*IGL
22941 ELSE
22942 K(I2,5)=(K(I2,5)/MSTU(5))*MSTU(5)+IGL
22943 ENDIF
22944 ENDIF
22945 ENDIF
22946 840 CONTINUE
22947
22948C...Remove collapsed quarks and junctions from ER and update IMI.
22949 CALL PYEDIT(11)
22950
22951C...Also update beam remnant part of IMI.
22952 NMI(1)=MINT(31)
22953 NMI(2)=MINT(31)
22954 DO 850 I=MINT(53)+1,N
22955 IF (K(I,1).LE.0) GOTO 850
22956C...Restore BR quark/diquark/baryon pointers in IMI.
22957 IF ((K(I,2).NE.21.OR.K(I,1).NE.14).AND.K(I,2).NE.88) THEN
22958 JS=K(I,3)-MINT(83)
22959 NMI(JS)=NMI(JS)+1
22960 IMI(JS,NMI(JS),1)=I
22961 IMI(JS,NMI(JS),2)=0
22962 ENDIF
22963 850 CONTINUE
22964
22965C...Restore companion information from collapsed gluons.
22966 DO 870 I=MINT(53)+1,N
22967 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) THEN
22968 JS=K(I,3)-MINT(83)
22969 JCD=MOD(K(I,4),MSTU(5))
22970 JAD=MOD(K(I,5),MSTU(5))
22971 DO 860 IM=1,NMI(JS)
22972 IF (IMI(JS,IM,1).EQ.JCD) IMC=IM
22973 IF (IMI(JS,IM,1).EQ.JAD) IMA=IM
22974 860 CONTINUE
22975 IMI(JS,IMC,2)=IMI(JS,IMA,1)
22976 IMI(JS,IMA,2)=IMI(JS,IMC,1)
22977 ENDIF
22978 870 CONTINUE
22979
22980C...Renumber colour lines (since some have disappeared)
22981 JCT=0
22982 JCD=0
22983 880 JCT=JCT+1
22984 MFOUND=0
22985 I=MINT(84)
22986 890 I=I+1
22987 IF (I.EQ.N+1) THEN
22988 IF (MFOUND.EQ.0) JCD=JCD+1
22989 ELSEIF (MCT(I,1).EQ.JCT.AND.K(I,1).GE.1) THEN
22990 MCT(I,1)=JCT-JCD
22991 MFOUND=1
22992 ELSEIF (MCT(I,2).EQ.JCT.AND.K(I,1).GE.1) THEN
22993 MCT(I,2)=JCT-JCD
22994 MFOUND=1
22995 ENDIF
22996 IF (I.LE.N) GOTO 890
22997 IF (JCT.LT.NCT) GOTO 880
22998 NCT=JCT-JCD
22999
23000C...Reset hard interaction subsystems to their CM frames.
23001 IF (IBOOST.EQ.1) THEN
23002 DO 900 IM=1,MINT(31)
23003 BETA=-(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
23004 CALL PYROBO(IMISEP(IM-1)+1,IMISEP(IM),0D0,0D0,0D0,0D0,BETA)
23005 900 CONTINUE
23006C...Zero beam remnant longitudinal momenta and energies
23007 DO 910 I=MINT(53)+1,N
23008 P(I,3)=0D0
23009 P(I,4)=0D0
23010 910 CONTINUE
23011 ELSE
23012 CALL PYERRM(9
23013 & ,'(PYMIHK:) Inconsistent kinematics. Too many boosts.')
23014C...Kill event and start another.
23015 MINT(51)=1
23016 RETURN
23017 ENDIF
23018
23019 9999 RETURN
23020 END
23021C*********************************************************************
23022
23023C...PYCTTR
23024C...Adapted from PYPREP.
23025C...Assigns LHA1 colour tags to coloured partons based on
23026C...K(I,4) and K(I,5) colour connection record.
23027C...KCS negative signifies that a previous tracing should be continued.
23028C...(in case the tag to be continued is empty, the routine exits)
23029C...Starts at I and ends at I or IEND.
23030C...Special considerations for systems with junctions.
23031C...Special: if IEND=-1, means trace this parton to its color partner,
23032C... then exit. If no partner found, exit with 0.
23033
23034 SUBROUTINE PYCTTR(I,KCS,IEND)
23035C...Double precision and integer declarations.
23036 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23037 INTEGER PYK,PYCHGE,PYCOMP
23038C...Commonblocks.
23039 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23040 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23041 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23042 COMMON/PYINT1/MINT(400),VINT(400)
23043C...The common block of colour tags.
23044 COMMON/PYCTAG/NCT,MCT(4000,2)
23045 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/
23046 DATA NERRPR/0/
23047 SAVE NERRPR
23048
23049C...Skip if parton not existing or does not have KCS
23050 IF (K(I,1).LE.0) GOTO 120
23051 KC=PYCOMP(K(I,2))
23052 IF (KC.EQ.0) GOTO 120
23053 KQ=KCHG(KC,2)
23054 IF (KQ.EQ.0) GOTO 120
23055 IF (IABS(KQ).EQ.1.AND.KQ*(9-2*ABS(KCS)).NE.ISIGN(1,K(I,2)))
23056 & GOTO 120
23057
23058 IF (KCS.GT.0) THEN
23059 NCT=NCT+1
23060C...Set colour tag of first parton.
23061 MCT(I,KCS-3)=NCT
23062 NCS=NCT
23063 ELSE
23064 KCS=-KCS
23065 NCS=MCT(I,KCS-3)
23066 IF (NCS.EQ.0) GOTO 120
23067 ENDIF
23068
23069 IA=I
23070 NSTP=0
23071 100 NSTP=NSTP+1
23072 IF(NSTP.GT.4*N) THEN
23073 CALL PYERRM(14,'(PYCTTR:) caught in infinite loop')
23074 GOTO 120
23075 ENDIF
23076
23077C...Finished if reached final-state triplet.
23078 IF(K(IA,1).EQ.3) THEN
23079 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) GOTO 120
23080 ENDIF
23081
23082C...Also finished if reached junction.
23083 IF(K(IA,1).EQ.42) THEN
23084 GOTO 120
23085 ENDIF
23086
23087C...GOTO next parton in colour space.
23088 110 IB=IA
23089C...If IB's KCS daughter not traced and exists, goto KCS daughter.
23090 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5))
23091 & .NE.0) THEN
23092 IA=MOD(K(IB,KCS),MSTU(5))
23093 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
23094 MREV=0
23095 ELSE
23096C...If KCS mother traced or KCS mother nonexistent, switch colour.
23097 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
23098 & MSTU(5)).EQ.0) THEN
23099 KCS=9-KCS
23100 NCT=NCT+1
23101 NCS=NCT
23102C...Assign new colour tag on other side of old parton.
23103 MCT(IB,KCS-3)=NCT
23104 ENDIF
23105C...Goto (new) KCS mother, set mother traced tag
23106 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
23107 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
23108 MREV=1
23109 ENDIF
23110 IF(IA.LE.0.OR.IA.GT.N) THEN
23111 IF (IEND.EQ.-1) THEN
23112 IEND=0
23113 GOTO 120
23114 ENDIF
23115 CALL PYERRM(12,'(PYCTTR:) colour tag tracing failed')
23116 IF(NERRPR.LT.5) THEN
23117 write(*,*) 'began at ',I
23118 write(*,*) 'ended going from', IB, ' to', IA, ' KCS=',KCS,
23119 & ' NCS=',NCS,' MREV=',MREV
23120 CALL PYLIST(4)
23121 NERRPR=NERRPR+1
23122 ENDIF
23123 MINT(51)=1
23124 RETURN
23125 ENDIF
23126 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5),
23127 & MSTU(5)).EQ.IB) THEN
23128 IF(MREV.EQ.1) KCS=9-KCS
23129 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
23130C...Set KSC mother traced tag for IA
23131 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
23132 ELSE
23133 IF(MREV.EQ.0) KCS=9-KCS
23134 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
23135C...Set KCS daughter traced tag for IA
23136 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
23137 ENDIF
23138C...Assign new colour tag
23139 MCT(IA,KCS-3)=NCS
23140C...Finish if IEND=-1 and found final-state color partner
23141 IF (IEND.EQ.-1.AND.K(IA,1).LT.10) THEN
23142 IEND=IA
23143 GOTO 120
23144 ENDIF
23145 IF (IA.NE.I.AND.IA.NE.IEND) GOTO 100
23146
23147 120 RETURN
23148 END
23149
23150*********************************************************************
23151
23152C...PYMIHG
23153C...Collapse JCP1 and connecting tags to JCG1.
23154C...Collapse JCP2 and connecting tags to JCG2.
23155
23156 SUBROUTINE PYMIHG(JCP1,JCG1,JCP2,JCG2)
23157C...Double precision and integer declarations.
23158 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23159 IMPLICIT INTEGER(I-N)
23160 INTEGER PYK,PYCHGE,PYCOMP
23161C...The event record
23162 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23163C...Parameters
23164 COMMON/PYINT1/MINT(400),VINT(400)
23165 SAVE /PYJETS/,/PYINT1/
23166C...Local variables
23167 COMMON /PYCBLS/MCO(4000,2),NCC,JCCO(4000,2),JCCN(4000,2),MACCPT
23168 COMMON /PYCTAG/NCT,MCT(4000,2)
23169 SAVE /PYCBLS/,/PYCTAG/
23170
23171C...Break up JCP1<->JCP2 tag and create JCP1<->JCG1 and JCP2<->JCG2 tags
23172C...in temporary tag collapse array JCCN. Only break up one connection.
23173 MACCPT=1
23174 MCLPS=0
23175 DO 100 ICC=1,NCC
23176 JCCN(ICC,1)=JCCO(ICC,1)
23177 JCCN(ICC,2)=JCCO(ICC,2)
23178C...If there was a mother, it was previously connected to JCP1.
23179C...Should be changed to JCP2.
23180 IF (MCLPS.EQ.0) THEN
23181 IF (JCCN(ICC,1).EQ.MAX(JCP1,JCP2).AND.JCCN(ICC,2).EQ.MIN(JCP1
23182 & ,JCP2)) THEN
23183 JCCN(ICC,1)=MAX(JCG2,JCP2)
23184 JCCN(ICC,2)=MIN(JCG2,JCP2)
23185 MCLPS=1
23186 ENDIF
23187 ENDIF
23188 100 CONTINUE
23189C...Also collapse colours on JCP1 side of JCG1
23190 IF (JCP1.NE.0) THEN
23191 JCCN(NCC+1,1)=MAX(JCP1,JCG1)
23192 JCCN(NCC+1,2)=MIN(JCP1,JCG1)
23193 ELSE
23194 JCCN(NCC+1,1)=MAX(JCP2,JCG2)
23195 JCCN(NCC+1,2)=MIN(JCP2,JCG2)
23196 ENDIF
23197
23198C...Initialize event record colour tag array MCT array to MCO.
23199 DO 110 I=MINT(84)+1,N
23200 MCT(I,1)=MCO(I,1)
23201 MCT(I,2)=MCO(I,2)
23202 110 CONTINUE
23203
23204C...Collapse tags:
23205C...IS = 1 : All tags connecting to JCG1 on JCG1 side -> JCG1
23206C...IS = 2 : All tags connecting to JCG2 on JCG2 side -> JCG2
23207C...IS = 3 : All tags connecting to JCG1 on JCP1 side -> JCG1
23208C...IS = 4 : All tags connecting to JCG2 on JCP2 side -> JCG2
23209 DO 160 IS=1,4
23210C...Skip if junction.
23211 IF ((IS.EQ.4.AND.JCP2.EQ.0).OR.(IS.EQ.3).AND.JCP1.EQ.0) GOTO 160
23212C...Define starting point in tag space.
23213C...JCA = previous tag
23214C...JCO = present tag
23215C...JCN = new tag
23216 IF (MOD(IS,2).EQ.1) THEN
23217 JCO=JCP1
23218 JCN=JCG1
23219 JCALL=JCG1
23220 ELSEIF (MOD(IS,2).EQ.0) THEN
23221 JCO=JCP2
23222 JCN=JCG2
23223 JCALL=JCG2
23224 ENDIF
23225 ITRACE=0
23226 120 ITRACE=ITRACE+1
23227 IF (ITRACE.GT.1000) THEN
23228C...NB: Proper error message should be defined here.
23229 CALL PYERRM(14
23230 & ,'(PYMIHG:) Inf loop when collapsing colours.')
23231 MINT(57)=MINT(57)+1
23232 MINT(51)=1
23233 RETURN
23234 ENDIF
23235C...Collapse all JCN tags to JCALL
23236 DO 130 I=MINT(84)+1,N
23237 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
23238 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
23239 130 CONTINUE
23240C...IS = 1,2: first step forward. IS = 3,4: first step backward.
23241 IF (IS.GT.2.AND.(JCN.EQ.JCALL)) THEN
23242 JCA=JCN
23243 JCN=JCO
23244 ELSE
23245 JCA=JCO
23246 JCO=JCN
23247 ENDIF
23248C...If possible, step from JCO to new tag JCN not equal to JCA.
23249 DO 140 ICC=1,NCC+1
23250 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN=
23251 & JCCN(ICC,2)
23252 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN=
23253 & JCCN(ICC,1)
23254 140 CONTINUE
23255C...Iterate if new colour was arrived at, but don't go in circles.
23256 IF (JCN.NE.JCO.AND.JCN.NE.JCALL) GOTO 120
23257C...Change all JCN tags in MCO to JCALL in MCT.
23258 DO 150 I=MINT(84)+1,N
23259 IF (MCO(I,1).EQ.JCN) MCT(I,1)=JCALL
23260 IF (MCO(I,2).EQ.JCN) MCT(I,2)=JCALL
23261C...If gluon and colour tag = anticolour tag (and not = 0) try again.
23262 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
23263 & .NE.0) MACCPT=0
23264 150 CONTINUE
23265 160 CONTINUE
23266
23267 DO 200 JCL=NCT,1,-1
23268 JCA=0
23269 JCN=JCL
23270 170 JCO=JCN
23271 DO 180 ICC=1,NCC+1
23272 IF (JCCN(ICC,1).EQ.JCO.AND.JCCN(ICC,2).NE.JCA) JCN
23273 & =JCCN(ICC,2)
23274 IF (JCCN(ICC,2).EQ.JCO.AND.JCCN(ICC,1).NE.JCA) JCN
23275 & =JCCN(ICC,1)
23276 180 CONTINUE
23277C...Overpaint all JCN with JCL
23278 IF (JCN.NE.JCO.AND.JCN.NE.JCL) THEN
23279 DO 190 I=MINT(84)+1,N
23280 IF (MCT(I,1).EQ.JCN) MCT(I,1)=JCL
23281 IF (MCT(I,2).EQ.JCN) MCT(I,2)=JCL
23282C...If gluon and colour tag = anticolour tag (and not = 0) try again.
23283 IF (K(I,2).EQ.21.AND.MCT(I,1).EQ.MCT(I,2).AND.MCT(I,1)
23284 & .NE.0) MACCPT=0
23285 190 CONTINUE
23286 JCA=JCO
23287 GOTO 170
23288 ENDIF
23289 200 CONTINUE
23290
23291 RETURN
23292 END
23293
23294C*********************************************************************
23295
23296C...PYMIRM
23297C...Picks primordial kT and shares longitudinal momentum among
23298C...beam remnants.
23299
23300 SUBROUTINE PYMIRM
23301
23302C...Double precision and integer declarations.
23303 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23304 IMPLICIT INTEGER(I-N)
23305 INTEGER PYK,PYCHGE,PYCOMP
23306C...The event record
23307 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23308C...Parameters
23309 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23310 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23311 COMMON/PYINT1/MINT(400),VINT(400)
23312C...The common block of colour tags.
23313 COMMON/PYCTAG/NCT,MCT(4000,2)
23314C...The common block of dangling ends
23315 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
23316 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
23317 & XMI(2,240),PT2MI(240),IMISEP(0:240)
23318 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/,/PYINTM/,/PYCTAG/
23319C...Local variables
23320 DIMENSION W(0:2,0:2),VB(3),NNXT(2),IVALQ(2),ICOMQ(2)
23321C...W(I,J)| J=0 | 1 | 2 |
23322C... I=0 | Wrem**2 | W+ | W- |
23323C... 1 | W1**2 | W1+ | W1- |
23324C... 2 | W2**2 | W2+ | W2- |
23325C...4-product
23326 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)
23327C...Tentative parametrization of <kT> as a function of Q.
23328 SIGPT(Q)=MAX(PARJ(21),2.1D0*Q/(7D0+Q))
23329C SIGPT(Q)=MAX(0.36D0,4D0*SQRT(Q)/(10D0+SQRT(Q))
23330C SIGPT(Q)=MAX(PARJ(21),3D0*SQRT(Q)/(5D0+SQRT(Q))
23331 GETPT(Q,SIGMA)=MIN(SIGMA*SQRT(-LOG(PYR(0))),PARP(93))
23332C...Lambda kinematic function.
23333 FLAM(A,B,C)=A**2+B**2+C**2-2D0*(A*B+B*C+C*A)
23334
23335C...Beginning and end of beam remnant partons
23336 NOUT=MINT(53)
23337 ISUB=MINT(1)
23338
23339C...Loopback point if kinematic choices gives impossible configuration.
23340 NTRY=0
23341 100 NTRY=NTRY+1
23342
23343C...Assign kT values on each side separately.
23344 DO 180 JS=1,2
23345
23346C...First zero all kT on this side. Skip if no kT to generate.
23347 DO 110 IM=1,NMI(JS)
23348 P(IMI(JS,IM,1),1)=0D0
23349 P(IMI(JS,IM,1),2)=0D0
23350 110 CONTINUE
23351 IF(MSTP(91).LE.0) GOTO 180
23352
23353C...Now assign kT to each (non-collapsed) parton in IMI.
23354 DO 170 IM=1,NMI(JS)
23355 I=IMI(JS,IM,1)
23356C...Select kT according to truncated gaussian or 1/kt6 tails.
23357C...For first interaction, either use rms width = PARP(91) or fitted.
23358 IF (IM.EQ.1) THEN
23359 SIGMA=PARP(91)
23360 IF (MSTP(91).GE.11.AND.MSTP(91).LE.20) THEN
23361 Q=SQRT(PT2MI(IM))
23362 SIGMA=SIGPT(Q)
23363 ENDIF
23364 ELSE
23365C...For subsequent interactions and BR partons use fragmentation width.
23366 SIGMA=PARJ(21)
23367 ENDIF
23368 PHI=PARU(2)*PYR(0)
23369 PT=0D0
23370 IF(NTRY.LE.100) THEN
23371 111 IF (MSTP(91).EQ.1.OR.MSTP(91).EQ.11) THEN
23372 PT=GETPT(Q,SIGMA)
23373 PTX=PT*COS(PHI)
23374 PTY=PT*SIN(PHI)
23375 ELSEIF (MSTP(91).EQ.2) THEN
23376 CALL PYERRM(1,'(PYMIRM:) Sorry, MSTP(91)=2 not '//
23377 & 'available, using MSTP(91)=1.')
23378 CALL PYGIVE('MSTP(91)=1')
23379 GOTO 111
23380 ELSEIF(MSTP(91).EQ.3.OR.MSTP(91).EQ.13) THEN
23381C...Use distribution with kt**6 tails, rms width = PARP(91).
23382 EPS=SQRT(3D0/2D0)*SIGMA
23383C...Generate PTX and PTY separately, each propto 1/KT**6
23384 DO 119 IXY=1,2
23385C...Decide which interval to try
23386 112 P12=1D0/(1D0+27D0/40D0*SIGMA**6/EPS**6)
23387 IF (PYR(0).LT.P12) THEN
23388C...Use flat approx with accept/reject up to EPS.
23389 PT=PYR(0)*EPS
23390 WT=(3D0/2D0*SIGMA**2/(PT**2+3D0/2D0*SIGMA**2))**3
23391 IF (PYR(0).GT.WT) GOTO 112
23392 ELSE
23393C...Above EPS, use 1/kt**6 approx with accept/reject.
23394 PT=EPS/(PYR(0)**(1D0/5D0))
23395 WT=PT**6/(PT**2+3D0/2D0*SIGMA**2)**3
23396 IF (PYR(0).GT.WT) GOTO 112
23397 ENDIF
23398 MSIGN=1
23399 IF (PYR(0).GT.0.5D0) MSIGN=-1
23400 IF (IXY.EQ.1) PTX=MSIGN*PT
23401 IF (IXY.EQ.2) PTY=MSIGN*PT
23402 119 CONTINUE
23403 ELSEIF (MSTP(91).EQ.4.OR.MSTP(91).EQ.14) THEN
23404 PTX=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
23405 PTY=SIGMA*(SQRT(6D0)*PYR(0)-SQRT(3D0/2D0))
23406 ENDIF
23407C...Adjust final PT. Impose upper cutoff, or zero for soft evts.
23408 PT=SQRT(PTX**2+PTY**2)
23409 WT=1D0
23410 IF (PT.GT.PARP(93)) WT=SQRT(PARP(93)/PT)
23411 IF(ISUB.EQ.95.AND.IM.EQ.1) WT=0D0
23412 PTX=PTX*WT
23413 PTY=PTY*WT
23414 PT=SQRT(PTX**2+PTY**2)
23415 ENDIF
23416
23417 P(I,1)=P(I,1)+PTX
23418 P(I,2)=P(I,2)+PTY
23419
23420C...Compensation kicks, with varying degree of local anticorrelations.
23421 MCORR=MSTP(90)
23422 IF (MCORR.EQ.0.OR.ISUB.EQ.95) THEN
23423 PTCX=-PTX/(NMI(JS)-1)
23424 PTCY=-PTY/(NMI(JS)-1)
23425 IF(ISUB.EQ.95) THEN
23426 PTCX=-PTX/(NMI(JS)-2)
23427 PTCY=-PTY/(NMI(JS)-2)
23428 ENDIF
23429 DO 120 IMC=1,NMI(JS)
23430 IF (IMC.EQ.IM) GOTO 120
23431 IF(ISUB.EQ.95.AND.IMC.EQ.1) GOTO 120
23432 P(IMI(JS,IMC,1),1)=P(IMI(JS,IMC,1),1)+PTCX
23433 P(IMI(JS,IMC,1),2)=P(IMI(JS,IMC,1),2)+PTCY
23434 120 CONTINUE
23435 ELSEIF (MCORR.GE.1) THEN
23436 DO 140 MSID=4,5
23437 NNXT(MSID-3)=0
23438C...Count up # of neighbours on either side
23439 IMO=I
23440 130 IMO=K(IMO,MSID)/MSTU(5)
23441 IF (IMO.EQ.0) GOTO 140
23442 NNXT(MSID-3)=NNXT(MSID-3)+1
23443C...Stop at quarks and junctions
23444 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 130
23445 140 CONTINUE
23446C...How should compensation be shared when unequal numbers on the
23447C...two sides? 50/50 regardless? N1:N2? Assume latter for now.
23448 NSUM=NNXT(1)+NNXT(2)
23449 T1=0
23450 DO 160 MSID=4,5
23451C...Total momentum to be compensated on this side
23452 IF (NNXT(MSID-3).EQ.0) GOTO 160
23453 PTCX=-(NNXT(MSID-3)*PTX)/NSUM
23454 PTCY=-(NNXT(MSID-3)*PTY)/NSUM
23455C...RS: compensation supression factor as we go out from parton I.
23456C...Hardcoded behaviour RS=0.5, i.e. 1/2**n falloff,
23457C...since (for now) MSTP(90) provides enough variability.
23458 RS=0.5D0
23459 FAC=(1D0-RS)/(RS*(1-RS**NNXT(MSID-3)))
23460 IMO=I
23461 150 IDA=IMO
23462 IMO=K(IMO,MSID)/MSTU(5)
23463 IF (IMO.EQ.0) GOTO 160
23464 FAC=FAC*RS
23465 IF (K(IMO,2).NE.88) THEN
23466 P(IMO,1)=P(IMO,1)+FAC*PTCX
23467 P(IMO,2)=P(IMO,2)+FAC*PTCY
23468 IF (MCORR.EQ.1.AND.K(IMO,2).EQ.21) GOTO 150
23469C...If we reach junction, divide out the kT that would have been
23470C...assigned to the junction on each of its other legs.
23471 ELSE
23472 L1=MOD(K(IMO,4),MSTU(5))
23473 L2=K(IMO,5)/MSTU(5)
23474 L3=MOD(K(IMO,5),MSTU(5))
23475 P(L1,1)=P(L1,1)+0.5D0*FAC*PTCX
23476 P(L1,2)=P(L1,2)+0.5D0*FAC*PTCY
23477 P(L2,1)=P(L2,1)+0.5D0*FAC*PTCX
23478 P(L2,2)=P(L2,2)+0.5D0*FAC*PTCY
23479 P(L3,1)=P(L3,1)+0.5D0*FAC*PTCX
23480 P(L3,2)=P(L3,2)+0.5D0*FAC*PTCY
23481 P(IDA,1)=P(IDA,1)-0.5D0*FAC*PTCX
23482 P(IDA,2)=P(IDA,2)-0.5D0*FAC*PTCY
23483 ENDIF
23484
23485 160 CONTINUE
23486 ENDIF
23487 170 CONTINUE
23488C...End assignment of kT values to initiators and remnants.
23489 180 CONTINUE
23490
23491C...Check kinematics constraints for non-BR partons.
23492 DO 190 IM=1,MINT(31)
23493 SHAT=XMI(1,IM)*XMI(2,IM)*VINT(2)
23494 PT1=SQRT(P(IMI(1,IM,1),1)**2+P(IMI(1,IM,1),2)**2)
23495 PT2=SQRT(P(IMI(2,IM,1),1)**2+P(IMI(2,IM,1),2)**2)
23496 PT1PT2=P(IMI(1,IM,1),1)*P(IMI(2,IM,1),1)
23497 & +P(IMI(1,IM,1),2)*P(IMI(2,IM,1),2)
23498 IF (SHAT.LT.2D0*(PT1*PT2-PT1PT2).AND.NTRY.LE.100) THEN
23499 IF(NTRY.GE.100) THEN
23500C...Kill this event and start another.
23501 CALL PYERRM(1,
23502 & '(PYMIRM:) No consistent (x,kT) sets found')
23503 MINT(51)=1
23504 RETURN
23505 ENDIF
23506 GOTO 100
23507 ENDIF
23508 190 CONTINUE
23509
23510C...Calculate W+ and W- available for combined remnant system.
23511 W(0,1)=VINT(1)
23512 W(0,2)=VINT(1)
23513 DO 200 IM=1,MINT(31)
23514 PT2 = (P(IMI(1,IM,1),1)+P(IMI(2,IM,1),1))**2
23515 & +(P(IMI(1,IM,1),2)+P(IMI(2,IM,1),2))**2
23516 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+PT2
23517 W(0,1)=W(0,1)-SQRT(XMI(1,IM)/XMI(2,IM)*ST)
23518 W(0,2)=W(0,2)-SQRT(XMI(2,IM)/XMI(1,IM)*ST)
23519 200 CONTINUE
23520C...Also store Wrem**2 = W+ * W-
23521 W(0,0)=W(0,1)*W(0,2)
23522
23523 IF ((W(0,0).LT.0D0.OR.W(0,1)+W(0,2).LT.0D0).AND.NTRY.LE.100) THEN
23524 IF(NTRY.GE.100) THEN
23525C...Kill this event and start another.
23526 CALL PYERRM(1,
23527 & '(PYMIRM:) Negative beam remnant mass squared unavoidable')
23528 MINT(51)=1
23529 RETURN
23530 ENDIF
23531 GOTO 100
23532 ENDIF
23533
23534C...Assign unscaled x values to partons/hadrons in each of the
23535C...beam remnants and calculate unscaled W+ and W- from them.
23536 NTRYX=0
23537 210 NTRYX=NTRYX+1
23538 DO 280 JS=1,2
23539 W(JS,1)=0D0
23540 W(JS,2)=0D0
23541 DO 270 IM=MINT(31)+1,NMI(JS)
23542 I=IMI(JS,IM,1)
23543 KF=K(I,2)
23544 KFA=IABS(KF)
23545 ICOMP=IMI(JS,IM,2)
23546
23547C...Skip collapsed gluons and junctions. Reset.
23548 IF (KFA.EQ.21.AND.K(I,1).EQ.14) GOTO 270
23549 IF (KFA.EQ.88) GOTO 270
23550 X=0D0
23551 IVALQ(1)=0
23552 IVALQ(2)=0
23553 ICOMQ(1)=0
23554 ICOMQ(2)=0
23555
23556C...If gluon then only beam remnant, so takes all.
23557 IF(KFA.EQ.21) THEN
23558 X=1D0
23559C...If valence quark then use parametrized valence distribution.
23560 ELSEIF(KFA.LE.6.AND.ICOMP.EQ.0) THEN
23561 IVALQ(1)=KF
23562C...If companion quark then derive from companion x.
23563 ELSEIF(KFA.LE.6) THEN
23564 ICOMQ(1)=ICOMP
23565C...If valence diquark then use two parametrized valence distributions.
23566 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23567 & ICOMP.EQ.0) THEN
23568 IVALQ(1)=ISIGN(KFA/1000,KF)
23569 IVALQ(2)=ISIGN(MOD(KFA/100,10),KF)
23570C...If valence+sea diquark then combine valence + companion choices.
23571 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0.AND.
23572 & ICOMP.LT.MSTU(5)) THEN
23573 IF(KFA/1000.EQ.IABS(K(ICOMP,2))) THEN
23574 IVALQ(1)=ISIGN(MOD(KFA/100,10),KF)
23575 ELSE
23576 IVALQ(1)=ISIGN(KFA/1000,KF)
23577 ENDIF
23578 ICOMQ(1)=ICOMP
23579C...Extra code: workaround for diquark made out of two sea
23580C...quarks, but where not (yet) ICOMP > MSTU(5).
23581 DO 220 IM1=1,MINT(31)
23582 IF(IMI(JS,IM1,2).EQ.I.AND.IMI(JS,IM1,1).NE.ICOMP) THEN
23583 ICOMQ(2)=IMI(JS,IM1,1)
23584 IVALQ(1)=0
23585 ENDIF
23586 220 CONTINUE
23587C...If sea diquark then sum of two derived from companion x.
23588 ELSEIF(KFA.GT.1000.AND.MOD(KFA/10,10).EQ.0) THEN
23589 ICOMQ(1)=MOD(ICOMP,MSTU(5))
23590 ICOMQ(2)=ICOMP/MSTU(5)
23591C...If meson or baryon then use fragmentation function.
23592C...Somewhat arbitrary split into old and new flavour, but OK normally.
23593 ELSE
23594 KFL3=MOD(KFA/10,10)
23595 IF(MOD(KFA/1000,10).EQ.0) THEN
23596 KFL1=MOD(KFA/100,10)
23597 ELSE
23598 KFL1=MOD(KFA,10000)-10*KFL3-1
23599 IF(MOD(KFA/1000,10).EQ.MOD(KFA/100,10).AND.
23600 & MOD(KFA,10).EQ.2) KFL1=KFL1+2
23601 ENDIF
23602 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
23603 CALL PYZDIS(KFL1,KFL3,PR,X)
23604 ENDIF
23605
23606 DO 260 IQ=1,2
23607C...Calculation of x of valence quark: assume form (1-x)^a/sqrt(x),
23608C...where a=3.5 for u in proton, =2 for d in proton and =0.8 for meson.
23609C...In other baryons combine u and d from proton appropriately.
23610 IF(IVALQ(IQ).NE.0) THEN
23611 NVAL=0
23612 IF(KFIVAL(JS,1).EQ.IVALQ(IQ)) NVAL=NVAL+1
23613 IF(KFIVAL(JS,2).EQ.IVALQ(IQ)) NVAL=NVAL+1
23614 IF(KFIVAL(JS,3).EQ.IVALQ(IQ)) NVAL=NVAL+1
23615C...Meson.
23616 IF(KFIVAL(JS,3).EQ.0) THEN
23617 MDU=0
23618C...Baryon with three identical quarks: mix u and d forms.
23619 ELSEIF(NVAL.EQ.3) THEN
23620 MDU=INT(PYR(0)+5D0/3D0)
23621C...Baryon, one of two identical quarks: u form.
23622 ELSEIF(NVAL.EQ.2) THEN
23623 MDU=2
23624C...Baryon with two identical quarks, but not the one picked: d form.
23625 ELSEIF(KFIVAL(JS,1).EQ.KFIVAL(JS,2).OR.KFIVAL(JS,2).EQ.
23626 & KFIVAL(JS,3).OR.KFIVAL(JS,1).EQ.KFIVAL(JS,3)) THEN
23627 MDU=1
23628C...Baryon with three nonidentical quarks: mix u and d forms.
23629 ELSE
23630 MDU=INT(PYR(0)+5D0/3D0)
23631 ENDIF
23632 XPOW=0.8D0
23633 IF(MDU.EQ.1) XPOW=3.5D0
23634 IF(MDU.EQ.2) XPOW=2D0
23635 230 XX=PYR(0)**2
23636 IF((1D0-XX)**XPOW.LT.PYR(0)) GOTO 230
23637 X=X+XX
23638 ENDIF
23639
23640C...Calculation of x of companion quark.
23641 IF(ICOMQ(IQ).NE.0) THEN
23642 XCOMP=1D-4
23643 DO 240 IM1=1,MINT(31)
23644 IF(IMI(JS,IM1,1).EQ.ICOMQ(IQ)) XCOMP=XMI(JS,IM1)
23645 240 CONTINUE
23646 NPOW=MAX(0,MIN(4,MSTP(87)))
23647 250 XX=XCOMP*(1D0/(1D0-PYR(0)*(1D0-XCOMP))-1D0)
23648 CORR=((1D0-XCOMP-XX)/(1D0-XCOMP))**NPOW*
23649 & (XCOMP**2+XX**2)/(XCOMP+XX)**2
23650 IF(CORR.LT.PYR(0)) GOTO 250
23651 X=X+XX
23652 ENDIF
23653 260 CONTINUE
23654
23655C...Optionally enchance x of composite systems (e.g. diquarks)
23656 IF (KFA.GT.100) X=PARP(79)*X
23657
23658C...Store x. Also calculate light cone energies of each system.
23659 XMI(JS,IM)=X
23660 W(JS,JS)=W(JS,JS)+X
23661 W(JS,3-JS)=W(JS,3-JS)+(P(I,5)**2+P(I,1)**2+P(I,2)**2)/X
23662 270 CONTINUE
23663 W(JS,JS)=W(JS,JS)*W(0,JS)
23664 W(JS,3-JS)=W(JS,3-JS)/W(0,JS)
23665 W(JS,0)=W(JS,1)*W(JS,2)
23666 280 CONTINUE
23667
23668C...Check W1 W2 < Wrem (can be done before rescaling, since W
23669C...insensitive to global rescalings of the BR x values).
23670 IF (SQRT(W(1,0))+SQRT(W(2,0)).GT.SQRT(W(0,0)).AND.NTRYX.LE.100)
23671 & THEN
23672 GOTO 210
23673 ELSEIF (NTRYX.GT.100.AND.NTRY.LE.100) THEN
23674 GOTO 100
23675 ELSEIF (NTRYX.GT.100) THEN
23676 CALL PYERRM(1,'(PYMIRM:) No consistent (x,kT) sets found')
23677 MINT(57)=MINT(57)+1
23678 MINT(51)=1
23679 RETURN
23680 ENDIF
23681
23682C...Compute x rescaling factors
23683 COMTRM=W(0,0)+SQRT(FLAM(W(0,0),W(1,0),W(2,0)))
23684 R1=(COMTRM+W(1,0)-W(2,0))/(2D0*W(1,1)*W(0,2))
23685 R2=(COMTRM+W(2,0)-W(1,0))/(2D0*W(2,2)*W(0,1))
23686
23687 IF (R1.LT.0.OR.R2.LT.0) THEN
23688 CALL PYERRM(19,'(PYMIRM:) negative rescaling factors !')
23689 MINT(57)=MINT(57)+1
23690 MINT(51)=1
23691 ENDIF
23692
23693C...Rescale W(1,*) and W(2,*) (not really necessary, but consistent).
23694 W(1,1)=W(1,1)*R1
23695 W(1,2)=W(1,2)/R1
23696 W(2,1)=W(2,1)/R2
23697 W(2,2)=W(2,2)*R2
23698
23699C...Rescale BR x values.
23700 DO 290 IM=MINT(31)+1,MAX(NMI(1),NMI(2))
23701 XMI(1,IM)=XMI(1,IM)*R1
23702 XMI(2,IM)=XMI(2,IM)*R2
23703 290 CONTINUE
23704
23705C...Now we have a consistent set of x and kT values.
23706C...First set up the initiators and their daughters correctly.
23707 DO 300 IM=1,MINT(31)
23708 I1=IMI(1,IM,1)
23709 I2=IMI(2,IM,1)
23710 ST=XMI(1,IM)*XMI(2,IM)*VINT(2)+(P(I1,1)+P(I2,1))**2+
23711 & (P(I1,2)+P(I2,2))**2
23712 PT12=P(I1,1)**2+P(I1,2)**2
23713 PT22=P(I2,1)**2+P(I2,2)**2
23714C...p_z
23715 P(I1,3)=SQRT(FLAM(ST,PT12,PT22)/(4D0*ST))
23716 P(I2,3)=-P(I1,3)
23717C...Energies (masses should be zero at this stage)
23718 P(I1,4)=SQRT(PT12+P(I1,3)**2)
23719 P(I2,4)=SQRT(PT22+P(I2,3)**2)
23720
23721C...Transverse 12 system initiator velocity:
23722 VB(1)=(P(I1,1)+P(I2,1))/SQRT(ST)
23723 VB(2)=(P(I1,2)+P(I2,2))/SQRT(ST)
23724C...Boost to overall initiator system rest frame
23725 CALL PYROBO(I1,I1,0D0,0D0,-VB(1),-VB(2),0D0)
23726 CALL PYROBO(I2,I2,0D0,0D0,-VB(1),-VB(2),0D0)
23727
23728C...Compute phi,theta coordinates of I1 and rotate z axis.
23729 PHI=PYANGL(P(I1,1),P(I1,2))
23730 THE=PYANGL(P(I1,3),SQRT(P(I1,1)**2+P(I1,2)**2))
23731 IMIN=IMISEP(IM-1)+1
23732C...(include documentation lines if MI = 1)
23733 IF (IM.EQ.1) IMIN=MINT(83)+5
23734 IMAX=IMISEP(IM)
23735C...Rotate entire system in phi
23736 CALL PYROBO(IMIN,IMAX,0D0,-PHI,0D0,0D0,0D0)
23737C...Only rotate 12 system in theta
23738 CALL PYROBO(I1,I1,-THE,0D0,0D0,0D0,0D0)
23739 CALL PYROBO(I2,I2,-THE,0D0,0D0,0D0,0D0)
23740
23741C...Now boost entire system back to LAB
23742 VB(3)=(XMI(1,IM)-XMI(2,IM))/(XMI(1,IM)+XMI(2,IM))
23743 CALL PYROBO(IMIN,IMAX,THE,PHI,VB(1),VB(2),0D0)
23744 CALL PYROBO(IMIN,IMAX,0D0,0D0,0D0,0D0,VB(3))
23745
23746 300 CONTINUE
23747
23748
23749C...For the beam remnant partons/hadrons, we only need to set pz and E.
23750 DO 320 JS=1,2
23751 DO 310 IM=MINT(31)+1,NMI(JS)
23752 I=IMI(JS,IM,1)
23753C...Skip collapsed gluons and junctions.
23754 IF (K(I,2).EQ.21.AND.K(I,1).EQ.14) GOTO 310
23755 IF (KFA.EQ.88) GOTO 310
23756 RMT2=P(I,5)**2+P(I,1)**2+P(I,2)**2
23757 P(I,4)=0.5D0*(XMI(JS,IM)*W(0,JS)+RMT2/(XMI(JS,IM)*W(0,JS)))
23758 P(I,3)=0.5D0*(XMI(JS,IM)*W(0,JS)-RMT2/(XMI(JS,IM)*W(0,JS)))
23759 IF (JS.EQ.2) P(I,3)=-P(I,3)
23760 310 CONTINUE
23761 320 CONTINUE
23762
23763
23764C...Documentation lines
23765 DO 340 JS=1,2
23766 IN=MINT(83)+JS+2
23767 IO=IMI(JS,1,1)
23768 K(IN,1)=21
23769 K(IN,2)=K(IO,2)
23770 K(IN,3)=MINT(83)+JS
23771 K(IN,4)=0
23772 K(IN,5)=0
23773 DO 330 J=1,5
23774 P(IN,J)=P(IO,J)
23775 V(IN,J)=V(IO,J)
23776 330 CONTINUE
23777 MCT(IN,1)=MCT(IO,1)
23778 MCT(IN,2)=MCT(IO,2)
23779 340 CONTINUE
23780
23781C...Final state colour reconnections.
23782 IF (MSTP(95).NE.1.OR.MINT(31).LE.1) GOTO 380
23783
23784C...Number of colour tags for which a recoupling will be tried.
23785 NTOT=NCT
23786C...Number of recouplings to try
23787 MINT(34)=0
23788 NRECP=0
23789 NITER=0
23790 350 NRECP=MINT(34)
23791 NITER=NITER+1
23792 IITER=0
23793 360 IITER=IITER+1
23794 IF (IITER.LE.PARP(78)*NTOT) THEN
23795C...Select two colour tags at random
23796C...NB: jj strings do not have colour tags assigned to them,
23797C...thus they are as yet not affected by anything done here.
23798 JCT=PYR(0)*NCT+1
23799 KCT=MOD(INT(JCT+PYR(0)*NCT),NCT)+1
23800 IJ1=0
23801 IJ2=0
23802 IK1=0
23803 IK2=0
23804C...Find final state partons with this (anti)colour
23805 DO 370 I=MINT(84)+1,N
23806 IF (K(I,1).EQ.3) THEN
23807 IF (MCT(I,1).EQ.JCT) IJ1=I
23808 IF (MCT(I,2).EQ.JCT) IJ2=I
23809 IF (MCT(I,1).EQ.KCT) IK1=I
23810 IF (MCT(I,2).EQ.KCT) IK2=I
23811 ENDIF
23812 370 CONTINUE
23813C...Only consider recouplings not involving junctions for now.
23814 IF (IJ1.EQ.0.OR.IJ2.EQ.0.OR.IK1.EQ.0.OR.IK2.EQ.0) GOTO 360
23815
23816 RLO=2D0*FOUR(IJ1,IJ2)*2D0*FOUR(IK1,IK2)
23817 RLN=2D0*FOUR(IJ1,IK2)*2D0*FOUR(IK1,IJ2)
23818 IF (RLN.LT.RLO.AND.MCT(IJ2,1).NE.KCT.AND.MCT(IK2,1).NE.JCT) THEN
23819 MCT(IJ2,2)=KCT
23820 MCT(IK2,2)=JCT
23821C...Count up number of reconnections
23822 MINT(34)=MINT(34)+1
23823 ENDIF
23824 IF (MINT(34).LE.1000) THEN
23825 GOTO 360
23826 ELSE
23827 CALL PYERRM(4,'(PYMIRM:) caught in infinite loop')
23828 GOTO 380
23829 ENDIF
23830 ENDIF
23831 IF (NRECP.LT.MINT(34)) GOTO 350
23832
23833C...Signal PYPREP to use /PYCTAG/ information rather than K(I,KCS).
23834 380 MINT(33)=1
23835
23836 RETURN
23837 END
23838
23839C*********************************************************************
23840
23841C...PYFSCR
23842C...Performs colour annealing.
23843C...MSTP(95) : CR Type
23844C... = 1 : old cut-and-paste reconnections, handled in PYMIHK
23845C... = 2 : Type I(no gg loops); hadron-hadron only
23846C... = 3 : Type I(no gg loops); all beams
23847C... = 4 : Type II(gg loops) ; hadron-hadron only
23848C... = 5 : Type II(gg loops) ; all beams
23849C... = 6 : Type S ; hadron-hadron only
23850C... = 7 : Type S ; all beams
23851C... = 8 : Type P ; hadron-hadron only
23852C... = 9 : Type P ; all beams
23853C...Types I and II are described in Sandhoff+Skands, in hep-ph/0604120.
23854C...Type S is driven by starting only from free triplets, not octets.
23855C...Type P is also driven by free triplets, but the reconnect probability
23856C...is computed from the string density per unit rapidity, where the axis
23857C...with respect to which the rapidity is computed is the Thrust axis of the
23858C...event.
23859C...A string piece remains unchanged with probability
23860C... PKEEP = (1-PARP(78))**N
23861C...This scaling corresponds to each string piece having to go through
23862C...N other ones, each with probability PARP(78) for reconnection.
23863C...For types I, II, and S, N is chosen simply as the number of multiple
23864C...interactions, for a rough scaling with the general level of activity.
23865C...For type P, N is chosen to be the number of string pieces in a given
23866C...interval of rapidity (minus one, since the string doesn't reconnect
23867C...with itself), and the reconnect probability is interpreted as the
23868C...probability per unit rapidity.
23869C...It also also possible to apply a dampening factor to the CR strength,
23870C...using PARP(77), which will cause reconnections among high-pT string
23871C...pieces to be suppressed.
23872
23873 SUBROUTINE PYFSCR(IP)
23874C...Double precision and integer declarations.
23875 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
23876 INTEGER PYK,PYCHGE,PYCOMP
23877C...Commonblocks.
23878 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
23879 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
23880 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
23881 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
23882 COMMON/PYINT1/MINT(400),VINT(400)
23883C...The common block of colour tags.
23884 COMMON/PYCTAG/NCT,MCT(4000,2)
23885 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/,/PYCTAG/,
23886 &/PYPARS/
23887C...MCN: Temporary storage of new colour tags
23888 INTEGER MCN(4000,2)
23889C...Arrays for storing color strings
23890 PARAMETER (NBINY=100)
23891 INTEGER ICR(4000),MSCR(4000)
23892 INTEGER IOPT(4000), NSTRY(NBINY)
23893 DOUBLE PRECISION RLOPTC(4000)
23894
23895C...Function to give four-product.
23896 FOUR(I,J)=P(I,4)*P(J,4)
23897 & -P(I,1)*P(J,1)-P(I,2)*P(J,2)-P(I,3)*P(J,3)
23898
23899C...Check valid range of MSTP(95), local copy
23900 IF (MSTP(95).LE.1.OR.MSTP(95).GE.10) RETURN
23901 MSTP95=MOD(MSTP(95),10)
23902C...Set whether CR allowed inside resonance systems or not
23903C...(not implemented yet)
23904C MRESCR=1
23905C IF (MSTP(95).GE.10) MRESCR=0
23906
23907C...Check whether colour tags already defined
23908 IF (MINT(33).EQ.0) THEN
23909C...Erase any existing colour tags for this event
23910 DO 100 I=1,N
23911 MCT(I,1)=0
23912 MCT(I,2)=0
23913 100 CONTINUE
23914C...Create colour tags for this event
23915 DO 120 I=1,N
23916 IF (K(I,1).EQ.3) THEN
23917 DO 110 KCS=4,5
23918 KCSIN=KCS
23919 IF (MCT(I,KCSIN-3).EQ.0) THEN
23920 CALL PYCTTR(I,KCSIN,I)
23921 ENDIF
23922 110 CONTINUE
23923 ENDIF
23924 120 CONTINUE
23925C...Instruct PYPREP to use colour tags
23926 MINT(33)=1
23927 ENDIF
23928
23929C...For MSTP(95) even, only apply to hadron-hadron
23930 KA1=IABS(MINT(11))
23931 KA2=IABS(MINT(12))
23932 IF (MOD(MSTP(95),2).EQ.0.AND.(KA1.LT.100.OR.KA2.LT.100)) GOTO 9999
23933
23934C...Initialize new tag array (but do not delete old yet)
23935 LCT=NCT
23936 DO 130 I=MAX(1,IP),N
23937 MCN(I,1)=0
23938 MCN(I,2)=0
23939 130 CONTINUE
23940
23941C...For Paquis type, determine thrust axis (default along Z axis)
23942 TX=0D0
23943 TY=0D0
23944 TZ=1D0
23945 IF (MSTP95.GE.8) THEN
23946 CALL PYTHRU(THRDUM,OBLDUM)
23947 TX = P(N+1,1)
23948 TY = P(N+1,2)
23949 TZ = P(N+1,3)
23950 ENDIF
23951
23952C...For each final-state dipole, check whether string should be
23953C...preserved.
23954 NCR=0
23955 IA=0
23956 IC=0
23957 RAPMAX=0.0
23958
23959 ICTMIN=NCT
23960 DO 150 ICT=1,NCT
23961 IA=0
23962 IC=0
23963 DO 140 I=MAX(1,IP),N
23964 IF (K(I,1).EQ.3.AND.MCT(I,1).EQ.ICT) IC=I
23965 IF (K(I,1).EQ.3.AND.MCT(I,2).EQ.ICT) IA=I
23966 140 CONTINUE
23967 IF (IC.NE.0.AND.IA.NE.0) THEN
23968C...Save smallest NCT value so far
23969 ICTMIN = MIN(ICTMIN,ICT)
23970C...For Paquis algorithm, just store all string pieces for now
23971 IF (MSTP95.GE.8) THEN
23972C... Add coloured parton
23973 NCR=NCR+1
23974 ICR(NCR)=IC
23975 MSCR(NCR)=1
23976 IOPT(NCR)=0
23977C... Store rapidity (along Thrust axis) in RLOPT for the time being
23978C... Add pion mass headroom to energy for this calculation
23979 EET = P(IC,4)*SQRT(1D0+(0.135D0/P(IC,4))**2)
23980 PZT = P(IC,1)*TX+P(IC,2)*TY+P(IC,3)*TZ
23981 RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT))
23982C... Add anti-coloured parton
23983 NCR = NCR+1
23984 ICR(NCR) = IA
23985 MSCR(NCR) = 2
23986 IOPT(NCR) = 0
23987C... Store rapidity (along Thrust axis) in RLOPT for the time being
23988 EET = P(IA,4)*SQRT(1D0+(0.135D0/P(IA,4))**2)
23989 PZT = P(IA,1)*TX+P(IA,2)*TY+P(IA,3)*TZ
23990 RLOPTC(NCR)=LOG((EET+PZT)/(EET-PZT))
23991C... Keep track of largest endpoint "rapidity"
23992 RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR)))
23993 RAPMAX = MAX(RAPMAX,ABS(RLOPTC(NCR-1)))
23994 ELSE
23995 CRMODF=1D0
23996C... Opt: suppress breakup of high-boost string pieces (i.e., let them escape)
23997C... (so far ignores the possibility that the whole "muck" may be moving.)
23998 IF (PARP(77).GT.0D0) THEN
23999 PT2STR=(P(IA,1)+P(IC,1))**2+(P(IA,2)+P(IC,2))**2
24000C... For lepton-lepton, use actual p2/m2, otherwise approximate p2 ~ 3/2 pT2
24001 IF (KA1.LT.100.AND.KA2.LT.100) THEN
24002 P2STR = PT2STR + (P(IA,3)+P(IC,3))**2
24003 ELSE
24004 P2STR = 3D0/2D0 * PT2STR
24005 ENDIF
24006 RM2STR=(P(IA,4)+P(IC,4))**2-(P(IA,3)+P(IC,3))**2-PT2STR
24007 RM2STR=MAX(RM2STR,PMAS(PYCOMP(111),1)**2)
24008C... Estimate number of particles ~ log(M2), cut off at 1.
24009 RLOGM2=MAX(1D0,LOG(RM2STR))
24010 P2AVG=P2STR/RLOGM2
24011C... Supress reconnection probability by 1/(1+P77*P2AVG)
24012 CRMODF=1D0/(1D0+PARP(77)**2*P2AVG)
24013 ENDIF
24014 PKEEP=(1D0-PARP(78)*CRMODF)**MINT(31)
24015 IF (PYR(0).LE.PKEEP) THEN
24016 LCT=LCT+1
24017 MCN(IC,1)=LCT
24018 MCN(IA,2)=LCT
24019 ELSE
24020C... Add coloured parton
24021 NCR=NCR+1
24022 ICR(NCR)=IC
24023 MSCR(NCR)=1
24024 IOPT(NCR)=0
24025 RLOPTC(NCR)=1D19
24026C... Add anti-coloured parton
24027 NCR=NCR+1
24028 ICR(NCR)=IA
24029 MSCR(NCR)=2
24030 IOPT(NCR)=0
24031 RLOPTC(NCR)=1D19
24032 ENDIF
24033 ENDIF
24034 ENDIF
24035 150 CONTINUE
24036
24037C...PAQUIS TYPE
24038 IF (MSTP95.GE.8) THEN
24039C... For Paquis type, make "histogram" of string densities along thrust axis
24040 RAPMIN = -RAPMAX
24041 DRAP = 2*RAPMAX/(1D0*NBINY)
24042C... Explicitly zero histogram bin content
24043 DO 147 IBINY=1,NBINY
24044 NSTRY(IBINY)=0
24045 147 CONTINUE
24046 DO 152 ISTR=1,NCR-1,2
24047 IC = ICR(ISTR)
24048 IA = ICR(ISTR+1)
24049 Y1 = MIN(RLOPTC(ISTR),RLOPTC(ISTR+1))
24050 Y2 = MAX(RLOPTC(ISTR),RLOPTC(ISTR+1))
24051 DO 153 IBINY=1,NBINY
24052 YBINLO = RAPMIN + (IBINY-1)*DRAP
24053C... If bin inside string piece, add 1 in this bin
24054C... (Strictly speaking: if it starts before midpoint and ends after midpoint)
24055 IF (Y1.LE.YBINLO+0.5*DRAP.AND.Y2.GE.YBINLO+0.5*DRAP)
24056 & NSTRY(IBINY) = NSTRY(IBINY) + 1
24057 153 CONTINUE
24058 152 CONTINUE
24059C... Loop over pieces to find individual reconnect probability
24060 DO 167 IS=1,NCR-1,2
24061 DNSUM = 0D0
24062 DNAVG = 0D0
24063C...Beginning at Y = RAPMIN = -RAPMAX, ending at Y = RAPMAX
24064 RBINLO = (MIN(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5
24065 RBINHI = (MAX(RLOPTC(IS),RLOPTC(IS+1))-RAPMIN)/DRAP + 0.5
24066C...Make sure integer bin numbers lie inside proper range
24067 IBINLO = MAX(1,MIN(NBINY,NINT(RBINLO)))
24068 IBINHI = MAX(1,MIN(NBINY,NINT(RBINHI)))
24069C...Size of rapidity bins (is < DRAP if piece smaller than one bin)
24070C...(also smaller than DRAP if a one-unit wide piece is stretched
24071C... over 2 bins, thus making the computation more accurate)
24072 DRAPAV = (RBINHI-RBINLO)/(IBINHI-IBINLO+1)*DRAP
24073C... Decide whether to suppress reconnections in high-pT string pieces
24074 CRMODF = 1D0
24075 IF (PARP(77).GT.0D0) THEN
24076C... Total string piece energy, momentum squared, and components
24077 EES = P(ICR(IS),4) + P(ICR(IS+1),4)
24078 PPS2 = (P(ICR(IS),1)+ P(ICR(IS+1),1))**2
24079 & + (P(ICR(IS),2)+ P(ICR(IS+1),2))**2
24080 & + (P(ICR(IS),3)+ P(ICR(IS+1),3))**2
24081 PZTS = P(ICR(IS),1)*TX+P(ICR(IS),2)*TY+P(ICR(IS),3)*TZ
24082 & + P(ICR(IS+1),1)*TX+P(ICR(IS+1),2)*TY+P(ICR(IS+1),3)*TZ
24083 PTTS = SQRT(PPS2 - PZTS**2)
24084C... Mass of string piece in units of mpi (at least 1)
24085 RMPI2 = 0.135D0
24086 RM2STR = MAX(RMPI2,EES**2 - PPS2)
24087C... Estimate number of pions ~ log(M2) (at least 1)
24088 RNPI = LOG(RM2STR/RMPI2)+1D0
24089 PT2AVG = (PTTS / RNPI)**2
24090C... Supress reconnection probability by 1/(1+P77*P2AVG)
24091 CRMODF=1D0/(1D0+PARP(77)**2*PT2AVG)
24092 ENDIF
24093 PKEEP = 1.0
24094 DO 178 IBINY=IBINLO,IBINHI
24095C DNSUM = DNSUM + 1D0
24096 DNOVL = MAX(0,NSTRY(IBINY)-1)
24097 PKEEP = PKEEP * (1D0-CRMODF*PARP(78))**(DRAPAV*DNOVL)
24098C DNAVG = DNAVG + MAX(1,NSTRY(IBINY))
24099 178 CONTINUE
24100C DNAVG = DNAVG / DNSUM
24101C... If keeping string piece, save
24102 IF (PYR(0).LE.PKEEP) THEN
24103 LCT = LCT+1
24104 MCN(ICR(IS),1)=LCT
24105 MCN(ICR(IS+1),2)=LCT
24106 ENDIF
24107 167 CONTINUE
24108 ENDIF
24109
24110C...Skip if there is only one possibility
24111 IF (NCR.LE.2) THEN
24112 GOTO 9999
24113 ENDIF
24114
24115C...Reorder, so ordered in I (in order to correspond to old algorithm)
24116 NLOOP=0
24117 151 NLOOP=NLOOP+1
24118 MORD=1
24119 DO 155 IC1=1,NCR-1
24120 I1=ICR(IC1)
24121 I2=ICR(IC1+1)
24122 IF (I1.GT.I2) THEN
24123 IT=I1
24124 MST=MSCR(IC1)
24125 ICR(IC1)=I2
24126 MSCR(IC1)=MSCR(IC1+1)
24127 ICR(IC1+1)=IT
24128 MSCR(IC1+1)=MST
24129 MORD=0
24130 ENDIF
24131 155 CONTINUE
24132C...Max do 1000 reordering loops
24133 IF (MORD.EQ.0.AND.NLOOP.LE.1000) GOTO 151
24134
24135C...PS: 03 May 2010
24136C...For Seattle and Paquis types, check if there is a dangling tag
24137C...Needed for special case when entire reconnected state was one or
24138C...more gluon loops in original topology in which case these CR
24139C...algorithms need to be told they shouldn't look for a dangling tag.
24140 M3FREE=0
24141 IF (MSTP95.GE.6.AND.MSTP95.LE.9) THEN
24142 DO 157 IC1=1,NCR
24143 I1=ICR(IC1)
24144C...Color charge
24145 MCI=KCHG(PYCOMP(K(I1,2)),2)*ISIGN(1,K(I1,2))
24146 IF (MCI.EQ.1.AND.MCN(I1,1).EQ.0) M3FREE=1
24147 IF (MCI.EQ.-1.AND.MCN(I1,2).EQ.0) M3FREE=1
24148 IF (MCI.EQ.2) THEN
24149 IF (MCN(I1,1).NE.0.AND.MCN(I1,2).EQ.0) M3FREE=1
24150 IF (MCN(I1,2).NE.0.AND.MCN(I1,1).EQ.0) M3FREE=1
24151 ENDIF
24152 157 CONTINUE
24153 ENDIF
24154
24155C...Loop over CR partons
24156C...(Ignore junctions for now.)
24157 NLOOP=0
24158 160 NLOOP=NLOOP+1
24159 RLMAX=0D0
24160 ICRMAX=0
24161C...Loop over coloured partons
24162 DO 230 IC1=1,NCR
24163C...Retrieve parton Event Record index and Colour Side
24164 I=ICR(IC1)
24165 MSI=MSCR(IC1)
24166C...Skip already connected partons
24167 IF (MCN(I,MSI).NE.0) GOTO 230
24168C...Shorthand for colour charge
24169 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
24170C...For Seattle algorithm, only start from partons with one dangling
24171C...colour tag (unless there aren't any, cf. M3FREE above.)
24172 IF (MSTP(95).GE.6.AND.MSTP(95).LE.9) THEN
24173 IF (MCI.EQ.2.AND.MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0
24174 & .AND.M3FREE.EQ.1) THEN
24175 GOTO 230
24176 ENDIF
24177 ENDIF
24178C...Retrieve saved optimal partner
24179 IO=IOPT(IC1)
24180 IF (IO.NE.0) THEN
24181C...Reject saved optimal partner if latter is now connected
24182C...(Also reject if using model S1, since saved partner may
24183C...now give rise to gg loop.)
24184 IF (MCN(IO,3-MSI).NE.0.OR.MSTP(95).LE.3) THEN
24185 IOPT(IC1)=0
24186 RLOPTC(IC1)=1D19
24187 ENDIF
24188 ENDIF
24189 RLOPT=RLOPTC(IC1)
24190C...Search for new optimal partner if necessary
24191 IF (IOPT(IC1).EQ.0) THEN
24192 MBROPT=0
24193 MGGOPT=0
24194 RLOPT=1D19
24195C...Loop over partons you can connect to
24196 DO 210 IC2=1,NCR
24197 J=ICR(IC2)
24198 MSJ=MSCR(IC2)
24199C...Skip if already connected
24200 IF (MCN(J,MSJ).NE.0) GOTO 210
24201C...Skip if this not colour-anticolour pair
24202 IF (MSI.EQ.MSJ) GOTO 210
24203C...And do not let gluons connect to themselves
24204 IF (I.EQ.J) GOTO 210
24205C...Suppress direct connections between partons in same Beam Remnant
24206 MBRSTR=0
24207 IF (K(I,3).LE.2.AND.K(I,3).GE.1.AND.K(I,3).EQ.K(J,3))
24208 & MBRSTR=1
24209C...Shorthand for colour charge
24210 MCJ=KCHG(PYCOMP(K(J,2)),2)*ISIGN(1,K(J,2))
24211C...Check for gluon loops
24212 MGGSTR=0
24213 IF (MCJ.EQ.2.AND.MCI.EQ.2) THEN
24214 IF (MCN(I,2).EQ.MCN(J,1).AND.MSTP(95).LE.3.AND.
24215 & MCN(I,2).NE.0) MGGSTR=1
24216 ENDIF
24217C...Save connection with smallest lambda measure
24218 RL=FOUR(I,J)
24219C...If best so far was a BR string and this is not, also save.
24220C...If best so far was a gg string and this is not, also save.
24221C...NB: this is not fool-proof. If the algorithm finds a BR or gg
24222C...string with a small Lambda measure as the last step, this connection
24223C...will be saved regardless of whether other possibilities existed.
24224C...I.e., there should really be a check whether another possibility has
24225C...already been found, but since these models are now actively in use
24226C...and uncertainties are anyway large, the algorithm is left as it is.
24227C...(correction --> Pythia 8 ?)
24228 IF (RL.LT.RLOPT.OR.(RL.EQ.RLOPT.AND.PYR(0).LE.0.5D0)
24229 & .OR.(MBROPT.EQ.1.AND.MBRSTR.EQ.0)
24230 & .OR.(MGGOPT.EQ.1.AND.MGGSTR.EQ.0)) THEN
24231C...Paquis type: fix problem above
24232 MPAQ = 0
24233 IF (MSTP95.GE.8.AND.RLOPT.LE.1D18) THEN
24234 IF (MBRSTR.EQ.1.AND.MBROPT.EQ.0) MPAQ=1
24235 IF (MGGSTR.EQ.1.AND.MGGOPT.EQ.0) MPAQ=1
24236 ENDIF
24237 IF (MPAQ.EQ.0) THEN
24238 RLOPT=RL
24239 RLOPTC(IC1)=RLOPT
24240 IOPT(IC1)=J
24241 MBROPT=MBRSTR
24242 MGGOPT=MGGSTR
24243 ENDIF
24244 ENDIF
24245 210 CONTINUE
24246 ENDIF
24247 IF (IOPT(IC1).NE.0) THEN
24248C...Save pair with largest RLOPT so far
24249 IF (RLOPT.GE.RLMAX) THEN
24250 ICRMAX=IC1
24251 RLMAX=RLOPT
24252 ENDIF
24253 ENDIF
24254 230 CONTINUE
24255C...Save and iterate
24256 ICMAX=0
24257 IF (ICRMAX.GT.0) THEN
24258 LCT=LCT+1
24259 ILMAX=ICR(ICRMAX)
24260 JLMAX=IOPT(ICRMAX)
24261 ICMAX=MSCR(ICRMAX)
24262 JCMAX=3-ICMAX
24263 MCN(ILMAX,ICMAX)=LCT
24264 MCN(JLMAX,JCMAX)=LCT
24265 IF (NLOOP.LE.2*(N-IP)) THEN
24266 GOTO 160
24267 ELSE
24268 CALL PYERRM(31,' PYFSCR: infinite loop in color annealing')
24269 CALL PYSTOP(11)
24270 ENDIF
24271 ELSE
24272C...Save and exit. First check for leftover gluon(s)
24273 DO 260 I=MAX(1,IP),N
24274C...Check colour charge
24275 MCI=KCHG(PYCOMP(K(I,2)),2)*ISIGN(1,K(I,2))
24276 IF (K(I,1).NE.3.OR.MCI.NE.2) GOTO 260
24277 IF(MCN(I,1).EQ.0.AND.MCN(I,2).EQ.0) THEN
24278C...Decide where to put left-over gluon (minimal insertion)
24279 ICMAX=0
24280 RLMAX=1D19
24281C...PS: Bug fix 30 Apr 2010: try all lines, not just reconnected ones
24282 DO 250 KCT=ICTMIN,LCT
24283 IC=0
24284 IA=0
24285 DO 240 IT=MAX(1,IP),N
24286 IF (IT.EQ.I.OR.K(IT,1).NE.3) GOTO 240
24287 IF (MCN(IT,1).EQ.KCT) IC=IT
24288 IF (MCN(IT,2).EQ.KCT) IA=IT
24289 240 CONTINUE
24290C...Skip if this color tag no longer present in event record
24291 IF (IC.EQ.0.OR.IA.EQ.0) GOTO 250
24292 RL=FOUR(IC,I)*FOUR(IA,I)
24293 IF (RL.LT.RLMAX) THEN
24294 RLMAX=RL
24295 ICMAX=IC
24296 IAMAX=IA
24297 ENDIF
24298 250 CONTINUE
24299 LCT=LCT+1
24300 MCN(I,1)=MCN(ICMAX,1)
24301 MCN(I,2)=LCT
24302 MCN(ICMAX,1)=LCT
24303 ENDIF
24304 260 CONTINUE
24305C...Here we need to loop over entire event.
24306 DO 270 IZ=MAX(1,IP),N
24307C...Do not erase parton shower colour history
24308 IF (K(IZ,1).NE.3) GOTO 270
24309C...Check colour charge
24310 MCI=KCHG(PYCOMP(K(IZ,2)),2)*ISIGN(1,K(IZ,2))
24311 IF (MCI.EQ.0) GOTO 270
24312 IF (MCN(IZ,1).NE.0) MCT(IZ,1)=MCN(IZ,1)
24313 IF (MCN(IZ,2).NE.0) MCT(IZ,2)=MCN(IZ,2)
24314 270 CONTINUE
24315 ENDIF
24316
24317 9999 RETURN
24318 END
24319
24320C*********************************************************************
24321
24322C...PYDIFF
24323C...Handles diffractive and elastic scattering.
24324
24325 SUBROUTINE PYDIFF
24326
24327C...Double precision and integer declarations.
24328 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24329 IMPLICIT INTEGER(I-N)
24330 INTEGER PYK,PYCHGE,PYCOMP
24331C...Commonblocks.
24332 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24333 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24334 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24335 COMMON/PYINT1/MINT(400),VINT(400)
24336 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
24337
24338C...Reset K, P and V vectors. Store incoming particles.
24339 DO 110 JT=1,MSTP(126)+10
24340 I=MINT(83)+JT
24341 DO 100 J=1,5
24342 K(I,J)=0
24343 P(I,J)=0D0
24344 V(I,J)=0D0
24345 100 CONTINUE
24346 110 CONTINUE
24347 N=MINT(84)
24348 MINT(3)=0
24349 MINT(21)=0
24350 MINT(22)=0
24351 MINT(23)=0
24352 MINT(24)=0
24353 MINT(4)=4
24354 DO 130 JT=1,2
24355 I=MINT(83)+JT
24356 K(I,1)=21
24357 K(I,2)=MINT(10+JT)
24358 DO 120 J=1,5
24359 P(I,J)=VINT(285+5*JT+J)
24360 120 CONTINUE
24361 130 CONTINUE
24362 MINT(6)=2
24363
24364C...Subprocess; kinematics.
24365 SQLAM=(VINT(2)-VINT(63)-VINT(64))**2-4D0*VINT(63)*VINT(64)
24366 PZ=SQRT(SQLAM)/(2D0*VINT(1))
24367 DO 200 JT=1,2
24368 I=MINT(83)+JT
24369 PE=(VINT(2)+VINT(62+JT)-VINT(65-JT))/(2D0*VINT(1))
24370 KFH=MINT(102+JT)
24371
24372C...Elastically scattered particle. (Except elastic GVMD states.)
24373 IF(MINT(16+JT).LE.0.AND.(MINT(10+JT).NE.22.OR.
24374 & MINT(106+JT).NE.3)) THEN
24375 N=N+1
24376 K(N,1)=1
24377 K(N,2)=KFH
24378 K(N,3)=I+2
24379 P(N,3)=PZ*(-1)**(JT+1)
24380 P(N,4)=PE
24381 P(N,5)=SQRT(VINT(62+JT))
24382
24383C...Decay rho from elastic scattering of gamma with sin**2(theta)
24384C...distribution of decay products (in rho rest frame).
24385 IF(KFH.EQ.113.AND.MINT(10+JT).EQ.22.AND.MSTP(102).EQ.1) THEN
24386 NSAV=N
24387 DBETAZ=P(N,3)/SQRT(P(N,3)**2+P(N,5)**2)
24388 P(N,3)=0D0
24389 P(N,4)=P(N,5)
24390 CALL PYDECY(NSAV)
24391 IF(N.EQ.NSAV+2.AND.IABS(K(NSAV+1,2)).EQ.211) THEN
24392 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
24393 CALL PYROBO(NSAV+1,NSAV+2,0D0,-PHI,0D0,0D0,0D0)
24394 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
24395 CALL PYROBO(NSAV+1,NSAV+2,-THE,0D0,0D0,0D0,0D0)
24396 140 CTHE=2D0*PYR(0)-1D0
24397 IF(1D0-CTHE**2.LT.PYR(0)) GOTO 140
24398 CALL PYROBO(NSAV+1,NSAV+2,ACOS(CTHE),PHI,0D0,0D0,0D0)
24399 ENDIF
24400 CALL PYROBO(NSAV,NSAV+2,0D0,0D0,0D0,0D0,DBETAZ)
24401 ENDIF
24402
24403C...Diffracted particle: low-mass system to two particles.
24404 ELSEIF(VINT(62+JT).LT.(VINT(66+JT)+PARP(103))**2) THEN
24405 N=N+2
24406 K(N-1,1)=1
24407 K(N,1)=1
24408 K(N-1,3)=I+2
24409 K(N,3)=I+2
24410 PMMAS=SQRT(VINT(62+JT))
24411 NTRY=0
24412 150 NTRY=NTRY+1
24413 IF(NTRY.LT.20) THEN
24414 MINT(105)=MINT(102+JT)
24415 MINT(109)=MINT(106+JT)
24416 CALL PYSPLI(KFH,21,KFL1,KFL2)
24417 CALL PYKFDI(KFL1,0,KFL3,KF1)
24418 IF(KF1.EQ.0) GOTO 150
24419 CALL PYKFDI(KFL2,-KFL3,KFLDUM,KF2)
24420 IF(KF2.EQ.0) GOTO 150
24421 ELSE
24422 KF1=KFH
24423 KF2=111
24424 ENDIF
24425 PM1=PYMASS(KF1)
24426 PM2=PYMASS(KF2)
24427 IF(PM1+PM2+PARJ(64).GT.PMMAS) GOTO 150
24428 K(N-1,2)=KF1
24429 K(N,2)=KF2
24430 P(N-1,5)=PM1
24431 P(N,5)=PM2
24432 PZP=SQRT(MAX(0D0,(PMMAS**2-PM1**2-PM2**2)**2-
24433 & 4D0*PM1**2*PM2**2))/(2D0*PMMAS)
24434 P(N-1,3)=PZP
24435 P(N,3)=-PZP
24436 P(N-1,4)=SQRT(PM1**2+PZP**2)
24437 P(N,4)=SQRT(PM2**2+PZP**2)
24438 CALL PYROBO(N-1,N,ACOS(2D0*PYR(0)-1D0),PARU(2)*PYR(0),
24439 & 0D0,0D0,0D0)
24440 DBETAZ=PZ*(-1)**(JT+1)/SQRT(PZ**2+PMMAS**2)
24441 CALL PYROBO(N-1,N,0D0,0D0,0D0,0D0,DBETAZ)
24442
24443C...Diffracted particle: valence quark kicked out.
24444 ELSEIF(MSTP(101).EQ.1.OR.(MSTP(101).EQ.3.AND.PYR(0).LT.
24445 & PARP(101))) THEN
24446 N=N+2
24447 K(N-1,1)=2
24448 K(N,1)=1
24449 K(N-1,3)=I+2
24450 K(N,3)=I+2
24451 MINT(105)=MINT(102+JT)
24452 MINT(109)=MINT(106+JT)
24453 CALL PYSPLI(KFH,21,K(N,2),K(N-1,2))
24454 P(N-1,5)=PYMASS(K(N-1,2))
24455 P(N,5)=PYMASS(K(N,2))
24456 SQLAM=(VINT(62+JT)-P(N-1,5)**2-P(N,5)**2)**2-
24457 & 4D0*P(N-1,5)**2*P(N,5)**2
24458 P(N-1,3)=(PE*SQRT(SQLAM)+PZ*(VINT(62+JT)+P(N-1,5)**2-
24459 & P(N,5)**2))/(2D0*VINT(62+JT))*(-1)**(JT+1)
24460 P(N-1,4)=SQRT(P(N-1,3)**2+P(N-1,5)**2)
24461 P(N,3)=PZ*(-1)**(JT+1)-P(N-1,3)
24462 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
24463
24464C...Diffracted particle: gluon kicked out.
24465 ELSE
24466 N=N+3
24467 K(N-2,1)=2
24468 K(N-1,1)=2
24469 K(N,1)=1
24470 K(N-2,3)=I+2
24471 K(N-1,3)=I+2
24472 K(N,3)=I+2
24473 MINT(105)=MINT(102+JT)
24474 MINT(109)=MINT(106+JT)
24475 CALL PYSPLI(KFH,21,K(N,2),K(N-2,2))
24476 K(N-1,2)=21
24477 P(N-2,5)=PYMASS(K(N-2,2))
24478 P(N-1,5)=0D0
24479 P(N,5)=PYMASS(K(N,2))
24480C...Energy distribution for particle into two jets.
24481 160 IMB=1
24482 IF(MOD(KFH/1000,10).NE.0) IMB=2
24483 CHIK=PARP(92+2*IMB)
24484 IF(MSTP(92).LE.1) THEN
24485 IF(IMB.EQ.1) CHI=PYR(0)
24486 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
24487 ELSEIF(MSTP(92).EQ.2) THEN
24488 CHI=1D0-PYR(0)**(1D0/(1D0+CHIK))
24489 ELSEIF(MSTP(92).EQ.3) THEN
24490 CUT=2D0*0.3D0/VINT(1)
24491 170 CHI=PYR(0)**2
24492 IF((CHI**2/(CHI**2+CUT**2))**0.25D0*(1D0-CHI)**CHIK.LT.
24493 & PYR(0)) GOTO 170
24494 ELSEIF(MSTP(92).EQ.4) THEN
24495 CUT=2D0*0.3D0/VINT(1)
24496 CUTR=(1D0+SQRT(1D0+CUT**2))/CUT
24497 180 CHIR=CUT*CUTR**PYR(0)
24498 CHI=(CHIR**2-CUT**2)/(2D0*CHIR)
24499 IF((1D0-CHI)**CHIK.LT.PYR(0)) GOTO 180
24500 ELSE
24501 CUT=2D0*0.3D0/VINT(1)
24502 CUTA=CUT**(1D0-PARP(98))
24503 CUTB=(1D0+CUT)**(1D0-PARP(98))
24504 190 CHI=(CUTA+PYR(0)*(CUTB-CUTA))**(1D0/(1D0-PARP(98)))
24505 IF(((CHI+CUT)**2/(2D0*(CHI**2+CUT**2)))**
24506 & (0.5D0*PARP(98))*(1D0-CHI)**CHIK.LT.PYR(0)) GOTO 190
24507 ENDIF
24508 IF(CHI.LT.P(N,5)**2/VINT(62+JT).OR.CHI.GT.1D0-P(N-2,5)**2/
24509 & VINT(62+JT)) GOTO 160
24510 SQM=P(N-2,5)**2/(1D0-CHI)+P(N,5)**2/CHI
24511 PZI=(PE*(VINT(62+JT)-SQM)+PZ*(VINT(62+JT)+SQM))/
24512 & (2D0*VINT(62+JT))
24513 PEI=SQRT(PZI**2+SQM)
24514 PQQP=(1D0-CHI)*(PEI+PZI)
24515 P(N-2,3)=0.5D0*(PQQP-P(N-2,5)**2/PQQP)*(-1)**(JT+1)
24516 P(N-2,4)=SQRT(P(N-2,3)**2+P(N-2,5)**2)
24517 P(N-1,4)=0.5D0*(VINT(62+JT)-SQM)/(PEI+PZI)
24518 P(N-1,3)=P(N-1,4)*(-1)**JT
24519 P(N,3)=PZI*(-1)**(JT+1)-P(N-2,3)
24520 P(N,4)=SQRT(P(N,3)**2+P(N,5)**2)
24521 ENDIF
24522
24523C...Documentation lines.
24524 K(I+2,1)=21
24525 IF(MINT(16+JT).EQ.0) K(I+2,2)=KFH
24526 IF(MINT(16+JT).NE.0.OR.(MINT(10+JT).EQ.22.AND.
24527 & MINT(106+JT).EQ.3)) K(I+2,2)=ISIGN(9900000,KFH)+10*(KFH/10)
24528 K(I+2,3)=I
24529 P(I+2,3)=PZ*(-1)**(JT+1)
24530 P(I+2,4)=PE
24531 P(I+2,5)=SQRT(VINT(62+JT))
24532 200 CONTINUE
24533
24534C...Rotate outgoing partons/particles using cos(theta).
24535 IF(VINT(23).LT.0.9D0) THEN
24536 CALL PYROBO(MINT(83)+3,N,ACOS(VINT(23)),VINT(24),0D0,0D0,0D0)
24537 ELSE
24538 CALL PYROBO(MINT(83)+3,N,ASIN(VINT(59)),VINT(24),0D0,0D0,0D0)
24539 ENDIF
24540
24541 RETURN
24542 END
24543
24544C*********************************************************************
24545
24546C...PYDISG
24547C...Set up a DIS process as gamma* + f -> f, with beam remnant
24548C...and showering added consecutively. Photon flux by the PYGAGA
24549C...routine (if at all).
24550
24551 SUBROUTINE PYDISG
24552
24553C...Double precision and integer declarations.
24554 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24555 IMPLICIT INTEGER(I-N)
24556 INTEGER PYK,PYCHGE,PYCOMP
24557C...Parameter statement to help give large particle numbers.
24558 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
24559 &KEXCIT=4000000,KDIMEN=5000000)
24560C...Commonblocks.
24561 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24562 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24563 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
24564 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24565 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24566 COMMON/PYINT1/MINT(400),VINT(400)
24567 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/
24568C...Local arrays.
24569 DIMENSION PMS(4)
24570
24571C...Choice of subprocess, number of documentation lines
24572 IDOC=7
24573 MINT(3)=IDOC-6
24574 MINT(4)=IDOC
24575 IPU1=MINT(84)+1
24576 IPU2=MINT(84)+2
24577 IPU3=MINT(84)+3
24578 ISIDE=1
24579 IF(MINT(107).EQ.4) ISIDE=2
24580
24581C...Reset K, P and V vectors. Store incoming particles
24582 DO 110 JT=1,MSTP(126)+20
24583 I=MINT(83)+JT
24584 DO 100 J=1,5
24585 K(I,J)=0
24586 P(I,J)=0D0
24587 V(I,J)=0D0
24588 100 CONTINUE
24589 110 CONTINUE
24590 DO 130 JT=1,2
24591 I=MINT(83)+JT
24592 K(I,1)=21
24593 K(I,2)=MINT(10+JT)
24594 DO 120 J=1,5
24595 P(I,J)=VINT(285+5*JT+J)
24596 120 CONTINUE
24597 130 CONTINUE
24598 MINT(6)=2
24599
24600C...Store incoming partons in hadronic CM-frame
24601 DO 140 JT=1,2
24602 I=MINT(84)+JT
24603 K(I,1)=14
24604 K(I,2)=MINT(14+JT)
24605 K(I,3)=MINT(83)+2+JT
24606 140 CONTINUE
24607 IF(MINT(15).EQ.22) THEN
24608 P(MINT(84)+1,3)=0.5D0*(VINT(1)+VINT(307)/VINT(1))
24609 P(MINT(84)+1,4)=0.5D0*(VINT(1)-VINT(307)/VINT(1))
24610 P(MINT(84)+1,5)=-SQRT(VINT(307))
24611 P(MINT(84)+2,3)=-0.5D0*VINT(307)/VINT(1)
24612 P(MINT(84)+2,4)=0.5D0*VINT(307)/VINT(1)
24613 KFRES=MINT(16)
24614 ISIDE=2
24615 ELSE
24616 P(MINT(84)+1,3)=0.5D0*VINT(308)/VINT(1)
24617 P(MINT(84)+1,4)=0.5D0*VINT(308)/VINT(1)
24618 P(MINT(84)+2,3)=-0.5D0*(VINT(1)+VINT(308)/VINT(1))
24619 P(MINT(84)+2,4)=0.5D0*(VINT(1)-VINT(308)/VINT(1))
24620 P(MINT(84)+1,5)=-SQRT(VINT(308))
24621 KFRES=MINT(15)
24622 ISIDE=1
24623 ENDIF
24624 SIDESG=(-1D0)**(ISIDE-1)
24625
24626C...Copy incoming partons to documentation lines.
24627 DO 170 JT=1,2
24628 I1=MINT(83)+4+JT
24629 I2=MINT(84)+JT
24630 K(I1,1)=21
24631 K(I1,2)=K(I2,2)
24632 K(I1,3)=I1-2
24633 DO 150 J=1,5
24634 P(I1,J)=P(I2,J)
24635 150 CONTINUE
24636
24637C...Second copy for partons before ISR shower, since no such.
24638 I1=MINT(83)+2+JT
24639 K(I1,1)=21
24640 K(I1,2)=K(I2,2)
24641 K(I1,3)=I1-2
24642 DO 160 J=1,5
24643 P(I1,J)=P(I2,J)
24644 160 CONTINUE
24645 170 CONTINUE
24646
24647C...Define initial partons.
24648 NTRY=0
24649 180 NTRY=NTRY+1
24650 IF(NTRY.GT.100) THEN
24651 MINT(51)=1
24652 RETURN
24653 ENDIF
24654
24655C...Scattered quark in hadronic CM frame.
24656 I=MINT(83)+7
24657 K(IPU3,1)=3
24658 K(IPU3,2)=KFRES
24659 K(IPU3,3)=I
24660 P(IPU3,5)=PYMASS(KFRES)
24661 P(IPU3,3)=P(IPU1,3)+P(IPU2,3)
24662 P(IPU3,4)=P(IPU1,4)+P(IPU2,4)
24663 P(IPU3,5)=0D0
24664 K(I,1)=21
24665 K(I,2)=KFRES
24666 K(I,3)=MINT(83)+4+ISIDE
24667 P(I,3)=P(IPU3,3)
24668 P(I,4)=P(IPU3,4)
24669 P(I,5)=P(IPU3,5)
24670 N=IPU3
24671 MINT(21)=KFRES
24672 MINT(22)=0
24673
24674C...No primordial kT, or chosen according to truncated Gaussian or
24675C...exponential, or (for photon) predetermined or power law.
24676 190 IF(MINT(40+ISIDE).EQ.2.AND.MINT(10+ISIDE).NE.22) THEN
24677 IF(MSTP(91).LE.0) THEN
24678 PT=0D0
24679 ELSEIF(MSTP(91).EQ.1) THEN
24680 PT=PARP(91)*SQRT(-LOG(PYR(0)))
24681 ELSE
24682 RPT1=PYR(0)
24683 RPT2=PYR(0)
24684 PT=-PARP(92)*LOG(RPT1*RPT2)
24685 ENDIF
24686 IF(PT.GT.PARP(93)) GOTO 190
24687 ELSEIF(MINT(106+ISIDE).EQ.3) THEN
24688 PTA=SQRT(VINT(282+ISIDE))
24689 PTB=0D0
24690 IF(MSTP(66).EQ.5.AND.MSTP(93).EQ.1) THEN
24691 PTB=PARP(99)*SQRT(-LOG(PYR(0)))
24692 ELSEIF(MSTP(66).EQ.5.AND.MSTP(93).EQ.2) THEN
24693 RPT1=PYR(0)
24694 RPT2=PYR(0)
24695 PTB=-PARP(99)*LOG(RPT1*RPT2)
24696 ENDIF
24697 IF(PTB.GT.PARP(100)) GOTO 190
24698 PT=SQRT(PTA**2+PTB**2+2D0*PTA*PTB*COS(PARU(2)*PYR(0)))
24699 IF(NTRY.GT.10) PT=PT*0.8D0**(NTRY-10)
24700 ELSEIF(IABS(MINT(14+ISIDE)).LE.8.OR.MINT(14+ISIDE).EQ.21) THEN
24701 IF(MSTP(93).LE.0) THEN
24702 PT=0D0
24703 ELSEIF(MSTP(93).EQ.1) THEN
24704 PT=PARP(99)*SQRT(-LOG(PYR(0)))
24705 ELSEIF(MSTP(93).EQ.2) THEN
24706 RPT1=PYR(0)
24707 RPT2=PYR(0)
24708 PT=-PARP(99)*LOG(RPT1*RPT2)
24709 ELSEIF(MSTP(93).EQ.3) THEN
24710 HA=PARP(99)**2
24711 HB=PARP(100)**2
24712 PT=SQRT(MAX(0D0,HA*(HA+HB)/(HA+HB-PYR(0)*HB)-HA))
24713 ELSE
24714 HA=PARP(99)**2
24715 HB=PARP(100)**2
24716 IF(MSTP(93).EQ.5) HB=MIN(VINT(48),PARP(100)**2)
24717 PT=SQRT(MAX(0D0,HA*((HA+HB)/HA)**PYR(0)-HA))
24718 ENDIF
24719 IF(PT.GT.PARP(100)) GOTO 190
24720 ELSE
24721 PT=0D0
24722 ENDIF
24723 VINT(156+ISIDE)=PT
24724 PHI=PARU(2)*PYR(0)
24725 P(IPU3,1)=PT*COS(PHI)
24726 P(IPU3,2)=PT*SIN(PHI)
24727 P(IPU3,4)=SQRT(P(IPU3,5)**2+PT**2+P(IPU3,3)**2)
24728 PMS(3-ISIDE)=P(IPU3,5)**2+P(IPU3,1)**2+P(IPU3,2)**2
24729 PCP=P(IPU3,4)+ABS(P(IPU3,3))
24730
24731C...Find one or two beam remnants.
24732 MINT(105)=MINT(102+ISIDE)
24733 MINT(109)=MINT(106+ISIDE)
24734 CALL PYSPLI(MINT(10+ISIDE),MINT(12+ISIDE),KFLCH,KFLSP)
24735 IF(MINT(51).NE.0) THEN
24736 MINT(51)=0
24737 GOTO 180
24738 ENDIF
24739
24740C...Store first remnant parton, with colour info and kinematics.
24741 I=N+1
24742 K(I,1)=1
24743 K(I,2)=KFLSP
24744 K(I,3)=MINT(83)+ISIDE
24745 P(I,5)=PYMASS(K(I,2))
24746 KCOL=KCHG(PYCOMP(KFLSP),2)
24747 IF(KCOL.NE.0) THEN
24748 K(I,1)=3
24749 KFLS=(3-KCOL*ISIGN(1,KFLSP))/2
24750 K(I,KFLS+3)=MSTU(5)*IPU3
24751 K(IPU3,6-KFLS)=MSTU(5)*I
24752 ICOLR=I
24753 ENDIF
24754 IF(KFLCH.EQ.0) THEN
24755 P(I,1)=-P(IPU3,1)
24756 P(I,2)=-P(IPU3,2)
24757 PMS(ISIDE)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24758 P(I,3)=-P(IPU3,3)
24759 P(I,4)=SQRT(PMS(ISIDE)+P(I,3)**2)
24760 PRP=P(I,4)+ABS(P(I,3))
24761
24762C...When extra remnant parton or hadron: store extra remnant.
24763 ELSE
24764 I=I+1
24765 K(I,1)=1
24766 K(I,2)=KFLCH
24767 K(I,3)=MINT(83)+ISIDE
24768 P(I,5)=PYMASS(K(I,2))
24769 KCOL=KCHG(PYCOMP(KFLCH),2)
24770 IF(KCOL.NE.0) THEN
24771 K(I,1)=3
24772 KFLS=(3-KCOL*ISIGN(1,KFLCH))/2
24773 K(I,KFLS+3)=MSTU(5)*IPU3
24774 K(IPU3,6-KFLS)=MSTU(5)*I
24775 ICOLR=I
24776 ENDIF
24777
24778C...Relative transverse momentum when two remnants.
24779 LOOP=0
24780 200 LOOP=LOOP+1
24781 CALL PYPTDI(1,P(I-1,1),P(I-1,2))
24782 P(I-1,1)=P(I-1,1)-0.5D0*P(IPU3,1)
24783 P(I-1,2)=P(I-1,2)-0.5D0*P(IPU3,2)
24784 PMS(3)=P(I-1,5)**2+P(I-1,1)**2+P(I-1,2)**2
24785 P(I,1)=-P(IPU3,1)-P(I-1,1)
24786 P(I,2)=-P(IPU3,2)-P(I-1,2)
24787 PMS(4)=P(I,5)**2+P(I,1)**2+P(I,2)**2
24788
24789C...Relative distribution of energy for particle into jet plus particle.
24790 IMB=1
24791 IF(MOD(MINT(10+ISIDE)/1000,10).NE.0) IMB=2
24792 IF(MSTP(94).LE.1) THEN
24793 IF(IMB.EQ.1) CHI=PYR(0)
24794 IF(IMB.EQ.2) CHI=1D0-SQRT(PYR(0))
24795 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24796 ELSEIF(MSTP(94).EQ.2) THEN
24797 CHI=1D0-PYR(0)**(1D0/(1D0+PARP(93+2*IMB)))
24798 IF(MOD(KFLCH/1000,10).NE.0) CHI=1D0-CHI
24799 ELSEIF(MSTP(94).EQ.3) THEN
24800 CALL PYZDIS(1,0,PMS(4),ZZ)
24801 CHI=ZZ
24802 ELSE
24803 CALL PYZDIS(1000,0,PMS(4),ZZ)
24804 CHI=ZZ
24805 ENDIF
24806
24807C...Construct total transverse mass; reject if too large.
24808 CHI=MAX(1D-8,MIN(1D0-1D-8,CHI))
24809 PMS(ISIDE)=PMS(4)/CHI+PMS(3)/(1D0-CHI)
24810 IF(PMS(ISIDE).GT.P(IPU3,4)**2) THEN
24811 IF(LOOP.LT.10) GOTO 200
24812 GOTO 180
24813 ENDIF
24814 VINT(158+ISIDE)=CHI
24815
24816C...Subdivide longitudinal momentum according to value selected above.
24817 PRP=SQRT(PMS(ISIDE)+P(IPU3,3)**2)+ABS(P(IPU3,3))
24818 PW1=(1D0-CHI)*PRP
24819 P(I-1,4)=0.5D0*(PW1+PMS(3)/PW1)
24820 P(I-1,3)=0.5D0*(PW1-PMS(3)/PW1)*SIDESG
24821 PW2=CHI*PRP
24822 P(I,4)=0.5D0*(PW2+PMS(4)/PW2)
24823 P(I,3)=0.5D0*(PW2-PMS(4)/PW2)*SIDESG
24824 ENDIF
24825 N=I
24826
24827C...Boost current and remnant systems to correct frame.
24828 IF(SQRT(PMS(1))+SQRT(PMS(2)).GT.0.99D0*VINT(1)) GOTO 180
24829 DSQLAM=SQRT(MAX(0D0,(VINT(2)-PMS(1)-PMS(2))**2-4D0*PMS(1)*PMS(2)))
24830 DRKC=(VINT(2)+PMS(3-ISIDE)-PMS(ISIDE)+DSQLAM)/
24831 &(2D0*VINT(1)*PCP)
24832 DRKR=(VINT(2)+PMS(ISIDE)-PMS(3-ISIDE)+DSQLAM)/
24833 &(2D0*VINT(1)*PRP)
24834 DBEC=-SIDESG*(DRKC**2-1D0)/(DRKC**2+1D0)
24835 DBER=SIDESG*(DRKR**2-1D0)/(DRKR**2+1D0)
24836 CALL PYROBO(IPU3,IPU3,0D0,0D0,0D0,0D0,DBEC)
24837 CALL PYROBO(IPU3+1,N,0D0,0D0,0D0,0D0,DBER)
24838
24839C...Let current quark shower; recoil but no showering by colour partner.
24840 QMAX=2D0*SQRT(VINT(309-ISIDE))
24841 MSTJ48=MSTJ(48)
24842 MSTJ(48)=1
24843 PARJ86=PARJ(86)
24844 PARJ(86)=0D0
24845 IF(MSTP(71).EQ.1) CALL PYSHOW(IPU3,ICOLR,QMAX)
24846 MSTJ(48)=MSTJ48
24847 PARJ(86)=PARJ86
24848
24849 RETURN
24850 END
24851
24852C*********************************************************************
24853
24854C...PYDOCU
24855C...Handles the documentation of the process in MSTI and PARI,
24856C...and also computes cross-sections based on accumulated statistics.
24857
24858 SUBROUTINE PYDOCU
24859
24860C...Double precision and integer declarations.
24861 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
24862 IMPLICIT INTEGER(I-N)
24863 INTEGER PYK,PYCHGE,PYCOMP
24864C...Commonblocks.
24865 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
24866 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
24867 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
24868 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
24869 COMMON/PYINT1/MINT(400),VINT(400)
24870 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
24871 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
24872 SAVE /PYJETS/,/PYDAT1/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,
24873 &/PYINT5/
24874
24875C...Calculate Monte Carlo estimates of cross-sections.
24876 ISUB=MINT(1)
24877 IF(MSTP(111).NE.-1) NGEN(ISUB,3)=NGEN(ISUB,3)+1
24878 NGEN(0,3)=NGEN(0,3)+1
24879 XSEC(0,3)=0D0
24880 DO 100 I=1,500
24881 IF(I.EQ.96.OR.I.EQ.97) THEN
24882 XSEC(I,3)=0D0
24883 ELSEIF(MSUB(95).EQ.1.AND.(I.EQ.11.OR.I.EQ.12.OR.I.EQ.13.OR.
24884 & I.EQ.28.OR.I.EQ.53.OR.I.EQ.68)) THEN
24885 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24886 & DBLE(NGEN(96,2)))
24887 ELSEIF(MSUB(95).EQ.1.AND.I.GE.381.AND.I.LE.386) THEN
24888 XSEC(I,3)=XSEC(96,2)*NGEN(I,3)/MAX(1D0,DBLE(NGEN(96,1))*
24889 & DBLE(NGEN(96,2)))
24890 ELSEIF(MSUB(I).EQ.0.OR.NGEN(I,1).EQ.0) THEN
24891 XSEC(I,3)=0D0
24892 ELSEIF(NGEN(I,2).EQ.0) THEN
24893 XSEC(I,3)=XSEC(I,2)*NGEN(0,3)/(DBLE(NGEN(I,1))*
24894 & DBLE(NGEN(0,2)))
24895 ELSE
24896 XSEC(I,3)=XSEC(I,2)*NGEN(I,3)/(DBLE(NGEN(I,1))*
24897 & DBLE(NGEN(I,2)))
24898 ENDIF
24899 XSEC(0,3)=XSEC(0,3)+XSEC(I,3)
24900 100 CONTINUE
24901
24902C...Rescale to known low-pT cross-section for standard QCD processes.
24903 IF(MSUB(95).EQ.1) THEN
24904 XSECH=XSEC(11,3)+XSEC(12,3)+XSEC(13,3)+XSEC(28,3)+XSEC(53,3)+
24905 & XSEC(68,3)+XSEC(95,3)
24906 XSECW=XSEC(97,2)/MAX(1D0,DBLE(NGEN(97,1)))
24907 IF(XSECH.GT.1D-20.AND.XSECW.GT.1D-20) THEN
24908 FAC=XSECW/XSECH
24909 XSEC(11,3)=FAC*XSEC(11,3)
24910 XSEC(12,3)=FAC*XSEC(12,3)
24911 XSEC(13,3)=FAC*XSEC(13,3)
24912 XSEC(28,3)=FAC*XSEC(28,3)
24913 XSEC(53,3)=FAC*XSEC(53,3)
24914 XSEC(68,3)=FAC*XSEC(68,3)
24915 XSEC(95,3)=FAC*XSEC(95,3)
24916 XSEC(0,3)=XSEC(0,3)-XSECH+XSECW
24917 ENDIF
24918 ENDIF
24919
24920C...Save information for gamma-p and gamma-gamma.
24921 IF(MINT(121).GT.1) THEN
24922 IGA=MINT(122)
24923 CALL PYSAVE(2,IGA)
24924 CALL PYSAVE(5,0)
24925 ENDIF
24926
24927C...Reset information on hard interaction.
24928 DO 110 J=1,200
24929 MSTI(J)=0
24930 PARI(J)=0D0
24931 110 CONTINUE
24932
24933C...Copy integer valued information from MINT into MSTI.
24934 DO 120 J=1,32
24935 MSTI(J)=MINT(J)
24936 120 CONTINUE
24937 IF(MINT(121).GT.1) MSTI(9)=MINT(122)
24938
24939C...Store cross-section variables in PARI.
24940 PARI(1)=XSEC(0,3)
24941 PARI(2)=XSEC(0,3)/MINT(5)
24942 PARI(7)=VINT(97)
24943 PARI(9)=VINT(99)
24944 PARI(10)=VINT(100)
24945 VINT(98)=VINT(98)+VINT(100)
24946 IF(MSTP(142).EQ.1) PARI(2)=XSEC(0,3)/VINT(98)
24947
24948C...Store kinematics variables in PARI.
24949 PARI(11)=VINT(1)
24950 PARI(12)=VINT(2)
24951 IF(ISUB.NE.95) THEN
24952 DO 130 J=13,26
24953 PARI(J)=VINT(30+J)
24954 130 CONTINUE
24955 PARI(29)=VINT(39)
24956 PARI(30)=VINT(40)
24957 PARI(31)=VINT(141)
24958 PARI(32)=VINT(142)
24959 PARI(33)=VINT(41)
24960 PARI(34)=VINT(42)
24961 PARI(35)=PARI(33)-PARI(34)
24962 PARI(36)=VINT(21)
24963 PARI(37)=VINT(22)
24964 PARI(38)=VINT(26)
24965 PARI(39)=VINT(157)
24966 PARI(40)=VINT(158)
24967 PARI(41)=VINT(23)
24968 PARI(42)=2D0*VINT(47)/VINT(1)
24969 ENDIF
24970
24971C...Store information on scattered partons in PARI.
24972 IF(ISUB.NE.95.AND.MINT(7)*MINT(8).NE.0) THEN
24973 DO 140 IS=7,8
24974 I=MINT(IS)
24975 PARI(36+IS)=P(I,3)/VINT(1)
24976 PARI(38+IS)=P(I,4)/VINT(1)
24977 PR=MAX(1D-20,P(I,5)**2+P(I,1)**2+P(I,2)**2)
24978 PARI(40+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24979 & SQRT(PR),1D20)),P(I,3))
24980 PR=MAX(1D-20,P(I,1)**2+P(I,2)**2)
24981 PARI(42+IS)=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/
24982 & SQRT(PR),1D20)),P(I,3))
24983 PARI(44+IS)=P(I,3)/SQRT(1D-20+P(I,1)**2+P(I,2)**2+P(I,3)**2)
24984 PARI(46+IS)=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
24985 PARI(48+IS)=PYANGL(P(I,1),P(I,2))
24986 140 CONTINUE
24987 ENDIF
24988
24989C...Store sum up transverse and longitudinal momenta.
24990 PARI(65)=2D0*PARI(17)
24991 IF(ISUB.LE.90.OR.ISUB.GE.95) THEN
24992 DO 150 I=MSTP(126)+1,N
24993 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 150
24994 PT=SQRT(P(I,1)**2+P(I,2)**2)
24995 PARI(69)=PARI(69)+PT
24996 IF(I.LE.MINT(52)) PARI(66)=PARI(66)+PT
24997 IF(I.GT.MINT(52).AND.I.LE.MINT(53)) PARI(68)=PARI(68)+PT
24998 150 CONTINUE
24999 PARI(67)=PARI(68)
25000 PARI(71)=VINT(151)
25001 PARI(72)=VINT(152)
25002 PARI(73)=VINT(151)
25003 PARI(74)=VINT(152)
25004 ELSE
25005 PARI(66)=PARI(65)
25006 PARI(69)=PARI(65)
25007 ENDIF
25008
25009C...Store various other pieces of information into PARI.
25010 PARI(61)=VINT(148)
25011 PARI(75)=VINT(155)
25012 PARI(76)=VINT(156)
25013 PARI(77)=VINT(159)
25014 PARI(78)=VINT(160)
25015 PARI(81)=VINT(138)
25016
25017C...Store information on lepton -> lepton + gamma in PYGAGA.
25018 MSTI(71)=MINT(141)
25019 MSTI(72)=MINT(142)
25020 PARI(101)=VINT(301)
25021 PARI(102)=VINT(302)
25022 DO 160 I=103,114
25023 PARI(I)=VINT(I+202)
25024 160 CONTINUE
25025
25026C...Set information for PYTABU.
25027 IF(ISET(ISUB).EQ.1.OR.ISET(ISUB).EQ.3) THEN
25028 MSTU(161)=MINT(21)
25029 MSTU(162)=0
25030 ELSEIF(ISET(ISUB).EQ.5) THEN
25031 MSTU(161)=MINT(23)
25032 MSTU(162)=0
25033 ELSE
25034 MSTU(161)=MINT(21)
25035 MSTU(162)=MINT(22)
25036 ENDIF
25037
25038 RETURN
25039 END
25040
25041C*********************************************************************
25042
25043C...PYFRAM
25044C...Performs transformations between different coordinate frames.
25045
25046 SUBROUTINE PYFRAM(IFRAME)
25047
25048C...Double precision and integer declarations.
25049 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25050 IMPLICIT INTEGER(I-N)
25051 INTEGER PYK,PYCHGE,PYCOMP
25052C...Commonblocks.
25053 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25054 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25055 COMMON/PYINT1/MINT(400),VINT(400)
25056 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
25057
25058C...Check that transformation can and should be done.
25059 IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
25060 &MINT(91).EQ.1)) THEN
25061 IF(IFRAME.EQ.MINT(6)) RETURN
25062 ELSE
25063 WRITE(MSTU(11),5000) IFRAME,MINT(6)
25064 RETURN
25065 ENDIF
25066
25067 IF(MINT(6).EQ.1) THEN
25068C...Transform from fixed target or user specified frame to
25069C...overall CM frame.
25070 CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
25071 CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
25072 CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
25073 ELSEIF(MINT(6).EQ.3) THEN
25074C...Transform from hadronic CM frame in DIS to overall CM frame.
25075 CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
25076 & -VINT(225))
25077 ENDIF
25078
25079 IF(IFRAME.EQ.1) THEN
25080C...Transform from overall CM frame to fixed target or user specified
25081C...frame.
25082 CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
25083 ELSEIF(IFRAME.EQ.3) THEN
25084C...Transform from overall CM frame to hadronic CM frame in DIS.
25085 CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
25086 CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
25087 CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
25088 ENDIF
25089
25090C...Set information about new frame.
25091 MINT(6)=IFRAME
25092 MSTI(6)=IFRAME
25093
25094 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
25095 &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
25096 &1X,I5)
25097
25098 RETURN
25099 END
25100
25101C*********************************************************************
25102
25103C...PYWIDT
25104C...Calculates full and partial widths of resonances.
25105
25106 SUBROUTINE PYWIDT(KFLR,SH,WDTP,WDTE)
25107
25108C...Double precision and integer declarations.
25109 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
25110 IMPLICIT INTEGER(I-N)
25111 INTEGER PYK,PYCHGE,PYCOMP
25112C...Parameter statement to help give large particle numbers.
25113 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
25114 &KEXCIT=4000000,KDIMEN=5000000)
25115C...Commonblocks.
25116 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
25117 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
25118 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
25119 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
25120 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
25121 COMMON/PYINT1/MINT(400),VINT(400)
25122 COMMON/PYINT4/MWID(500),WIDS(500,5)
25123 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
25124 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
25125 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
25126 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
25127 COMMON/PYPUED/IUED(0:99),RUED(0:99)
25128 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
25129 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/
25130C...Local arrays and saved variables.
25131 COMPLEX*16 ZMIXC(4,4),AL,BL,AR,BR,FL,FR
25132 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
25133 &WID2SV(3,2),WDTPP(0:400),WDTEP(0:400,0:5)
25134C...UED: equivalences between ordered particles (451->475)
25135C...and UED particle code (5 000 000 + id)
25136 PARAMETER(KKFLMI=451,KKFLMA=475)
25137 DIMENSION CHIDEL(3), IUEDPR(25)
25138 DIMENSION IUEDEQ(KKFLMA),MUED(2)
25139 COMMON/SW1/SW21,CW21
25140 DATA (IUEDEQ(I),I=KKFLMI,KKFLMA)/
25141 & 6100001,6100002,6100003,6100004,6100005,6100006,
25142 & 5100001,5100002,5100003,5100004,5100005,5100006,
25143 & 6100011,6100013,6100015,
25144 & 5100012,5100011,5100014,5100013,5100016,5100015,
25145 & 5100021,5100022,5100023,5100024/
25146C...Save local variables
25147 SAVE MOFSV,WIDWSV,WID2SV
25148C...Initial values
25149 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
25150 DATA CHIDEL/1.1D-03,1.D0,7.4D+2/
25151 DATA IUEDPR/25*0/
25152C...UED: inline functions used in kk width calculus
25153 FKAC1(X,Y)=1.-X**2/Y**2
25154 FKAC2(X,Y)=2.+X**2/Y**2
25155
25156C...Compressed code and sign; mass.
25157 KFLA=IABS(KFLR)
25158 KFLS=ISIGN(1,KFLR)
25159 KC=PYCOMP(KFLA)
25160 SHR=SQRT(SH)
25161 PMR=PMAS(KC,1)
25162
25163C...Reset width information.
25164 DO 110 I=0,MDCY(KC,3)
25165 WDTP(I)=0D0
25166 DO 100 J=0,5
25167 WDTE(I,J)=0D0
25168 100 CONTINUE
25169 110 CONTINUE
25170
25171C...Allow for fudge factor to rescale resonance width.
25172 FUDGE=1D0
25173 IF(MSTP(110).NE.0.AND.(MWID(KC).EQ.1.OR.MWID(KC).EQ.2.OR.
25174 &(MWID(KC).EQ.3.AND.MINT(63).EQ.1))) THEN
25175 IF(MSTP(110).EQ.KFLA) THEN
25176 FUDGE=PARP(110)
25177 ELSEIF(MSTP(110).EQ.-1) THEN
25178 IF(KFLA.NE.6.AND.KFLA.NE.23.AND.KFLA.NE.24) FUDGE=PARP(110)
25179 ELSEIF(MSTP(110).EQ.-2) THEN
25180 FUDGE=PARP(110)
25181 ENDIF
25182 ENDIF
25183
25184C...Not to be treated as a resonance: return.
25185 IF((MWID(KC).LE.0.OR.MWID(KC).GE.4).AND.KFLA.NE.21.AND.
25186 &KFLA.NE.22) THEN
25187 WDTP(0)=1D0
25188 WDTE(0,0)=1D0
25189 MINT(61)=0
25190 MINT(62)=0
25191 MINT(63)=0
25192 RETURN
25193
25194C...Treatment as a resonance based on tabulated branching ratios.
25195 ELSEIF(MWID(KC).EQ.2.OR.(MWID(KC).EQ.3.AND.MINT(63).EQ.0)) THEN
25196C...Loop over possible decay channels; skip irrelevant ones.
25197 DO 120 I=1,MDCY(KC,3)
25198 IDC=I+MDCY(KC,2)-1
25199 IF(MDME(IDC,1).LT.0) GOTO 120
25200
25201C...Read out decay products and nominal masses.
25202 KFD1=KFDP(IDC,1)
25203 KFC1=PYCOMP(KFD1)
25204C...Skip dummy modes or unrecognized particles
25205 IF (KFD1.EQ.0.OR.KFC1.EQ.0) GOTO 120
25206 IF(KCHG(KFC1,3).EQ.1) KFD1=KFLS*KFD1
25207 PM1=PMAS(KFC1,1)
25208 KFD2=KFDP(IDC,2)
25209 KFC2=PYCOMP(KFD2)
25210 IF(KCHG(KFC2,3).EQ.1) KFD2=KFLS*KFD2
25211 PM2=PMAS(KFC2,1)
25212 KFD3=KFDP(IDC,3)
25213 PM3=0D0
25214 IF(KFD3.NE.0) THEN
25215 KFC3=PYCOMP(KFD3)
25216 IF(KCHG(KFC3,3).EQ.1) KFD3=KFLS*KFD3
25217 PM3=PMAS(KFC3,1)
25218 ENDIF
25219
25220C...Naive partial width and alternative threshold factors.
25221 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)
25222 IF(MDME(IDC,2).GE.51.AND.MDME(IDC,2).LE.53.AND.
25223 & PM1+PM2+PM3.GE.SHR) THEN
25224 WDTP(I)=0D0
25225 ELSEIF(MDME(IDC,2).EQ.52.AND.KFD3.EQ.0) THEN
25226 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,(SH-PM1**2-PM2**2)**2-
25227 & 4D0*PM1**2*PM2**2))/SH
25228 ELSEIF(MDME(IDC,2).EQ.52) THEN
25229 PMA=MAX(PM1,PM2,PM3)
25230 PMC=MIN(PM1,PM2,PM3)
25231 PMB=PM1+PM2+PM3-PMA-PMC
25232 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMC-PMC)
25233 PMAN=PMA**2/SH
25234 PMBN=PMB**2/SH
25235 PMCN=PMC**2/SH
25236 PMBCN=PMBC**2/SH
25237 WDTP(I)=WDTP(I)*SQRT(MAX(0D0,
25238 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
25239 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
25240 & ((SHR-PMA)**2-(PMB+PMC)**2)*
25241 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
25242 & ((1D0-PMBCN)*PMBCN*SH)
25243 ELSEIF(MDME(IDC,2).EQ.53.AND.KFD3.EQ.0) THEN
25244 WDTP(I)=WDTP(I)*SQRT(
25245 & MAX(0D0,(SH-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2)/
25246 & MAX(1D-4,(PMR**2-PM1**2-PM2**2)**2-4D0*PM1**2*PM2**2))
25247 ELSEIF(MDME(IDC,2).EQ.53) THEN
25248 PMA=MAX(PM1,PM2,PM3)
25249 PMC=MIN(PM1,PM2,PM3)
25250 PMB=PM1+PM2+PM3-PMA-PMC
25251 PMBC=PMB+PMC+0.5D0*(SHR-PMA-PMB-PMC)
25252 PMAN=PMA**2/SH
25253 PMBN=PMB**2/SH
25254 PMCN=PMC**2/SH
25255 PMBCN=PMBC**2/SH
25256 FACACT=SQRT(MAX(0D0,
25257 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
25258 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
25259 & ((SHR-PMA)**2-(PMB+PMC)**2)*
25260 & (1D0+0.25D0*(PMA+PMB+PMC)/SHR)/
25261 & ((1D0-PMBCN)*PMBCN*SH)
25262 PMBC=PMB+PMC+0.5D0*(PMR-PMA-PMB-PMC)
25263 PMAN=PMA**2/PMR**2
25264 PMBN=PMB**2/PMR**2
25265 PMCN=PMC**2/PMR**2
25266 PMBCN=PMBC**2/PMR**2
25267 FACNOM=SQRT(MAX(0D0,
25268 & ((1D0-PMAN-PMBCN)**2-4D0*PMAN*PMBCN)*
25269 & ((PMBCN-PMBN-PMCN)**2-4D0*PMBN*PMCN)))*
25270 & ((PMR-PMA)**2-(PMB+PMC)**2)*
25271 & (1D0+0.25D0*(PMA+PMB+PMC)/PMR)/
25272 & ((1D0-PMBCN)*PMBCN*PMR**2)
25273 WDTP(I)=WDTP(I)*FACACT/MAX(1D-6,FACNOM)
25274 ENDIF
25275 WDTP(I)=FUDGE*WDTP(I)
25276 WDTP(0)=WDTP(0)+WDTP(I)
25277
25278C...Calculate secondary width (at most two identical/opposite).
25279 WID2=1D0
25280 IF(MDME(IDC,1).GT.0) THEN
25281 IF(KFD2.EQ.KFD1) THEN
25282 IF(KCHG(KFC1,3).EQ.0) THEN
25283 WID2=WIDS(KFC1,1)
25284 ELSEIF(KFD1.GT.0) THEN
25285 WID2=WIDS(KFC1,4)
25286 ELSE
25287 WID2=WIDS(KFC1,5)
25288 ENDIF
25289 IF(KFD3.GT.0) THEN
25290 WID2=WID2*WIDS(KFC3,2)
25291 ELSEIF(KFD3.LT.0) THEN
25292 WID2=WID2*WIDS(KFC3,3)
25293 ENDIF
25294 ELSEIF(KFD2.EQ.-KFD1) THEN
25295 WID2=WIDS(KFC1,1)
25296 IF(KFD3.GT.0) THEN
25297 WID2=WID2*WIDS(KFC3,2)
25298 ELSEIF(KFD3.LT.0) THEN
25299 WID2=WID2*WIDS(KFC3,3)
25300 ENDIF
25301 ELSEIF(KFD3.EQ.KFD1) THEN
25302 IF(KCHG(KFC1,3).EQ.0) THEN
25303 WID2=WIDS(KFC1,1)
25304 ELSEIF(KFD1.GT.0) THEN
25305 WID2=WIDS(KFC1,4)
25306 ELSE
25307 WID2=WIDS(KFC1,5)
25308 ENDIF
25309 IF(KFD2.GT.0) THEN
25310 WID2=WID2*WIDS(KFC2,2)
25311 ELSEIF(KFD2.LT.0) THEN
25312 WID2=WID2*WIDS(KFC2,3)
25313 ENDIF
25314 ELSEIF(KFD3.EQ.-KFD1) THEN
25315 WID2=WIDS(KFC1,1)
25316 IF(KFD2.GT.0) THEN
25317 WID2=WID2*WIDS(KFC2,2)
25318 ELSEIF(KFD2.LT.0) THEN
25319 WID2=WID2*WIDS(KFC2,3)
25320 ENDIF
25321 ELSEIF(KFD3.EQ.KFD2) THEN
25322 IF(KCHG(KFC2,3).EQ.0) THEN
25323 WID2=WIDS(KFC2,1)
25324 ELSEIF(KFD2.GT.0) THEN
25325 WID2=WIDS(KFC2,4)
25326 ELSE
25327 WID2=WIDS(KFC2,5)
25328 ENDIF
25329 IF(KFD1.GT.0) THEN
25330 WID2=WID2*WIDS(KFC1,2)
25331 ELSEIF(KFD1.LT.0) THEN
25332 WID2=WID2*WIDS(KFC1,3)
25333 ENDIF
25334 ELSEIF(KFD3.EQ.-KFD2) THEN
25335 WID2=WIDS(KFC2,1)
25336 IF(KFD1.GT.0) THEN
25337 WID2=WID2*WIDS(KFC1,2)
25338 ELSEIF(KFD1.LT.0) THEN
25339 WID2=WID2*WIDS(KFC1,3)
25340 ENDIF
25341 ELSE
25342 IF(KFD1.GT.0) THEN
25343 WID2=WIDS(KFC1,2)
25344 ELSE
25345 WID2=WIDS(KFC1,3)
25346 ENDIF
25347 IF(KFD2.GT.0) THEN
25348 WID2=WID2*WIDS(KFC2,2)
25349 ELSE
25350 WID2=WID2*WIDS(KFC2,3)
25351 ENDIF
25352 IF(KFD3.GT.0) THEN
25353 WID2=WID2*WIDS(KFC3,2)
25354 ELSEIF(KFD3.LT.0) THEN
25355 WID2=WID2*WIDS(KFC3,3)
25356 ENDIF
25357 ENDIF
25358
25359C...Store effective widths according to case.
25360 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25361 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25362 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25363 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25364 ENDIF
25365 120 CONTINUE
25366C...Return.
25367 MINT(61)=0
25368 MINT(62)=0
25369 MINT(63)=0
25370 RETURN
25371 ENDIF
25372
25373C...Here begins detailed dynamical calculation of resonance widths.
25374C...Shared treatment of Higgs states.
25375 KFHIGG=25
25376 IHIGG=1
25377 IF(KFLA.EQ.35.OR.KFLA.EQ.36) THEN
25378 KFHIGG=KFLA
25379 IHIGG=KFLA-33
25380 ENDIF
25381
25382C...Common electroweak and strong constants.
25383 XW=PARU(102)
25384 XWV=XW
25385 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
25386 XW1=1D0-XW
25387 AEM=PYALEM(SH)
25388 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
25389 AS=PYALPS(SH)
25390 RADC=1D0+AS/PARU(1)
25391
25392 IF(KFLA.EQ.6) THEN
25393C...t quark.
25394 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25395 RADCT=1D0-2.5D0*AS/PARU(1)
25396 DO 140 I=1,MDCY(KC,3)
25397 IDC=I+MDCY(KC,2)-1
25398 IF(MDME(IDC,1).LT.0) GOTO 140
25399 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25400 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25401 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
25402 WID2=1D0
25403 IF(I.GE.4.AND.I.LE.7) THEN
25404C...t -> W + q; including approximate QCD correction factor.
25405 WDTP(I)=FAC*VCKM(3,I-3)*RADCT*
25406 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25407 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25408 IF(KFLR.GT.0) THEN
25409 WID2=WIDS(24,2)
25410 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
25411 ELSE
25412 WID2=WIDS(24,3)
25413 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
25414 ENDIF
25415 ELSEIF(I.EQ.9) THEN
25416C...t -> H + b.
25417 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
25418 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25419 & ((1D0+RM2-RM1)*(RM2R*PARU(141)**2+1D0/PARU(141)**2)+
25420 & 4D0*SQRT(RM2R*RM2))
25421 WID2=WIDS(37,2)
25422 IF(KFLR.LT.0) WID2=WIDS(37,3)
25423CMRENNA++
25424 ELSEIF(I.GE.10.AND.I.LE.13.AND.IMSS(1).NE.0) THEN
25425C...t -> ~t + ~chi_i0, i = 1, 2, 3 or 4.
25426 BETA=ATAN(RMSS(5))
25427 SINB=SIN(BETA)
25428 TANW=SQRT(PARU(102)/(1D0-PARU(102)))
25429 ET=KCHG(6,1)/3D0
25430 T3L=SIGN(0.5D0,ET)
25431 KFC1=PYCOMP(KFDP(IDC,1))
25432 KFC2=PYCOMP(KFDP(IDC,2))
25433 PMNCHI=PMAS(KFC1,1)
25434 PMSTOP=PMAS(KFC2,1)
25435 IF(SHR.GT.PMNCHI+PMSTOP) THEN
25436 IZ=I-9
25437 DO 130 IK=1,4
25438 ZMIXC(IZ,IK)=DCMPLX(ZMIX(IZ,IK),ZMIXI(IZ,IK))
25439 130 CONTINUE
25440 AL=SHR*DCONJG(ZMIXC(IZ,4))/(2.0D0*PMAS(24,1)*SINB)
25441 AR=-ET*ZMIXC(IZ,1)*TANW
25442 BL=T3L*(ZMIXC(IZ,2)-ZMIXC(IZ,1)*TANW)-AR
25443 BR=AL
25444 FL=SFMIX(6,1)*AL+SFMIX(6,2)*AR
25445 FR=SFMIX(6,1)*BL+SFMIX(6,2)*BR
25446 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
25447 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
25448 WDTP(I)=(0.5D0*PYALEM(SH)/PARU(102))*PCM*
25449 & ((ABS(FL)**2+ABS(FR)**2)*(SH+PMNCHI**2-PMSTOP**2)+
25450 & SMZ(IZ)*4D0*SHR*DBLE(FL*DCONJG(FR)))/SH
25451 IF(KFLR.GT.0) THEN
25452 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
25453 ELSE
25454 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
25455 ENDIF
25456 ENDIF
25457 ELSEIF(I.EQ.14.AND.IMSS(1).NE.0) THEN
25458C...t -> ~g + ~t
25459 KFC1=PYCOMP(KFDP(IDC,1))
25460 KFC2=PYCOMP(KFDP(IDC,2))
25461 PMNCHI=PMAS(KFC1,1)
25462 PMSTOP=PMAS(KFC2,1)
25463 IF(SHR.GT.PMNCHI+PMSTOP) THEN
25464 RL=SFMIX(6,1)
25465 RR=-SFMIX(6,2)
25466 PCM=SQRT((SH-(PMNCHI+PMSTOP)**2)*
25467 & (SH-(PMNCHI-PMSTOP)**2))/(2D0*SHR)
25468 WDTP(I)=4D0/3D0*0.5D0*PYALPS(SH)*PCM*((RL**2+RR**2)*
25469 & (SH+PMNCHI**2-PMSTOP**2)+PMNCHI*4D0*SHR*RL*RR)/SH
25470 IF(KFLR.GT.0) THEN
25471 WID2=WIDS(KFC1,2)*WIDS(KFC2,2)
25472 ELSE
25473 WID2=WIDS(KFC1,2)*WIDS(KFC2,3)
25474 ENDIF
25475 ENDIF
25476 ELSEIF(I.EQ.15.AND.IMSS(1).NE.0) THEN
25477C...t -> ~gravitino + ~t
25478 XMP2=RMSS(29)**2
25479 KFC1=PYCOMP(KFDP(IDC,1))
25480 XMGR2=PMAS(KFC1,1)**2
25481 WDTP(I)=SH**2*SHR/(96D0*PARU(1)*XMP2*XMGR2)*(1D0-RM2)**4
25482 KFC2=PYCOMP(KFDP(IDC,2))
25483 WID2=WIDS(KFC2,2)
25484 IF(KFLR.LT.0) WID2=WIDS(KFC2,3)
25485CMRENNA--
25486 ENDIF
25487 WDTP(I)=FUDGE*WDTP(I)
25488 WDTP(0)=WDTP(0)+WDTP(I)
25489 IF(MDME(IDC,1).GT.0) THEN
25490 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25491 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25492 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25493 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25494 ENDIF
25495 140 CONTINUE
25496
25497 ELSEIF(KFLA.EQ.7) THEN
25498C...b' quark.
25499 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25500 DO 150 I=1,MDCY(KC,3)
25501 IDC=I+MDCY(KC,2)-1
25502 IF(MDME(IDC,1).LT.0) GOTO 150
25503 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25504 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25505 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 150
25506 WID2=1D0
25507 IF(I.GE.4.AND.I.LE.7) THEN
25508C...b' -> W + q.
25509 WDTP(I)=FAC*VCKM(I-3,4)*
25510 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25511 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25512 IF(KFLR.GT.0) THEN
25513 WID2=WIDS(24,3)
25514 IF(I.EQ.6) WID2=WID2*WIDS(6,2)
25515 IF(I.EQ.7) WID2=WID2*WIDS(8,2)
25516 ELSE
25517 WID2=WIDS(24,2)
25518 IF(I.EQ.6) WID2=WID2*WIDS(6,3)
25519 IF(I.EQ.7) WID2=WID2*WIDS(8,3)
25520 ENDIF
25521 WID2=WIDS(24,3)
25522 IF(KFLR.LT.0) WID2=WIDS(24,2)
25523 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
25524C...b' -> H + q.
25525 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25526 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
25527 IF(KFLR.GT.0) THEN
25528 WID2=WIDS(37,3)
25529 IF(I.EQ.10) WID2=WID2*WIDS(6,2)
25530 ELSE
25531 WID2=WIDS(37,2)
25532 IF(I.EQ.10) WID2=WID2*WIDS(6,3)
25533 ENDIF
25534 ENDIF
25535 WDTP(I)=FUDGE*WDTP(I)
25536 WDTP(0)=WDTP(0)+WDTP(I)
25537 IF(MDME(IDC,1).GT.0) THEN
25538 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25539 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25540 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25541 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25542 ENDIF
25543 150 CONTINUE
25544
25545 ELSEIF(KFLA.EQ.8) THEN
25546C...t' quark.
25547 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25548 DO 160 I=1,MDCY(KC,3)
25549 IDC=I+MDCY(KC,2)-1
25550 IF(MDME(IDC,1).LT.0) GOTO 160
25551 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25552 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25553 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 160
25554 WID2=1D0
25555 IF(I.GE.4.AND.I.LE.7) THEN
25556C...t' -> W + q.
25557 WDTP(I)=FAC*VCKM(4,I-3)*
25558 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25559 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25560 IF(KFLR.GT.0) THEN
25561 WID2=WIDS(24,2)
25562 IF(I.EQ.7) WID2=WID2*WIDS(7,2)
25563 ELSE
25564 WID2=WIDS(24,3)
25565 IF(I.EQ.7) WID2=WID2*WIDS(7,3)
25566 ENDIF
25567 ELSEIF(I.EQ.9.OR.I.EQ.10) THEN
25568C...t' -> H + q.
25569 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25570 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
25571 IF(KFLR.GT.0) THEN
25572 WID2=WIDS(37,2)
25573 IF(I.EQ.10) WID2=WID2*WIDS(7,2)
25574 ELSE
25575 WID2=WIDS(37,3)
25576 IF(I.EQ.10) WID2=WID2*WIDS(7,3)
25577 ENDIF
25578 ENDIF
25579 WDTP(I)=FUDGE*WDTP(I)
25580 WDTP(0)=WDTP(0)+WDTP(I)
25581 IF(MDME(IDC,1).GT.0) THEN
25582 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25583 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25584 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25585 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25586 ENDIF
25587 160 CONTINUE
25588
25589 ELSEIF(KFLA.EQ.17) THEN
25590C...tau' lepton.
25591 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25592 DO 170 I=1,MDCY(KC,3)
25593 IDC=I+MDCY(KC,2)-1
25594 IF(MDME(IDC,1).LT.0) GOTO 170
25595 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25596 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25597 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 170
25598 WID2=1D0
25599 IF(I.EQ.3) THEN
25600C...tau' -> W + nu'_tau.
25601 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25602 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25603 IF(KFLR.GT.0) THEN
25604 WID2=WIDS(24,3)
25605 WID2=WID2*WIDS(18,2)
25606 ELSE
25607 WID2=WIDS(24,2)
25608 WID2=WID2*WIDS(18,3)
25609 ENDIF
25610 ELSEIF(I.EQ.5) THEN
25611C...tau' -> H + nu'_tau.
25612 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25613 & ((1D0+RM2-RM1)*(PARU(141)**2+RM2/PARU(141)**2)+4D0*RM2)
25614 IF(KFLR.GT.0) THEN
25615 WID2=WIDS(37,3)
25616 WID2=WID2*WIDS(18,2)
25617 ELSE
25618 WID2=WIDS(37,2)
25619 WID2=WID2*WIDS(18,3)
25620 ENDIF
25621 ENDIF
25622 WDTP(I)=FUDGE*WDTP(I)
25623 WDTP(0)=WDTP(0)+WDTP(I)
25624 IF(MDME(IDC,1).GT.0) THEN
25625 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25626 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25627 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25628 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25629 ENDIF
25630 170 CONTINUE
25631
25632 ELSEIF(KFLA.EQ.18) THEN
25633C...nu'_tau neutrino.
25634 FAC=(AEM/(16D0*XW))*(SH/PMAS(24,1)**2)*SHR
25635 DO 180 I=1,MDCY(KC,3)
25636 IDC=I+MDCY(KC,2)-1
25637 IF(MDME(IDC,1).LT.0) GOTO 180
25638 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
25639 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
25640 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 180
25641 WID2=1D0
25642 IF(I.EQ.2) THEN
25643C...nu'_tau -> W + tau'.
25644 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25645 & ((1D0-RM2)**2+(1D0+RM2)*RM1-2D0*RM1**2)
25646 IF(KFLR.GT.0) THEN
25647 WID2=WIDS(24,2)
25648 WID2=WID2*WIDS(17,2)
25649 ELSE
25650 WID2=WIDS(24,3)
25651 WID2=WID2*WIDS(17,3)
25652 ENDIF
25653 ELSEIF(I.EQ.3) THEN
25654C...nu'_tau -> H + tau'.
25655 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
25656 & ((1D0+RM2-RM1)*(RM2*PARU(141)**2+1D0/PARU(141)**2)+4D0*RM2)
25657 IF(KFLR.GT.0) THEN
25658 WID2=WIDS(37,2)
25659 WID2=WID2*WIDS(17,2)
25660 ELSE
25661 WID2=WIDS(37,3)
25662 WID2=WID2*WIDS(17,3)
25663 ENDIF
25664 ENDIF
25665 WDTP(I)=FUDGE*WDTP(I)
25666 WDTP(0)=WDTP(0)+WDTP(I)
25667 IF(MDME(IDC,1).GT.0) THEN
25668 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25669 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25670 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25671 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25672 ENDIF
25673 180 CONTINUE
25674
25675 ELSEIF(KFLA.EQ.21) THEN
25676C...QCD:
25677C***Note that widths are not given in dimensional quantities here.
25678 DO 190 I=1,MDCY(KC,3)
25679 IDC=I+MDCY(KC,2)-1
25680 IF(MDME(IDC,1).LT.0) GOTO 190
25681 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25682 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25683 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 190
25684 WID2=1D0
25685 IF(I.LE.8) THEN
25686C...QCD -> q + qbar
25687 WDTP(I)=(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25688 IF(I.EQ.6) WID2=WIDS(6,1)
25689 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25690 ENDIF
25691 WDTP(I)=FUDGE*WDTP(I)
25692 WDTP(0)=WDTP(0)+WDTP(I)
25693 IF(MDME(IDC,1).GT.0) THEN
25694 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25695 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25696 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25697 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25698 ENDIF
25699 190 CONTINUE
25700
25701 ELSEIF(KFLA.EQ.22) THEN
25702C...QED photon.
25703C***Note that widths are not given in dimensional quantities here.
25704 DO 200 I=1,MDCY(KC,3)
25705 IDC=I+MDCY(KC,2)-1
25706 IF(MDME(IDC,1).LT.0) GOTO 200
25707 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25708 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25709 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 200
25710 WID2=1D0
25711 IF(I.LE.8) THEN
25712C...QED -> q + qbar.
25713 EF=KCHG(I,1)/3D0
25714 FCOF=3D0*RADC
25715 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25716 WDTP(I)=FCOF*EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25717 IF(I.EQ.6) WID2=WIDS(6,1)
25718 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25719 ELSEIF(I.LE.12) THEN
25720C...QED -> l+ + l-.
25721 EF=KCHG(9+2*(I-8),1)/3D0
25722 WDTP(I)=EF**2*(1D0+2D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
25723 IF(I.EQ.12) WID2=WIDS(17,1)
25724 ENDIF
25725 WDTP(I)=FUDGE*WDTP(I)
25726 WDTP(0)=WDTP(0)+WDTP(I)
25727 IF(MDME(IDC,1).GT.0) THEN
25728 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25729 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25730 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25731 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25732 ENDIF
25733 200 CONTINUE
25734
25735 ELSEIF(KFLA.EQ.23) THEN
25736C...Z0:
25737 ICASE=1
25738 XWC=1D0/(16D0*XW*XW1)
25739 FAC=(AEM*XWC/3D0)*SHR
25740 210 CONTINUE
25741 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
25742 VINT(111)=0D0
25743 VINT(112)=0D0
25744 VINT(114)=0D0
25745 ENDIF
25746 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25747 KFI=IABS(MINT(15))
25748 IF(KFI.GT.20) KFI=IABS(MINT(16))
25749 EI=KCHG(KFI,1)/3D0
25750 AI=SIGN(1D0,EI)
25751 VI=AI-4D0*EI*XWV
25752 SQMZ=PMAS(23,1)**2
25753 HZ=SHR*WDTP(0)
25754 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=1D0
25755 IF(MSTP(43).EQ.3) VINT(112)=
25756 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
25757 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25758 & XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
25759 ENDIF
25760 DO 220 I=1,MDCY(KC,3)
25761 IDC=I+MDCY(KC,2)-1
25762 IF(MDME(IDC,1).LT.0) GOTO 220
25763 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25764 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25765 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 220
25766 WID2=1D0
25767 IF(I.LE.8) THEN
25768C...Z0 -> q + qbar
25769 EF=KCHG(I,1)/3D0
25770 AF=SIGN(1D0,EF+0.1D0)
25771 VF=AF-4D0*EF*XWV
25772 FCOF=3D0*RADC
25773 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
25774 IF(I.EQ.6) WID2=WIDS(6,1)
25775 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25776 ELSEIF(I.LE.16) THEN
25777C...Z0 -> l+ + l-, nu + nubar
25778 EF=KCHG(I+2,1)/3D0
25779 AF=SIGN(1D0,EF+0.1D0)
25780 VF=AF-4D0*EF*XWV
25781 FCOF=1D0
25782 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
25783 ENDIF
25784 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
25785 IF(ICASE.EQ.1) THEN
25786 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
25787 & BE34
25788 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
25789 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
25790 & EF*VF+(VI**2+AI**2)*VINT(114)*VF**2)*(1D0+2D0*RM1)+
25791 & (VI**2+AI**2)*VINT(114)*AF**2*(1D0-4D0*RM1))*BE34
25792 ELSEIF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25793 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
25794 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
25795 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
25796 ENDIF
25797 IF(ICASE.EQ.1) WDTP(I)=FUDGE*WDTP(I)
25798 IF(ICASE.EQ.1) WDTP(0)=WDTP(0)+WDTP(I)
25799 IF(MDME(IDC,1).GT.0) THEN
25800 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
25801 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
25802 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25803 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
25804 & WDTE(I,MDME(IDC,1))
25805 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25806 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25807 ENDIF
25808 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
25809 IF(MSTP(43).EQ.1.OR.MSTP(43).EQ.3) VINT(111)=
25810 & VINT(111)+FGGF*WID2
25811 IF(MSTP(43).EQ.3) VINT(112)=VINT(112)+FGZF*WID2
25812 IF(MSTP(43).EQ.2.OR.MSTP(43).EQ.3) VINT(114)=
25813 & VINT(114)+FZZF*WID2
25814 ENDIF
25815 ENDIF
25816 220 CONTINUE
25817 IF(MINT(61).GE.1) ICASE=3-ICASE
25818 IF(ICASE.EQ.2) GOTO 210
25819
25820 ELSEIF(KFLA.EQ.24) THEN
25821C...W+/-:
25822 FAC=(AEM/(24D0*XW))*SHR
25823 DO 230 I=1,MDCY(KC,3)
25824 IDC=I+MDCY(KC,2)-1
25825 IF(MDME(IDC,1).LT.0) GOTO 230
25826 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SH
25827 RM2=PMAS(IABS(KFDP(IDC,2)),1)**2/SH
25828 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 230
25829 WID2=1D0
25830 IF(I.LE.16) THEN
25831C...W+/- -> q + qbar'
25832 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
25833 IF(KFLR.GT.0) THEN
25834 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
25835 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
25836 IF(I.GE.13) WID2=WID2*WIDS(7,3)
25837 ELSE
25838 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
25839 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
25840 IF(I.GE.13) WID2=WID2*WIDS(7,2)
25841 ENDIF
25842 ELSEIF(I.LE.20) THEN
25843C...W+/- -> l+/- + nu
25844 FCOF=1D0
25845 IF(KFLR.GT.0) THEN
25846 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
25847 ELSE
25848 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
25849 ENDIF
25850 ENDIF
25851 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
25852 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
25853 WDTP(I)=FUDGE*WDTP(I)
25854 WDTP(0)=WDTP(0)+WDTP(I)
25855 IF(MDME(IDC,1).GT.0) THEN
25856 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
25857 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
25858 WDTE(I,0)=WDTE(I,MDME(IDC,1))
25859 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
25860 ENDIF
25861 230 CONTINUE
25862
25863 ELSEIF(KFLA.EQ.25.OR.KFLA.EQ.35.OR.KFLA.EQ.36) THEN
25864C...h0 (or H0, or A0):
25865 SHFS=SH
25866 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
25867 DO 270 I=1,MDCY(KFHIGG,3)
25868 IDC=I+MDCY(KFHIGG,2)-1
25869 IF(MDME(IDC,1).LT.0) GOTO 270
25870 KFC1=PYCOMP(KFDP(IDC,1))
25871 KFC2=PYCOMP(KFDP(IDC,2))
25872 RM1=PMAS(KFC1,1)**2/SH
25873 RM2=PMAS(KFC2,1)**2/SH
25874 IF(I.NE.16.AND.I.NE.17.AND.SQRT(RM1)+SQRT(RM2).GT.1D0)
25875 & GOTO 270
25876 WID2=1D0
25877
25878 IF(I.LE.8) THEN
25879C...h0 -> q + qbar
25880 WDTP(I)=FAC*3D0*(PYMRUN(KFDP(IDC,1),SH)**2/SHFS)*
25881 & SQRT(MAX(0D0,1D0-4D0*RM1))*RADC
25882C...A0 behaves like beta, ho and H0 like beta**3.
25883 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25884 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25885 IF(MOD(I,2).EQ.1) WDTP(I)=WDTP(I)*PARU(151+10*IHIGG)**2
25886 IF(MOD(I,2).EQ.0) WDTP(I)=WDTP(I)*PARU(152+10*IHIGG)**2
25887 IF(IMSS(1).NE.0.AND.KFC1.EQ.5) THEN
25888 WDTP(I)=WDTP(I)/(1D0+RMSS(41))**2
25889 IF(IHIGG.NE.3) THEN
25890 WDTP(I)=WDTP(I)*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
25891 & PARU(151+10*IHIGG))**2
25892 ENDIF
25893 ENDIF
25894 ENDIF
25895 IF(I.EQ.6) WID2=WIDS(6,1)
25896 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
25897 ELSEIF(I.LE.12) THEN
25898C...h0 -> l+ + l-
25899 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))*(SH/SHFS)
25900C...A0 behaves like beta, ho and H0 like beta**3.
25901 IF(IHIGG.NE.3) WDTP(I)=WDTP(I)*(1D0-4D0*RM1)
25902 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
25903 & PARU(153+10*IHIGG)**2
25904 IF(I.EQ.12) WID2=WIDS(17,1)
25905
25906 ELSEIF(I.EQ.13) THEN
25907C...h0 -> g + g; quark loop contribution only
25908 ETARE=0D0
25909 ETAIM=0D0
25910 DO 240 J=1,2*MSTP(1)
25911 EPS=(2D0*PMAS(J,1))**2/SH
25912C...Loop integral; function of eps=4m^2/shat; different for A0.
25913 IF(EPS.LE.1D0) THEN
25914 IF(EPS.GT.1D-4) THEN
25915 ROOT=SQRT(1D0-EPS)
25916 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25917 ELSE
25918 RLN=LOG(4D0/EPS-2D0)
25919 ENDIF
25920 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25921 PHIIM=0.5D0*PARU(1)*RLN
25922 ELSE
25923 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25924 PHIIM=0D0
25925 ENDIF
25926 IF(IHIGG.LE.2) THEN
25927 ETAREJ=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25928 ETAIMJ=-0.5D0*EPS*(1D0-EPS)*PHIIM
25929 ELSE
25930 ETAREJ=-0.5D0*EPS*PHIRE
25931 ETAIMJ=-0.5D0*EPS*PHIIM
25932 ENDIF
25933C...Couplings (=1 for standard model Higgs).
25934 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
25935 IF(MOD(J,2).EQ.1) THEN
25936 ETAREJ=ETAREJ*PARU(151+10*IHIGG)
25937 ETAIMJ=ETAIMJ*PARU(151+10*IHIGG)
25938 ELSE
25939 ETAREJ=ETAREJ*PARU(152+10*IHIGG)
25940 ETAIMJ=ETAIMJ*PARU(152+10*IHIGG)
25941 ENDIF
25942 ENDIF
25943 ETARE=ETARE+ETAREJ
25944 ETAIM=ETAIM+ETAIMJ
25945 240 CONTINUE
25946 ETA2=ETARE**2+ETAIM**2
25947 WDTP(I)=FAC*(AS/PARU(1))**2*ETA2
25948
25949 ELSEIF(I.EQ.14) THEN
25950C...h0 -> gamma + gamma; quark, lepton, W+- and H+- loop contributions
25951 ETARE=0D0
25952 ETAIM=0D0
25953 JMAX=3*MSTP(1)+1
25954 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
25955 DO 250 J=1,JMAX
25956 IF(J.LE.2*MSTP(1)) THEN
25957 EJ=KCHG(J,1)/3D0
25958 EPS=(2D0*PMAS(J,1))**2/SH
25959 ELSEIF(J.LE.3*MSTP(1)) THEN
25960 JL=2*(J-2*MSTP(1))-1
25961 EJ=KCHG(10+JL,1)/3D0
25962 EPS=(2D0*PMAS(10+JL,1))**2/SH
25963 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
25964 EPS=(2D0*PMAS(24,1))**2/SH
25965 ELSE
25966 EPS=(2D0*PMAS(37,1))**2/SH
25967 ENDIF
25968C...Loop integral; function of eps=4m^2/shat.
25969 IF(EPS.LE.1D0) THEN
25970 IF(EPS.GT.1D-4) THEN
25971 ROOT=SQRT(1D0-EPS)
25972 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
25973 ELSE
25974 RLN=LOG(4D0/EPS-2D0)
25975 ENDIF
25976 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
25977 PHIIM=0.5D0*PARU(1)*RLN
25978 ELSE
25979 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
25980 PHIIM=0D0
25981 ENDIF
25982 IF(J.LE.3*MSTP(1)) THEN
25983C...Fermion loops: loop integral different for A0; charges.
25984 IF(IHIGG.LE.2) THEN
25985 PHIPRE=-0.5D0*EPS*(1D0+(1D0-EPS)*PHIRE)
25986 PHIPIM=-0.5D0*EPS*(1D0-EPS)*PHIIM
25987 ELSE
25988 PHIPRE=-0.5D0*EPS*PHIRE
25989 PHIPIM=-0.5D0*EPS*PHIIM
25990 ENDIF
25991 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
25992 EJC=3D0*EJ**2
25993 EJH=PARU(151+10*IHIGG)
25994 ELSEIF(J.LE.2*MSTP(1)) THEN
25995 EJC=3D0*EJ**2
25996 EJH=PARU(152+10*IHIGG)
25997 ELSE
25998 EJC=EJ**2
25999 EJH=PARU(153+10*IHIGG)
26000 ENDIF
26001 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
26002 ETAREJ=EJC*EJH*PHIPRE
26003 ETAIMJ=EJC*EJH*PHIPIM
26004 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
26005C...W loops: loop integral and charges.
26006 ETAREJ=0.5D0+0.75D0*EPS*(1D0+(2D0-EPS)*PHIRE)
26007 ETAIMJ=0.75D0*EPS*(2D0-EPS)*PHIIM
26008 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
26009 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
26010 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
26011 ENDIF
26012 ELSE
26013C...Charged H loops: loop integral and charges.
26014 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*
26015 & PARU(158+10*IHIGG+2*(IHIGG/3))
26016 ETAREJ=EPS*(1D0-EPS*PHIRE)*FACHHH
26017 ETAIMJ=-EPS**2*PHIIM*FACHHH
26018 ENDIF
26019 ETARE=ETARE+ETAREJ
26020 ETAIM=ETAIM+ETAIMJ
26021 250 CONTINUE
26022 ETA2=ETARE**2+ETAIM**2
26023 WDTP(I)=FAC*(AEM/PARU(1))**2*0.5D0*ETA2
26024
26025 ELSEIF(I.EQ.15) THEN
26026C...h0 -> gamma + Z0; quark, lepton, W and H+- loop contributions
26027 ETARE=0D0
26028 ETAIM=0D0
26029 JMAX=3*MSTP(1)+1
26030 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) JMAX=JMAX+1
26031 DO 260 J=1,JMAX
26032 IF(J.LE.2*MSTP(1)) THEN
26033 EJ=KCHG(J,1)/3D0
26034 AJ=SIGN(1D0,EJ+0.1D0)
26035 VJ=AJ-4D0*EJ*XWV
26036 EPS=(2D0*PMAS(J,1))**2/SH
26037 EPSP=(2D0*PMAS(J,1)/PMAS(23,1))**2
26038 ELSEIF(J.LE.3*MSTP(1)) THEN
26039 JL=2*(J-2*MSTP(1))-1
26040 EJ=KCHG(10+JL,1)/3D0
26041 AJ=SIGN(1D0,EJ+0.1D0)
26042 VJ=AJ-4D0*EJ*XWV
26043 EPS=(2D0*PMAS(10+JL,1))**2/SH
26044 EPSP=(2D0*PMAS(10+JL,1)/PMAS(23,1))**2
26045 ELSE
26046 EPS=(2D0*PMAS(24,1))**2/SH
26047 EPSP=(2D0*PMAS(24,1)/PMAS(23,1))**2
26048 ENDIF
26049C...Loop integrals; functions of eps=4m^2/shat and eps'=4m^2/m_Z^2.
26050 IF(EPS.LE.1D0) THEN
26051 ROOT=SQRT(1D0-EPS)
26052 IF(EPS.GT.1D-4) THEN
26053 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
26054 ELSE
26055 RLN=LOG(4D0/EPS-2D0)
26056 ENDIF
26057 PHIRE=-0.25D0*(RLN**2-PARU(1)**2)
26058 PHIIM=0.5D0*PARU(1)*RLN
26059 PSIRE=0.5D0*ROOT*RLN
26060 PSIIM=-0.5D0*ROOT*PARU(1)
26061 ELSE
26062 PHIRE=(ASIN(1D0/SQRT(EPS)))**2
26063 PHIIM=0D0
26064 PSIRE=SQRT(EPS-1D0)*ASIN(1D0/SQRT(EPS))
26065 PSIIM=0D0
26066 ENDIF
26067 IF(EPSP.LE.1D0) THEN
26068 ROOT=SQRT(1D0-EPSP)
26069 IF(EPSP.GT.1D-4) THEN
26070 RLN=LOG((1D0+ROOT)/(1D0-ROOT))
26071 ELSE
26072 RLN=LOG(4D0/EPSP-2D0)
26073 ENDIF
26074 PHIREP=-0.25D0*(RLN**2-PARU(1)**2)
26075 PHIIMP=0.5D0*PARU(1)*RLN
26076 PSIREP=0.5D0*ROOT*RLN
26077 PSIIMP=-0.5D0*ROOT*PARU(1)
26078 ELSE
26079 PHIREP=(ASIN(1D0/SQRT(EPSP)))**2
26080 PHIIMP=0D0
26081 PSIREP=SQRT(EPSP-1D0)*ASIN(1D0/SQRT(EPSP))
26082 PSIIMP=0D0
26083 ENDIF
26084 FXYRE=EPS*EPSP/(8D0*(EPS-EPSP))*(1D0+EPS*EPSP/(EPS-EPSP)*
26085 & (PHIRE-PHIREP)+2D0*EPS/(EPS-EPSP)*(PSIRE-PSIREP))
26086 FXYIM=EPS**2*EPSP/(8D0*(EPS-EPSP)**2)*
26087 & (EPSP*(PHIIM-PHIIMP)+2D0*(PSIIM-PSIIMP))
26088 F1RE=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIRE-PHIREP)
26089 F1IM=-EPS*EPSP/(2D0*(EPS-EPSP))*(PHIIM-PHIIMP)
26090 IF(J.LE.3*MSTP(1)) THEN
26091C...Fermion loops: loop integral different for A0; charges.
26092 IF(IHIGG.EQ.3) FXYRE=0D0
26093 IF(IHIGG.EQ.3) FXYIM=0D0
26094 IF(J.LE.2*MSTP(1).AND.MOD(J,2).EQ.1) THEN
26095 EJC=-3D0*EJ*VJ
26096 EJH=PARU(151+10*IHIGG)
26097 ELSEIF(J.LE.2*MSTP(1)) THEN
26098 EJC=-3D0*EJ*VJ
26099 EJH=PARU(152+10*IHIGG)
26100 ELSE
26101 EJC=-EJ*VJ
26102 EJH=PARU(153+10*IHIGG)
26103 ENDIF
26104 IF(MSTP(4).EQ.0.AND.IHIGG.EQ.1) EJH=1D0
26105 ETAREJ=EJC*EJH*(FXYRE-0.25D0*F1RE)
26106 ETAIMJ=EJC*EJH*(FXYIM-0.25D0*F1IM)
26107 ELSEIF(J.EQ.3*MSTP(1)+1) THEN
26108C...W loops: loop integral and charges.
26109 HEPS=(1D0+2D0/EPS)*XW/XW1-(5D0+2D0/EPS)
26110 ETAREJ=-XW1*((3D0-XW/XW1)*F1RE+HEPS*FXYRE)
26111 ETAIMJ=-XW1*((3D0-XW/XW1)*F1IM+HEPS*FXYIM)
26112 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
26113 ETAREJ=ETAREJ*PARU(155+10*IHIGG)
26114 ETAIMJ=ETAIMJ*PARU(155+10*IHIGG)
26115 ENDIF
26116 ELSE
26117C...Charged H loops: loop integral and charges.
26118 FACHHH=(PMAS(24,1)/PMAS(37,1))**2*(1D0-2D0*XW)*
26119 & PARU(158+10*IHIGG+2*(IHIGG/3))
26120 ETAREJ=FACHHH*FXYRE
26121 ETAIMJ=FACHHH*FXYIM
26122 ENDIF
26123 ETARE=ETARE+ETAREJ
26124 ETAIM=ETAIM+ETAIMJ
26125 260 CONTINUE
26126 ETA2=(ETARE**2+ETAIM**2)/(XW*XW1)
26127 WDTP(I)=FAC*(AEM/PARU(1))**2*(1D0-PMAS(23,1)**2/SH)**3*ETA2
26128 WID2=WIDS(23,2)
26129
26130 ELSEIF(I.LE.17) THEN
26131C...h0 -> Z0 + Z0, W+ + W-
26132 PM1=PMAS(IABS(KFDP(IDC,1)),1)
26133 PG1=PMAS(IABS(KFDP(IDC,1)),2)
26134 IF(MINT(62).GE.1) THEN
26135 IF(MSTP(42).EQ.0.OR.(4D0*(PM1+10D0*PG1)**2.LT.SH.AND.
26136 & CKIN(46).LT.CKIN(45).AND.CKIN(48).LT.CKIN(47).AND.
26137 & MAX(CKIN(45),CKIN(47)).LT.PM1-10D0*PG1)) THEN
26138 MOFSV(IHIGG,I-15)=0
26139 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
26140 & 1D0-4D0*RM1))
26141 WID2=1D0
26142 ELSE
26143 MOFSV(IHIGG,I-15)=1
26144 RMAS=SQRT(MAX(0D0,SH))
26145 CALL PYOFSH(1,KFLA,KFDP(IDC,1),KFDP(IDC,2),RMAS,WIDW,
26146 & WID2)
26147 WIDWSV(IHIGG,I-15)=WIDW
26148 WID2SV(IHIGG,I-15)=WID2
26149 ENDIF
26150 ELSE
26151 IF(MOFSV(IHIGG,I-15).EQ.0) THEN
26152 WIDW=(1D0-4D0*RM1+12D0*RM1**2)*SQRT(MAX(0D0,
26153 & 1D0-4D0*RM1))
26154 WID2=1D0
26155 ELSE
26156 WIDW=WIDWSV(IHIGG,I-15)
26157 WID2=WID2SV(IHIGG,I-15)
26158 ENDIF
26159 ENDIF
26160 WDTP(I)=FAC*WIDW/(2D0*(18-I))
26161 IF(MSTP(49).NE.0) WDTP(I)=WDTP(I)*PMAS(KFHIGG,1)**2/SHFS
26162 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) WDTP(I)=WDTP(I)*
26163 & PARU(138+I+10*IHIGG)**2
26164 WID2=WID2*WIDS(7+I,1)
26165
26166 ELSEIF(I.EQ.18.AND.IHIGG.GE.2) THEN
26167C...H0 -> Z0 + h0, A0-> Z0 + h0
26168 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
26169 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26170 IF(IHIGG.EQ.2) THEN
26171 WDTP(I)=WDTP(I)*PARU(179)**2
26172 ELSEIF(IHIGG.EQ.3) THEN
26173 WDTP(I)=WDTP(I)*PARU(186)**2
26174 ENDIF
26175 WID2=WIDS(23,2)*WIDS(25,2)
26176
26177 ELSEIF(I.EQ.19.AND.IHIGG.GE.2) THEN
26178C...H0 -> h0 + h0, A0-> h0 + h0
26179 WDTP(I)=FAC*0.25D0*
26180 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
26181 IF(IHIGG.EQ.2) THEN
26182 WDTP(I)=WDTP(I)*PARU(176)**2
26183 ELSEIF(IHIGG.EQ.3) THEN
26184 WDTP(I)=WDTP(I)*PARU(169)**2
26185 ENDIF
26186 WID2=WIDS(25,1)
26187 ELSEIF((I.EQ.20.OR.I.EQ.21).AND.IHIGG.GE.2) THEN
26188C...H0 -> W+/- + H-/+, A0 -> W+/- + H-/+
26189 WDTP(I)=FAC*0.5D0*SQRT(MAX(0D0,
26190 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26191 & *PARU(195+IHIGG)**2
26192 IF(I.EQ.20) THEN
26193 WID2=WIDS(24,2)*WIDS(37,3)
26194 ELSEIF(I.EQ.21) THEN
26195 WID2=WIDS(24,3)*WIDS(37,2)
26196 ENDIF
26197
26198 ELSEIF(I.EQ.22.AND.IHIGG.EQ.2) THEN
26199C...H0 -> Z0 + A0.
26200 WDTP(I)=FAC*0.5D0*PARU(187)**2*SQRT(MAX(0D0,
26201 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26202 WID2=WIDS(36,2)*WIDS(23,2)
26203
26204 ELSEIF(I.EQ.23.AND.IHIGG.EQ.2) THEN
26205C...H0 -> h0 + A0.
26206 WDTP(I)=FAC*0.5D0*PARU(180)**2*
26207 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
26208 WID2=WIDS(25,2)*WIDS(36,2)
26209
26210 ELSEIF(I.EQ.24.AND.IHIGG.EQ.2) THEN
26211C...H0 -> A0 + A0
26212 WDTP(I)=FAC*0.25D0*PARU(177)**2*
26213 & PMAS(23,1)**4/SH**2*SQRT(MAX(0D0,1D0-4D0*RM1))
26214 WID2=WIDS(36,1)
26215
26216CMRENNA++
26217 ELSE
26218C...Add in SUSY decays (two-body) by rescaling by phase space factor.
26219 RM10=RM1*SH/PMR**2
26220 RM20=RM2*SH/PMR**2
26221 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
26222 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
26223 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
26224 WFAC=0D0
26225 ELSE
26226 WFAC=WFAC/WFAC0
26227 ENDIF
26228 WDTP(I)=PMAS(KFLA,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
26229CMRENNA--
26230 IF(KFC2.EQ.KFC1) THEN
26231 WID2=WIDS(KFC1,1)
26232 ELSE
26233 KSGN1=2
26234 IF(KFDP(IDC,1).LT.0) KSGN1=3
26235 KSGN2=2
26236 IF(KFDP(IDC,2).LT.0) KSGN2=3
26237 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
26238 ENDIF
26239 ENDIF
26240 WDTP(I)=FUDGE*WDTP(I)
26241 WDTP(0)=WDTP(0)+WDTP(I)
26242 IF(MDME(IDC,1).GT.0) THEN
26243 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26244 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26245 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26246 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26247 ENDIF
26248 270 CONTINUE
26249
26250 ELSEIF(KFLA.EQ.32) THEN
26251C...Z'0:
26252 ICASE=1
26253 XWC=1D0/(16D0*XW*XW1)
26254 FAC=(AEM*XWC/3D0)*SHR
26255 VINT(117)=0D0
26256 280 CONTINUE
26257 IF(MINT(61).GE.1.AND.ICASE.EQ.2) THEN
26258 VINT(111)=0D0
26259 VINT(112)=0D0
26260 VINT(113)=0D0
26261 VINT(114)=0D0
26262 VINT(115)=0D0
26263 VINT(116)=0D0
26264 ENDIF
26265 IF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26266 KFAI=IABS(MINT(15))
26267 EI=KCHG(KFAI,1)/3D0
26268 AI=SIGN(1D0,EI+0.1D0)
26269 VI=AI-4D0*EI*XWV
26270 KFAIC=1
26271 IF(KFAI.LE.10.AND.MOD(KFAI,2).EQ.0) KFAIC=2
26272 IF(KFAI.GT.10.AND.MOD(KFAI,2).NE.0) KFAIC=3
26273 IF(KFAI.GT.10.AND.MOD(KFAI,2).EQ.0) KFAIC=4
26274 IF(KFAI.LE.2.OR.KFAI.EQ.11.OR.KFAI.EQ.12) THEN
26275 VPI=PARU(119+2*KFAIC)
26276 API=PARU(120+2*KFAIC)
26277 ELSEIF(KFAI.LE.4.OR.KFAI.EQ.13.OR.KFAI.EQ.14) THEN
26278 VPI=PARJ(178+2*KFAIC)
26279 API=PARJ(179+2*KFAIC)
26280 ELSE
26281 VPI=PARJ(186+2*KFAIC)
26282 API=PARJ(187+2*KFAIC)
26283 ENDIF
26284 SQMZ=PMAS(23,1)**2
26285 HZ=SHR*VINT(117)
26286 SQMZP=PMAS(32,1)**2
26287 HZP=SHR*WDTP(0)
26288 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
26289 & MSTP(44).EQ.7) VINT(111)=1D0
26290 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=
26291 & 2D0*XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+HZ**2)
26292 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=
26293 & 2D0*XWC*SH*(SH-SQMZP)/((SH-SQMZP)**2+HZP**2)
26294 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
26295 & MSTP(44).EQ.7) VINT(114)=XWC**2*SH**2/((SH-SQMZ)**2+HZ**2)
26296 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=
26297 & 2D0*XWC**2*SH**2*((SH-SQMZ)*(SH-SQMZP)+HZ*HZP)/
26298 & (((SH-SQMZ)**2+HZ**2)*((SH-SQMZP)**2+HZP**2))
26299 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
26300 & MSTP(44).EQ.7) VINT(116)=XWC**2*SH**2/((SH-SQMZP)**2+HZP**2)
26301 ENDIF
26302 DO 290 I=1,MDCY(KC,3)
26303 IDC=I+MDCY(KC,2)-1
26304 IF(MDME(IDC,1).LT.0) GOTO 290
26305 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26306 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26307 IF(SQRT(RM1)+SQRT(RM2).GT.1D0.OR.MDME(IDC,1).LT.0) GOTO 290
26308 WID2=1D0
26309 IF(I.LE.16) THEN
26310 IF(I.LE.8) THEN
26311C...Z'0 -> q + qbar
26312 EF=KCHG(I,1)/3D0
26313 AF=SIGN(1D0,EF+0.1D0)
26314 VF=AF-4D0*EF*XWV
26315 IF(I.LE.2) THEN
26316 VPF=PARU(123-2*MOD(I,2))
26317 APF=PARU(124-2*MOD(I,2))
26318 ELSEIF(I.LE.4) THEN
26319 VPF=PARJ(182-2*MOD(I,2))
26320 APF=PARJ(183-2*MOD(I,2))
26321 ELSE
26322 VPF=PARJ(190-2*MOD(I,2))
26323 APF=PARJ(191-2*MOD(I,2))
26324 ENDIF
26325 FCOF=3D0*RADC
26326 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
26327 & PYHFTH(SH,SH*RM1,1D0)
26328 IF(I.EQ.6) WID2=WIDS(6,1)
26329 IF((I.EQ.7.OR.I.EQ.8)) WID2=WIDS(I,1)
26330 ELSEIF(I.LE.16) THEN
26331C...Z'0 -> l+ + l-, nu + nubar
26332 EF=KCHG(I+2,1)/3D0
26333 AF=SIGN(1D0,EF+0.1D0)
26334 VF=AF-4D0*EF*XWV
26335 IF(I.LE.10) THEN
26336 VPF=PARU(127-2*MOD(I,2))
26337 APF=PARU(128-2*MOD(I,2))
26338 ELSEIF(I.LE.12) THEN
26339 VPF=PARJ(186-2*MOD(I,2))
26340 APF=PARJ(187-2*MOD(I,2))
26341 ELSE
26342 VPF=PARJ(194-2*MOD(I,2))
26343 APF=PARJ(195-2*MOD(I,2))
26344 ENDIF
26345 FCOF=1D0
26346 IF((I.EQ.15.OR.I.EQ.16)) WID2=WIDS(2+I,1)
26347 ENDIF
26348 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
26349 IF(ICASE.EQ.1) THEN
26350 WDTPZ=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
26351 WDTP(I)=FAC*FCOF*(VPF**2*(1D0+2D0*RM1)+
26352 & APF**2*(1D0-4D0*RM1))*BE34
26353 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26354 WDTP(I)=FAC*FCOF*((EI**2*VINT(111)*EF**2+EI*VI*VINT(112)*
26355 & EF*VF+EI*VPI*VINT(113)*EF*VPF+(VI**2+AI**2)*VINT(114)*
26356 & VF**2+(VI*VPI+AI*API)*VINT(115)*VF*VPF+(VPI**2+API**2)*
26357 & VINT(116)*VPF**2)*(1D0+2D0*RM1)+((VI**2+AI**2)*VINT(114)*
26358 & AF**2+(VI*VPI+AI*API)*VINT(115)*AF*APF+(VPI**2+API**2)*
26359 & VINT(116)*APF**2)*(1D0-4D0*RM1))*BE34
26360 ELSEIF(MINT(61).EQ.2) THEN
26361 FGGF=FCOF*EF**2*(1D0+2D0*RM1)*BE34
26362 FGZF=FCOF*EF*VF*(1D0+2D0*RM1)*BE34
26363 FGZPF=FCOF*EF*VPF*(1D0+2D0*RM1)*BE34
26364 FZZF=FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*BE34
26365 FZZPF=FCOF*(VF*VPF*(1D0+2D0*RM1)+AF*APF*(1D0-4D0*RM1))*
26366 & BE34
26367 FZPZPF=FCOF*(VPF**2*(1D0+2D0*RM1)+APF**2*(1D0-4D0*RM1))*
26368 & BE34
26369 ENDIF
26370 ELSEIF(I.EQ.17) THEN
26371C...Z'0 -> W+ + W-
26372 WDTPZP=PARU(129)**2*XW1**2*
26373 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26374 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
26375 IF(ICASE.EQ.1) THEN
26376 WDTPZ=0D0
26377 WDTP(I)=FAC*WDTPZP
26378 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26379 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
26380 ELSEIF(MINT(61).EQ.2) THEN
26381 FGGF=0D0
26382 FGZF=0D0
26383 FGZPF=0D0
26384 FZZF=0D0
26385 FZZPF=0D0
26386 FZPZPF=WDTPZP
26387 ENDIF
26388 WID2=WIDS(24,1)
26389 ELSEIF(I.EQ.18) THEN
26390C...Z'0 -> H+ + H-
26391 CZC=2D0*(1D0-2D0*XW)
26392 BE34C=(1D0-4D0*RM1)*SQRT(MAX(0D0,1D0-4D0*RM1))
26393 IF(ICASE.EQ.1) THEN
26394 WDTPZ=0.25D0*PARU(142)**2*CZC**2*BE34C
26395 WDTP(I)=FAC*0.25D0*PARU(143)**2*CZC**2*BE34C
26396 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26397 WDTP(I)=FAC*0.25D0*(EI**2*VINT(111)+PARU(142)*EI*VI*
26398 & VINT(112)*CZC+PARU(143)*EI*VPI*VINT(113)*CZC+PARU(142)**2*
26399 & (VI**2+AI**2)*VINT(114)*CZC**2+PARU(142)*PARU(143)*
26400 & (VI*VPI+AI*API)*VINT(115)*CZC**2+PARU(143)**2*
26401 & (VPI**2+API**2)*VINT(116)*CZC**2)*BE34C
26402 ELSEIF(MINT(61).EQ.2) THEN
26403 FGGF=0.25D0*BE34C
26404 FGZF=0.25D0*PARU(142)*CZC*BE34C
26405 FGZPF=0.25D0*PARU(143)*CZC*BE34C
26406 FZZF=0.25D0*PARU(142)**2*CZC**2*BE34C
26407 FZZPF=0.25D0*PARU(142)*PARU(143)*CZC**2*BE34C
26408 FZPZPF=0.25D0*PARU(143)**2*CZC**2*BE34C
26409 ENDIF
26410 WID2=WIDS(37,1)
26411 ELSEIF(I.EQ.19) THEN
26412C...Z'0 -> Z0 + gamma.
26413 ELSEIF(I.EQ.20) THEN
26414C...Z'0 -> Z0 + h0
26415 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26416 WDTPZP=PARU(145)**2*4D0*ABS(1D0-2D0*XW)*
26417 & (3D0*RM1+0.25D0*FLAM**2)*FLAM
26418 IF(ICASE.EQ.1) THEN
26419 WDTPZ=0D0
26420 WDTP(I)=FAC*WDTPZP
26421 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26422 WDTP(I)=FAC*(VPI**2+API**2)*VINT(116)*WDTPZP
26423 ELSEIF(MINT(61).EQ.2) THEN
26424 FGGF=0D0
26425 FGZF=0D0
26426 FGZPF=0D0
26427 FZZF=0D0
26428 FZZPF=0D0
26429 FZPZPF=WDTPZP
26430 ENDIF
26431 WID2=WIDS(23,2)*WIDS(25,2)
26432 ELSEIF(I.EQ.21.OR.I.EQ.22) THEN
26433C...Z' -> h0 + A0 or H0 + A0.
26434 BE34C=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26435 IF(I.EQ.21) THEN
26436 CZAH=PARU(186)
26437 CZPAH=PARU(188)
26438 ELSE
26439 CZAH=PARU(187)
26440 CZPAH=PARU(189)
26441 ENDIF
26442 IF(ICASE.EQ.1) THEN
26443 WDTPZ=CZAH**2*BE34C
26444 WDTP(I)=FAC*CZPAH**2*BE34C
26445 ELSEIF(MINT(61).EQ.1.AND.ICASE.EQ.2) THEN
26446 WDTP(I)=FAC*(CZAH**2*(VI**2+AI**2)*VINT(114)+CZAH*CZPAH*
26447 & (VI*VPI+AI*API)*VINT(115)+CZPAH**2*(VPI**2+API**2)*
26448 & VINT(116))*BE34C
26449 ELSEIF(MINT(61).EQ.2) THEN
26450 FGGF=0D0
26451 FGZF=0D0
26452 FGZPF=0D0
26453 FZZF=CZAH**2*BE34C
26454 FZZPF=CZAH*CZPAH*BE34C
26455 FZPZPF=CZPAH**2*BE34C
26456 ENDIF
26457 IF(I.EQ.21) WID2=WIDS(25,2)*WIDS(36,2)
26458 IF(I.EQ.22) WID2=WIDS(35,2)*WIDS(36,2)
26459 ENDIF
26460 IF(ICASE.EQ.1) THEN
26461 VINT(117)=VINT(117)+FAC*WDTPZ
26462 WDTP(I)=FUDGE*WDTP(I)
26463 WDTP(0)=WDTP(0)+WDTP(I)
26464 ENDIF
26465 IF(MDME(IDC,1).GT.0) THEN
26466 IF((ICASE.EQ.1.AND.MINT(61).NE.1).OR.
26467 & (ICASE.EQ.2.AND.MINT(61).EQ.1)) THEN
26468 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26469 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+
26470 & WDTE(I,MDME(IDC,1))
26471 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26472 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26473 ENDIF
26474 IF(MINT(61).EQ.2.AND.ICASE.EQ.2) THEN
26475 IF(MSTP(44).EQ.1.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.5.OR.
26476 & MSTP(44).EQ.7) VINT(111)=VINT(111)+FGGF*WID2
26477 IF(MSTP(44).EQ.4.OR.MSTP(44).EQ.7) VINT(112)=VINT(112)+
26478 & FGZF*WID2
26479 IF(MSTP(44).EQ.5.OR.MSTP(44).EQ.7) VINT(113)=VINT(113)+
26480 & FGZPF*WID2
26481 IF(MSTP(44).EQ.2.OR.MSTP(44).EQ.4.OR.MSTP(44).EQ.6.OR.
26482 & MSTP(44).EQ.7) VINT(114)=VINT(114)+FZZF*WID2
26483 IF(MSTP(44).EQ.6.OR.MSTP(44).EQ.7) VINT(115)=VINT(115)+
26484 & FZZPF*WID2
26485 IF(MSTP(44).EQ.3.OR.MSTP(44).EQ.5.OR.MSTP(44).EQ.6.OR.
26486 & MSTP(44).EQ.7) VINT(116)=VINT(116)+FZPZPF*WID2
26487 ENDIF
26488 ENDIF
26489 290 CONTINUE
26490 IF(MINT(61).GE.1) ICASE=3-ICASE
26491 IF(ICASE.EQ.2) GOTO 280
26492
26493 ELSEIF(KFLA.EQ.34) THEN
26494C...W'+/-:
26495 FAC=(AEM/(24D0*XW))*SHR
26496 DO 300 I=1,MDCY(KC,3)
26497 IDC=I+MDCY(KC,2)-1
26498 IF(MDME(IDC,1).LT.0) GOTO 300
26499 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26500 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26501 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 300
26502 WID2=1D0
26503 IF(I.LE.20) THEN
26504 IF(I.LE.16) THEN
26505C...W'+/- -> q + qbar'
26506 CKMFAC = VCKM((I-1)/4+1,MOD(I-1,4)+1)
26507 FCOF=3D0*CKMFAC*RADC*(PARU(131)**2+PARU(132)**2)
26508 FCOF2=3D0*CKMFAC*RADC*(PARU(131)**2-PARU(132)**2)
26509 IF(KFLR.GT.0) THEN
26510 IF(MOD(I,4).EQ.3) WID2=WIDS(6,2)
26511 IF(MOD(I,4).EQ.0) WID2=WIDS(8,2)
26512 IF(I.GE.13) WID2=WID2*WIDS(7,3)
26513 ELSE
26514 IF(MOD(I,4).EQ.3) WID2=WIDS(6,3)
26515 IF(MOD(I,4).EQ.0) WID2=WIDS(8,3)
26516 IF(I.GE.13) WID2=WID2*WIDS(7,2)
26517 ENDIF
26518 ELSEIF(I.LE.20) THEN
26519C...W'+/- -> l+/- + nu
26520 FCOF=PARU(133)**2+PARU(134)**2
26521 FCOF2=PARU(133)**2-PARU(134)**2
26522 IF(KFLR.GT.0) THEN
26523 IF(I.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
26524 ELSE
26525 IF(I.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
26526 ENDIF
26527 ENDIF
26528 WDTP(I)=FAC*0.5*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)
26529 & *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26530 IF (RM1.GT.0D0.AND.RM2.GT.0D0) THEN
26531C...PS 28/06/2010
26532C...Inserted (gV2-gA2)*sqrt(m1*m2) term (FCOF2), following M. Chizhov
26533 WDTP(I)=WDTP(I) + FAC*0.5*6D0*FCOF2*SQRT(RM1*RM2)
26534 & *SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26535 ENDIF
26536 ELSEIF(I.EQ.21) THEN
26537C...W'+/- -> W+/- + Z0
26538 WDTP(I)=FAC*PARU(135)**2*0.5D0*XW1*(RM1/RM2)*
26539 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
26540 & (1D0+10D0*RM1+10D0*RM2+RM1**2+RM2**2+10D0*RM1*RM2)
26541 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(23,2)
26542 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(23,2)
26543 ELSEIF(I.EQ.23) THEN
26544C...W'+/- -> W+/- + h0
26545 FLAM=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26546 WDTP(I)=FAC*PARU(146)**2*2D0*(3D0*RM1+0.25D0*FLAM**2)*FLAM
26547 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
26548 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
26549 ENDIF
26550 WDTP(I)=FUDGE*WDTP(I)
26551 WDTP(0)=WDTP(0)+WDTP(I)
26552 IF(MDME(IDC,1).GT.0) THEN
26553 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26554 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26555 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26556 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26557 ENDIF
26558 300 CONTINUE
26559
26560 ELSEIF(KFLA.EQ.37) THEN
26561C...H+/-:
26562C IF(MSTP(49).EQ.0) THEN
26563 SHFS=SH
26564C ELSE
26565C SHFS=PMAS(37,1)**2
26566C ENDIF
26567 FAC=(AEM/(8D0*XW))*(SHFS/PMAS(24,1)**2)*SHR
26568 DO 310 I=1,MDCY(KC,3)
26569 IDC=I+MDCY(KC,2)-1
26570 IF(MDME(IDC,1).LT.0) GOTO 310
26571 KFC1=PYCOMP(KFDP(IDC,1))
26572 KFC2=PYCOMP(KFDP(IDC,2))
26573 RM1=PMAS(KFC1,1)**2/SH
26574 RM2=PMAS(KFC2,1)**2/SH
26575 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 310
26576 WID2=1D0
26577 IF(I.LE.4) THEN
26578C...H+/- -> q + qbar'
26579 RM1R=PYMRUN(KFDP(IDC,1),SH)**2/SH
26580 RM2R=PYMRUN(KFDP(IDC,2),SH)**2/SH
26581 WDTP(I)=FAC*3D0*RADC*MAX(0D0,(RM1R*PARU(141)**2+
26582 & RM2R/PARU(141)**2)*(1D0-RM1R-RM2R)-4D0*RM1R*RM2R)*
26583 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
26584 IF(KFLR.GT.0) THEN
26585 IF(I.EQ.3) WID2=WIDS(6,2)
26586 IF(I.EQ.4) WID2=WIDS(7,3)*WIDS(8,2)
26587 ELSE
26588 IF(I.EQ.3) WID2=WIDS(6,3)
26589 IF(I.EQ.4) WID2=WIDS(7,2)*WIDS(8,3)
26590 ENDIF
26591 ELSEIF(I.LE.8) THEN
26592C...H+/- -> l+/- + nu
26593 WDTP(I)=FAC*((RM1*PARU(141)**2+RM2/PARU(141)**2)*
26594 & (1D0-RM1-RM2)-4D0*RM1*RM2)*SQRT(MAX(0D0,
26595 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))*(SH/SHFS)
26596 IF(KFLR.GT.0) THEN
26597 IF(I.EQ.8) WID2=WIDS(17,3)*WIDS(18,2)
26598 ELSE
26599 IF(I.EQ.8) WID2=WIDS(17,2)*WIDS(18,3)
26600 ENDIF
26601 ELSEIF(I.EQ.9) THEN
26602C...H+/- -> W+/- + h0.
26603 WDTP(I)=FAC*PARU(195)**2*0.5D0*SQRT(MAX(0D0,
26604 & (1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26605 IF(KFLR.GT.0) WID2=WIDS(24,2)*WIDS(25,2)
26606 IF(KFLR.LT.0) WID2=WIDS(24,3)*WIDS(25,2)
26607
26608CMRENNA++
26609 ELSE
26610C...Add in SUSY decays (two-body) by rescaling by phase space factor.
26611 RM10=RM1*SH/PMR**2
26612 RM20=RM2*SH/PMR**2
26613 WFAC0=1D0+RM10**2+RM20**2-2D0*(RM10+RM20+RM10*RM20)
26614 WFAC=1D0+RM1**2+RM2**2-2D0*(RM1+RM2+RM1*RM2)
26615 IF(WFAC.LE.0D0 .OR. WFAC0.LE.0D0) THEN
26616 WFAC=0D0
26617 ELSE
26618 WFAC=WFAC/WFAC0
26619 ENDIF
26620 WDTP(I)=PMAS(KC,2)*BRAT(IDC)*(SHR/PMR)*SQRT(WFAC)
26621CMRENNA--
26622 KSGN1=2
26623 IF(KFLS*KFDP(IDC,1).LT.0.AND.KCHG(KFC1,3).EQ.1) KSGN1=3
26624 KSGN2=2
26625 IF(KFLS*KFDP(IDC,2).LT.0.AND.KCHG(KFC2,3).EQ.1) KSGN2=3
26626 WID2=WIDS(KFC1,KSGN1)*WIDS(KFC2,KSGN2)
26627 ENDIF
26628 WDTP(I)=FUDGE*WDTP(I)
26629 WDTP(0)=WDTP(0)+WDTP(I)
26630 IF(MDME(IDC,1).GT.0) THEN
26631 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26632 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26633 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26634 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26635 ENDIF
26636 310 CONTINUE
26637
26638 ELSEIF(KFLA.EQ.41) THEN
26639C...R:
26640 FAC=(AEM/(12D0*XW))*SHR
26641 DO 320 I=1,MDCY(KC,3)
26642 IDC=I+MDCY(KC,2)-1
26643 IF(MDME(IDC,1).LT.0) GOTO 320
26644 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26645 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26646 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 320
26647 WID2=1D0
26648 IF(I.LE.6) THEN
26649C...R -> q + qbar'
26650 FCOF=3D0*RADC
26651 ELSEIF(I.LE.9) THEN
26652C...R -> l+ + l'-
26653 FCOF=1D0
26654 ENDIF
26655 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
26656 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26657 IF(KFLR.GT.0) THEN
26658 IF(I.EQ.4) WID2=WIDS(6,3)
26659 IF(I.EQ.5) WID2=WIDS(7,3)
26660 IF(I.EQ.6) WID2=WIDS(6,2)*WIDS(8,3)
26661 IF(I.EQ.9) WID2=WIDS(17,3)
26662 ELSE
26663 IF(I.EQ.4) WID2=WIDS(6,2)
26664 IF(I.EQ.5) WID2=WIDS(7,2)
26665 IF(I.EQ.6) WID2=WIDS(6,3)*WIDS(8,2)
26666 IF(I.EQ.9) WID2=WIDS(17,2)
26667 ENDIF
26668 WDTP(I)=FUDGE*WDTP(I)
26669 WDTP(0)=WDTP(0)+WDTP(I)
26670 IF(MDME(IDC,1).GT.0) THEN
26671 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26672 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26673 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26674 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26675 ENDIF
26676 320 CONTINUE
26677
26678 ELSEIF(KFLA.EQ.42) THEN
26679C...LQ (leptoquark).
26680 FAC=(AEM/4D0)*PARU(151)*SHR
26681 DO 330 I=1,MDCY(KC,3)
26682 IDC=I+MDCY(KC,2)-1
26683 IF(MDME(IDC,1).LT.0) GOTO 330
26684 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26685 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26686 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 330
26687 WDTP(I)=FAC*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
26688 WID2=1D0
26689 ILQQ=KFDP(IDC,1)*ISIGN(1,KFLR)
26690 IF(ILQQ.GE.6) WID2=WIDS(ILQQ,2)
26691 IF(ILQQ.LE.-6) WID2=WIDS(-ILQQ,3)
26692 ILQL=KFDP(IDC,2)*ISIGN(1,KFLR)
26693 IF(ILQL.GE.17) WID2=WID2*WIDS(ILQL,2)
26694 IF(ILQL.LE.-17) WID2=WID2*WIDS(-ILQL,3)
26695 WDTP(I)=FUDGE*WDTP(I)
26696 WDTP(0)=WDTP(0)+WDTP(I)
26697 IF(MDME(IDC,1).GT.0) THEN
26698 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26699 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26700 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26701 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26702 ENDIF
26703 330 CONTINUE
26704
26705C...UED: kk state width decays : flav: 451 476
26706 ELSEIF(IUED(1).EQ.1.AND.
26707 & PYCOMP(ABS(KFLA)).GE.KKFLMI.AND.
26708 & PYCOMP(ABS(KFLA)).LE.KKFLMA) THEN
26709 KCLA=PYCOMP(KFLA)
26710C...q*_S,q*_D,l*_S,l*_D,gamma*,g*,Z*,W*
26711 RMFLAS=PMAS(KCLA,1)
26712 FACSH=SH/PMAS(KCLA,1)**2
26713 ALPHEM=PYALEM(RMFLAS**2)
26714 ALPHS=PYALPS(RMFLAS**2)
26715
26716C...uedcor parameters (alpha_s is calculated at mkk scale)
26717C...alpha_em is calculated at z pole !
26718 ALPHEM=PARU(101)
26719 FACSH=1.
26720
26721 DO 1070 I=1,MDCY(KCLA,3)
26722 IDC=I+MDCY(KCLA,2)-1
26723
26724 IF(MDME(IDC,1).LT.0) GOTO 1070
26725 KFC1=PYCOMP(ABS(KFDP(IDC,1)))
26726 KFC2=PYCOMP(ABS(KFDP(IDC,2)))
26727 RM1=PMAS(KFC1,1)**2/SH
26728 RM2=PMAS(KFC2,1)**2/SH
26729 IF(SQRT(RM1)+SQRT(RM2).GT.1D0)
26730 & GOTO 1070
26731 WID2=1D0
26732
26733C...N.B. RINV=RUED(1)
26734 RMKK=RUED(1)
26735 RMWKK=PMAS(475,1)
26736 RMZKK=PMAS(474,1)
26737 SW2=PARU(102)
26738 CW2=1.-SW2
26739 KKCLA=KCLA-KKFLMI+1
26740 IF(ABS(KFC1).GE.KKFLMI)KKPART=KFC1
26741 IF(ABS(KFC2).GE.KKFLMI)KKPART=KFC2
26742 IF(KKCLA.LE.6) THEN
26743C...q*_S -> q + gamma* (in first time sw21=0)
26744 FAC=0.25*ALPHEM*RMFLAS*0.5*CW21/CW2*KCHG(KCLA,1)**2/9.
26745C...Eventually change the following by enabling a choice of open or closed.
26746C...Only the gamma_kk channel is open.
26747 IF(MOD(I,2).EQ.0)
26748 + WDTP(I)=FAC*FKAC2(RMFLAS,RMKK)*FKAC1(RMKK,RMFLAS)**2
26749 WDTP(I)=FACSH*WDTP(I)
26750 WID2=WIDS(473,2)
26751 ELSEIF(KKCLA.GT.6.AND.KKCLA.LE.12)THEN
26752C...q*_D -> q + Z*/W*
26753 FAC=0.25*ALPHEM*RMFLAS/(4.*SW2)
26754 GAMMAW=FAC*FKAC2(RMFLAS,RMWKK)*FKAC1(RMWKK,RMFLAS)**2
26755 IF(I.EQ.1)THEN
26756C...q*_D -> q + Z*
26757 WDTP(I)=0.5*GAMMAW
26758 WID2=WIDS(474,2)
26759 ELSEIF(I.EQ.2)THEN
26760C...q*_D -> q + W*
26761 WDTP(I)=GAMMAW
26762 WID2=WIDS(475,2)
26763 ENDIF
26764 WDTP(I)=FACSH*WDTP(I)
26765C...q*_D -> q + gamma* is closed
26766 ELSEIF(KKCLA.GT.12.AND.KKCLA.LE.21)THEN
26767C...l*_S,l*_D -> gamma* + l*_S/l*_D(=nu_l,l)
26768 FAC=ALPHEM/4.*RMFLAS/CW2/8.
26769 RMGAKK=PMAS(473,1)
26770 WDTP(I)=FAC*FKAC2(RMFLAS,RMGAKK)*
26771 + FKAC1(RMGAKK,RMFLAS)**2
26772 WDTP(I)=FACSH*WDTP(I)
26773 WID2=WIDS(473,2)
26774 ELSEIF(KKCLA.EQ.22)THEN
26775 RMQST=PMAS(KKPART,1)
26776 WID2=WIDS(KKPART,2)
26777C...g* -> q*_S/q*_D + q
26778 FAC=10.*ALPHS/12.*RMFLAS
26779 WDTP(I)=FAC*FKAC1(RMQST,RMFLAS)**2*FKAC2(RMQST,RMFLAS)
26780 WDTP(I)=FACSH*WDTP(I)
26781 ELSEIF(KKCLA.EQ.23)THEN
26782C...gamma* decays to graviton + gamma : initial value is used
26783 ICHI=IUED(4)/2
26784 WDTP(I)=RMFLAS*(RMFLAS/RUED(2))**(IUED(4)+2)
26785 & *CHIDEL(ICHI)
26786 ELSEIF(KKCLA.EQ.24)THEN
26787C...Z* -> l*_S + l is closed
26788C... Z* -> l*_D + l
26789 IF(I.LE.3)GOTO 1070
26790c... After closing the channels for a Z* decaying into positively charged
26791C... KK lepton singlets, close the channels for a Z* decaying into negatively
26792C... charged KK lepton singlets + positively charged SM particles
26793 IF(I.GE.10.AND.I.LE.12)GOTO 1070
26794 FAC=3./2.*ALPHEM/24./SW2*RMZKK
26795 RMLST=PMAS(KKPART,1)
26796 WDTP(I)=FAC*FKAC1(RMLST,RMZKK)**2*FKAC2(RMLST,RMZKK)
26797 WDTP(I)=FACSH*WDTP(I)
26798 WID2=WIDS(KKPART,2)
26799 ELSEIF(KKCLA.EQ.25)THEN
26800C...W* -> l*_D lbar
26801 FAC=3.*ALPHEM/12./SW2*RMWKK
26802 RMLST=PMAS(KKPART,1)
26803 WDTP(I)=FAC*FKAC1(RMLST,RMWKK)**2*FKAC2(RMLST,RMWKK)
26804 WDTP(I)=FACSH*WDTP(I)
26805 WID2=WIDS(KKPART,2)
26806 ENDIF
26807 WDTP(0)=WDTP(0)+WDTP(I)
26808 IF(MDME(IDC,1).GT.0) THEN
26809 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26810 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26811 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26812 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26813 ENDIF
26814 1070 CONTINUE
26815 IUEDPR(KKCLA)=1
26816
26817 ELSEIF(KFLA.EQ.KTECHN+111.OR.KFLA.EQ.KTECHN+221) THEN
26818C...Techni-pi0 and techni-pi0':
26819 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26820 DO 340 I=1,MDCY(KC,3)
26821 IDC=I+MDCY(KC,2)-1
26822 IF(MDME(IDC,1).LT.0) GOTO 340
26823 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26824 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26825 RM1=PM1**2/SH
26826 RM2=PM2**2/SH
26827 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 340
26828 WID2=1D0
26829C...pi_tc -> g + g
26830 IF(I.EQ.8) THEN
26831 FACP=(AS/(4D0*PARU(1))*ITCM(1)/RTCM(1))**2
26832 & /(8D0*PARU(1))*SH*SHR
26833 IF(KFLA.EQ.KTECHN+111) THEN
26834 FACP=FACP*RTCM(9)
26835 ELSE
26836 FACP=FACP*RTCM(10)
26837 ENDIF
26838 WDTP(I)=FACP
26839 ELSE
26840C...pi_tc -> f + fbar.
26841 FCOF=1D0
26842 IKA=IABS(KFDP(IDC,1))
26843 IF(IKA.LT.10) FCOF=3D0*RADC
26844 HM1=PM1
26845 HM2=PM2
26846 IF(IKA.GE.4.AND.IKA.LE.6) THEN
26847 FCOF=FCOF*RTCM(1+IKA)**2
26848 HM1=PYMRUN(KFDP(IDC,1),SH)
26849 HM2=PYMRUN(KFDP(IDC,2),SH)
26850 ELSEIF(IKA.EQ.15) THEN
26851 FCOF=FCOF*RTCM(8)**2
26852 ENDIF
26853 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26854 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26855 ENDIF
26856 WDTP(I)=FUDGE*WDTP(I)
26857 WDTP(0)=WDTP(0)+WDTP(I)
26858 IF(MDME(IDC,1).GT.0) THEN
26859 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26860 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26861 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26862 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26863 ENDIF
26864 340 CONTINUE
26865
26866 ELSEIF(KFLA.EQ.KTECHN+211) THEN
26867C...pi+_tc
26868 FAC=(1D0/(32D0*PARU(1)*RTCM(1)**2))*SHR
26869 DO 350 I=1,MDCY(KC,3)
26870 IDC=I+MDCY(KC,2)-1
26871 IF(MDME(IDC,1).LT.0) GOTO 350
26872 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
26873 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
26874 PM3=0D0
26875 IF(I.EQ.5) PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
26876 RM1=PM1**2/SH
26877 RM2=PM2**2/SH
26878 RM3=PM3**2/SH
26879 IF(SQRT(RM1)+SQRT(RM2)+SQRT(RM3).GT.1D0) GOTO 350
26880 WID2=1D0
26881C...pi_tc -> f + f'.
26882 FCOF=1D0
26883 IF(IABS(KFDP(IDC,1)).LT.10) FCOF=3D0*RADC
26884C...pi_tc+ -> W b b~
26885 IF(I.EQ.5.AND.SHR.LT.PMAS(6,1)+PMAS(5,1)) THEN
26886 FCOF=3D0*RADC
26887 XMT2=PMAS(6,1)**2/SH
26888 FACP=FAC/(4D0*PARU(1))*FCOF*XMT2*RTCM(7)**2
26889 KFC3=PYCOMP(KFDP(IDC,3))
26890 CHECK = SQRT(RM1)+SQRT(RM2)+SQRT(RM3)
26891 CHECK = SQRT(RM1)
26892 T0 = (1D0-CHECK**2)*
26893 & (XMT2*(6D0*XMT2**2+3D0*XMT2*RM1-4D0*RM1**2)-
26894 & (5D0*XMT2**2+2D0*XMT2*RM1-8D0*RM1**2))/(4D0*XMT2**2)
26895 T1 = (1D0-XMT2)*(RM1-XMT2)*((XMT2**2+XMT2*RM1+4D0*RM1**2)
26896 & -3D0*XMT2**2*(XMT2+RM1))/(2D0*XMT2**3)
26897 T3 = RM1**2/XMT2**3*(3D0*XMT2-4D0*RM1+4D0*XMT2*RM1)
26898 WDTP(I)=FACP*(T0 + T1*LOG((XMT2-CHECK**2)/(XMT2-1D0))
26899 & +T3*LOG(CHECK))
26900 IF(KFLR.GT.0) THEN
26901 WID2=WIDS(24,2)
26902 ELSE
26903 WID2=WIDS(24,3)
26904 ENDIF
26905 ELSE
26906 FCOF=1D0
26907 IKA=IABS(KFDP(IDC,1))
26908 IF(IKA.LT.10) FCOF=3D0*RADC
26909 HM1=PM1
26910 HM2=PM2
26911 IF(I.GE.1.AND.I.LE.5) THEN
26912 IF(I.LE.2) THEN
26913 FCOF=FCOF*RTCM(5)**2
26914 ELSEIF(I.LE.4) THEN
26915 FCOF=FCOF*RTCM(6)**2
26916 ELSEIF(I.EQ.5) THEN
26917 FCOF=FCOF*RTCM(7)**2
26918 ENDIF
26919 HM1=PYMRUN(KFDP(IDC,1),SH)
26920 HM2=PYMRUN(KFDP(IDC,2),SH)
26921 ELSEIF(I.EQ.8) THEN
26922 FCOF=FCOF*RTCM(8)**2
26923 ENDIF
26924 WDTP(I)=FAC*FCOF*(HM1+HM2)**2*
26925 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
26926 ENDIF
26927 WDTP(I)=FUDGE*WDTP(I)
26928 WDTP(0)=WDTP(0)+WDTP(I)
26929 IF(MDME(IDC,1).GT.0) THEN
26930 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26931 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26932 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26933 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26934 ENDIF
26935 350 CONTINUE
26936
26937 ELSEIF(KFLA.EQ.KTECHN+331) THEN
26938C...Techni-eta.
26939 FAC=(SH/PARP(46)**2)*SHR
26940 DO 360 I=1,MDCY(KC,3)
26941 IDC=I+MDCY(KC,2)-1
26942 IF(MDME(IDC,1).LT.0) GOTO 360
26943 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26944 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26945 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 360
26946 WID2=1D0
26947 IF(I.LE.2) THEN
26948 WDTP(I)=FAC*RM1*SQRT(MAX(0D0,1D0-4D0*RM1))/(4D0*PARU(1))
26949 IF(I.EQ.2) WID2=WIDS(6,1)
26950 ELSE
26951 WDTP(I)=FAC*5D0*AS**2/(96D0*PARU(1)**3)
26952 ENDIF
26953 WDTP(I)=FUDGE*WDTP(I)
26954 WDTP(0)=WDTP(0)+WDTP(I)
26955 IF(MDME(IDC,1).GT.0) THEN
26956 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
26957 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
26958 WDTE(I,0)=WDTE(I,MDME(IDC,1))
26959 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
26960 ENDIF
26961 360 CONTINUE
26962
26963 ELSEIF(KFLA.EQ.KTECHN+113) THEN
26964C...Techni-rho0:
26965 ALPRHT=2.16D0*(3D0/ITCM(1))
26966 FAC=(ALPRHT/12D0)*SHR
26967 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
26968 SQMZ=PMAS(23,1)**2
26969 SQMW=PMAS(24,1)**2
26970 SHP=SH
26971 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
26972 GMMZ=SHR*WDTPP(0)
26973 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
26974 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
26975 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
26976 DO 370 I=1,MDCY(KC,3)
26977 IDC=I+MDCY(KC,2)-1
26978 IF(MDME(IDC,1).LT.0) GOTO 370
26979 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
26980 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
26981 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 370
26982 WID2=1D0
26983 IF(I.EQ.1) THEN
26984C...rho_tc0 -> W+ + W-.
26985C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
26986 WDTP(I)=FAC*RTCM(3)**4*
26987 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26988 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26989 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
26990 & RTCM(3)**2/4D0/XW/24D0/RTCM(13)**2*SHR**3
26991 WID2=WIDS(24,1)
26992 ELSEIF(I.EQ.2) THEN
26993C...rho_tc0 -> W+ + pi_tc-.
26994C... Multiplied by 2 for pi_T^+ W^-_T + pi_T^- W^+_T
26995 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
26996 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
26997 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
26998 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM1)*
26999 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
27000 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27001 ELSEIF(I.EQ.3) THEN
27002C...rho_tc0 -> pi_tc+ + W-.
27003 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
27004 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27005 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
27006 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*RM2)*
27007 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
27008 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(24,3)
27009 ELSEIF(I.EQ.4) THEN
27010C...rho_tc0 -> pi_tc+ + pi_tc-.
27011 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
27012 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27013 WID2=WIDS(PYCOMP(KTECHN+211),1)
27014 ELSEIF(I.EQ.5) THEN
27015C...rho_tc0 -> gamma + pi_tc0
27016 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27017 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27018 & SHR**3
27019 WID2=WIDS(PYCOMP(KTECHN+111),2)
27020 ELSEIF(I.EQ.6) THEN
27021C...rho_tc0 -> gamma + pi_tc0'
27022 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27023 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*SHR**3
27024 WID2=WIDS(PYCOMP(KTECHN+221),2)
27025 ELSEIF(I.EQ.7) THEN
27026C...rho_tc0 -> Z0 + pi_tc0
27027 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27028 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27029 & XW/XW1*SHR**3
27030 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
27031 ELSEIF(I.EQ.8) THEN
27032C...rho_tc0 -> Z0 + pi_tc0'
27033 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27034 & (1D0-RTCM(4)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
27035 & XW/XW1*SHR**3
27036 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27037 ELSEIF(I.EQ.9) THEN
27038C...rho_tc0 -> gamma + Z0
27039 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27040 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
27041 WID2=WIDS(23,2)
27042 ELSEIF(I.EQ.10) THEN
27043C...rho_tc0 -> Z0 + Z0
27044 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27045 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2*XW/XW1/24D0/RTCM(12)**2*
27046 & SHR**3
27047 WID2=WIDS(23,1)
27048 ELSE
27049C...rho_tc0 -> f + fbar.
27050 WID2=1D0
27051 IF(I.LE.18) THEN
27052 IA=I-10
27053 FCOF=3D0*RADC
27054 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27055 ELSE
27056 IA=I-6
27057 FCOF=1D0
27058 IF(IA.GE.17) WID2=WIDS(IA,1)
27059 ENDIF
27060 EI=KCHG(IA,1)/3D0
27061 AI=SIGN(1D0,EI+0.1D0)
27062 VI=AI-4D0*EI*XWV
27063 VALI=0.5D0*(VI+AI)
27064 VARI=0.5D0*(VI-AI)
27065 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27066 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
27067 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27068 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
27069 ENDIF
27070 WDTP(I)=FUDGE*WDTP(I)
27071 WDTP(0)=WDTP(0)+WDTP(I)
27072 IF(MDME(IDC,1).GT.0) THEN
27073 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27074 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27075 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27076 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27077 ENDIF
27078 370 CONTINUE
27079
27080 ELSEIF(KFLA.EQ.KTECHN+213) THEN
27081C...Techni-rho+/-:
27082 ALPRHT=2.16D0*(3D0/ITCM(1))
27083 FAC=(ALPRHT/12D0)*SHR
27084 SQMZ=PMAS(23,1)**2
27085 SQMW=PMAS(24,1)**2
27086 SHP=SH
27087 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
27088 GMMW=SHR*WDTPP(0)
27089 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
27090 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
27091 DO 380 I=1,MDCY(KC,3)
27092 IDC=I+MDCY(KC,2)-1
27093 IF(MDME(IDC,1).LT.0) GOTO 380
27094 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27095 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27096 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 380
27097 WID2=1D0
27098 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27099c WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27100c & /3D0*SHR**3
27101 IF(I.EQ.1) THEN
27102C...rho_tc+ -> W+ + Z0.
27103C......Goldstone
27104 WDTP(I)=FAC*RTCM(3)**4*
27105 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27106 VA2=RTCM(3)**2*(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(12)**2
27107 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW/XW1
27108C......W_L Z_T
27109 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM2)+PCM**2*VA2)
27110 & /3D0*SHR**3
27111 VA2=0D0
27112 AA2=RTCM(3)**2/RTCM(13)**2/4D0/XW
27113C......W_T Z_L
27114 WDTP(I)=WDTP(I)+AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
27115 & /3D0*SHR**3
27116 IF(KFLR.GT.0) THEN
27117 WID2=WIDS(24,2)*WIDS(23,2)
27118 ELSE
27119 WID2=WIDS(24,3)*WIDS(23,2)
27120 ENDIF
27121 ELSEIF(I.EQ.2) THEN
27122C...rho_tc+ -> W+ + pi_tc0.
27123 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
27124 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27125 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
27126 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMW/SH)*
27127 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(13)**2*SHR**3
27128 IF(KFLR.GT.0) THEN
27129 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+111),2)
27130 ELSE
27131 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+111),2)
27132 ENDIF
27133 ELSEIF(I.EQ.3) THEN
27134C...rho_tc+ -> pi_tc+ + Z0.
27135 WDTP(I)=FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*
27136 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27137 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))*
27138 & ((1D0-RM1-RM2)**2-4D0*RM1*RM2 + 6D0*SQMZ/SH)*
27139 & (1D0-RTCM(3)**2)/4D0/XW/XW1/24D0/RTCM(13)**2*SHR**3+
27140 & AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27141 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27142 & SHR**3*XW/XW1
27143 IF(KFLR.GT.0) THEN
27144 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(23,2)
27145 ELSE
27146 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(23,2)
27147 ENDIF
27148 ELSEIF(I.EQ.4) THEN
27149C...rho_tc+ -> pi_tc+ + pi_tc0.
27150 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*
27151 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27152 IF(KFLR.GT.0) THEN
27153 WID2=WIDS(PYCOMP(KTECHN+211),2)*WIDS(PYCOMP(KTECHN+111),2)
27154 ELSE
27155 WID2=WIDS(PYCOMP(KTECHN+211),3)*WIDS(PYCOMP(KTECHN+111),2)
27156 ENDIF
27157 ELSEIF(I.EQ.5) THEN
27158C...rho_tc+ -> pi_tc+ + gamma
27159 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27160 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(3)**2)/24D0/RTCM(12)**2*
27161 & SHR**3
27162 IF(KFLR.GT.0) THEN
27163 WID2=WIDS(PYCOMP(KTECHN+211),2)
27164 ELSE
27165 WID2=WIDS(PYCOMP(KTECHN+211),3)
27166 ENDIF
27167 ELSEIF(I.EQ.6) THEN
27168C...rho_tc+ -> W+ + pi_tc0'
27169 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27170 & (1D0-RTCM(4)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3
27171 IF(KFLR.GT.0) THEN
27172 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+221),2)
27173 ELSE
27174 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+221),2)
27175 ENDIF
27176 ELSEIF(I.EQ.7) THEN
27177C...rho_tc+ -> W+ + gamma
27178 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27179 & (2D0*RTCM(2)-1D0)**2*RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
27180 IF(KFLR.GT.0) THEN
27181 WID2=WIDS(24,2)
27182 ELSE
27183 WID2=WIDS(24,3)
27184 ENDIF
27185 ELSE
27186C...rho_tc+ -> f + fbar'.
27187 IA=I-7
27188 WID2=1D0
27189 IF(IA.LE.16) THEN
27190 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
27191 IF(KFLR.GT.0) THEN
27192 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
27193 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
27194 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
27195 ELSE
27196 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
27197 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
27198 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
27199 ENDIF
27200 ELSE
27201 FCOF=1D0
27202 IF(KFLR.GT.0) THEN
27203 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
27204 ELSE
27205 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
27206 ENDIF
27207 ENDIF
27208 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27209 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27210 ENDIF
27211 WDTP(I)=FUDGE*WDTP(I)
27212 WDTP(0)=WDTP(0)+WDTP(I)
27213 IF(MDME(IDC,1).GT.0) THEN
27214 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27215 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27216 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27217 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27218 ENDIF
27219 380 CONTINUE
27220
27221 ELSEIF(KFLA.EQ.KTECHN+223) THEN
27222C...Techni-omega:
27223 ALPRHT=2.16D0*(3D0/ITCM(1))
27224 FAC=(ALPRHT/12D0)*SHR
27225 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR*(2D0*RTCM(2)-1D0)**2
27226 SQMZ=PMAS(23,1)**2
27227 SHP=SH
27228 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
27229 GMMZ=SHR*WDTPP(0)
27230 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
27231 BWZI=-(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
27232 DO 390 I=1,MDCY(KC,3)
27233 IDC=I+MDCY(KC,2)-1
27234 IF(MDME(IDC,1).LT.0) GOTO 390
27235 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27236 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27237 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 390
27238 WID2=1D0
27239 IF(I.EQ.1) THEN
27240C...omega_tc0 -> gamma + pi_tc0.
27241 WDTP(I)=AEM/24D0/RTCM(12)**2*(1D0-RTCM(3)**2)*
27242 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*SHR**3
27243 WID2=WIDS(PYCOMP(KTECHN+111),2)
27244 ELSEIF(I.EQ.2) THEN
27245C...omega_tc0 -> Z0 + pi_tc0
27246 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27247 & (1D0-RTCM(3)**2)/24D0/RTCM(12)**2*(1D0-2D0*XW)**2/4D0/
27248 & XW/XW1*SHR**3
27249 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+111),2)
27250 ELSEIF(I.EQ.3) THEN
27251C...omega_tc0 -> gamma + pi_tc0'
27252 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27253 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
27254 & SHR**3
27255 WID2=WIDS(PYCOMP(KTECHN+221),2)
27256 ELSEIF(I.EQ.4) THEN
27257C...omega_tc0 -> Z0 + pi_tc0'
27258 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27259 & (2D0*RTCM(2)-1D0)**2*(1D0-RTCM(4)**2)/24D0/RTCM(12)**2*
27260 & XW/XW1*SHR**3
27261 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27262 ELSEIF(I.EQ.5) THEN
27263C...omega_tc0 -> W+ + pi_tc-
27264 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27265 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
27266 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
27267 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27268 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27269 ELSEIF(I.EQ.6) THEN
27270C...omega_tc0 -> pi_tc+ + W-
27271 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27272 & (1D0-RTCM(3)**2)/4D0/XW/24D0/RTCM(12)**2*SHR**3+
27273 & FAC*RTCM(3)**2*(1D0-RTCM(3)**2)*RTCM(11)**2*
27274 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27275 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
27276 ELSEIF(I.EQ.7) THEN
27277C...omega_tc0 -> W+ + W-.
27278C... Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T
27279 WDTP(I)=FAC*RTCM(3)**4*RTCM(11)**2*
27280 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3+
27281 & 2D0*AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27282 & RTCM(3)**2/4D0/XW/24D0/RTCM(12)**2*SHR**3
27283 WID2=WIDS(24,1)
27284 ELSEIF(I.EQ.8) THEN
27285C...omega_tc0 -> pi_tc+ + pi_tc-.
27286 WDTP(I)=FAC*(1D0-RTCM(3)**2)**2*RTCM(11)**2*
27287 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3
27288 WID2=WIDS(PYCOMP(KTECHN+211),1)
27289C...omega_tc0 -> gamma + Z0
27290 ELSEIF(I.EQ.9) THEN
27291 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27292 & RTCM(3)**2/24D0/RTCM(12)**2*SHR**3
27293 WID2=WIDS(23,2)
27294C...omega_tc0 -> Z0 + Z0
27295 ELSEIF(I.EQ.10) THEN
27296 WDTP(I)=AEM*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))**3*
27297 & RTCM(3)**2*(XW1-XW)**2/XW/XW1/4D0
27298 & /24D0/RTCM(12)**2*SHR**3
27299 WID2=WIDS(23,1)
27300 ELSE
27301C...omega_tc0 -> f + fbar.
27302 WID2=1D0
27303 IF(I.LE.18) THEN
27304 IA=I-10
27305 FCOF=3D0*RADC
27306 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27307 ELSE
27308 IA=I-8
27309 FCOF=1D0
27310 IF(IA.GE.17) WID2=WIDS(IA,1)
27311 ENDIF
27312 EI=KCHG(IA,1)/3D0
27313 AI=SIGN(1D0,EI+0.1D0)
27314 VI=AI-4D0*EI*XWV
27315 VALI=-0.5D0*(VI+AI)
27316 VARI=-0.5D0*(VI-AI)
27317 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27318 & ((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
27319 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27320 & (EI+VALI*BWZR)*(EI+VARI*BWZR)+VALI*VARI*BWZI**2))
27321 ENDIF
27322 WDTP(I)=FUDGE*WDTP(I)
27323 WDTP(0)=WDTP(0)+WDTP(I)
27324 IF(MDME(IDC,1).GT.0) THEN
27325 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27326 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27327 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27328 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27329 ENDIF
27330 390 CONTINUE
27331
27332C.....V8 -> quark anti-quark
27333 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
27334 FAC=AS/6D0*SHR
27335 TANT3=RTCM(21)
27336 IF(ITCM(2).EQ.0) THEN
27337 IMDL=1
27338 ELSEIF(ITCM(2).EQ.1) THEN
27339 IMDL=2
27340 ENDIF
27341 DO 400 I=1,MDCY(KC,3)
27342 IDC=I+MDCY(KC,2)-1
27343 IF(MDME(IDC,1).LT.0) GOTO 400
27344 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
27345 RM1=PM1**2/SH
27346 IF(RM1.GT.0.25D0) GOTO 400
27347 WID2=1D0
27348 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
27349 FMIX=1D0/TANT3**2
27350 ELSE
27351 FMIX=TANT3**2
27352 ENDIF
27353 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
27354 IF(I.EQ.6) WID2=WIDS(6,1)
27355 WDTP(I)=FUDGE*WDTP(I)
27356 WDTP(0)=WDTP(0)+WDTP(I)
27357 IF(MDME(IDC,1).GT.0) THEN
27358 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27359 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27360 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27361 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27362 ENDIF
27363 400 CONTINUE
27364
27365 ELSEIF(KFLA.EQ.KTECHN+100111.OR.KFLA.EQ.KTECHN+200111) THEN
27366 FAC=(1D0/(4D0*PARU(1)*RTCM(1)**2))*SHR
27367 CLEBF=0D0
27368 DO 410 I=1,MDCY(KC,3)
27369 IDC=I+MDCY(KC,2)-1
27370 IF(MDME(IDC,1).LT.0) GOTO 410
27371 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27372 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27373 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 410
27374 WID2=1D0
27375C...pi_tc -> g + g
27376 IF(I.EQ.7) THEN
27377 IF(KFLA.EQ.KTECHN+100111) THEN
27378 CLEBG=4D0/3D0
27379 ELSE
27380 CLEBG=5D0/3D0
27381 ENDIF
27382 FACP=(AS/(8D0*PARU(1))*ITCM(1)/RTCM(1))**2
27383 & /(2D0*PARU(1))*SH*SHR*CLEBG
27384 WDTP(I)=FACP
27385 ELSE
27386C...pi_tc -> f + fbar.
27387 IF(I.EQ.6) WID2=WIDS(6,1)
27388 FCOF=1D0
27389 IKA=IABS(KFDP(IDC,1))
27390 IF(IKA.LT.10) FCOF=3D0*RADC
27391 HM1=PYMRUN(KFDP(IDC,1),SH)
27392 WDTP(I)=FAC*FCOF*HM1**2*CLEBF*
27393 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27394 ENDIF
27395 WDTP(I)=FUDGE*WDTP(I)
27396 WDTP(0)=WDTP(0)+WDTP(I)
27397 IF(MDME(IDC,1).GT.0) THEN
27398 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27399 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27400 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27401 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27402 ENDIF
27403 410 CONTINUE
27404
27405 ELSEIF(KFLA.GE.KTECHN+100113.AND.KFLA.LE.KTECHN+400113) THEN
27406 FAC=AS/6D0*SHR
27407 ALPRHT=2.16D0*(3D0/ITCM(1))
27408 TANT3=RTCM(21)
27409 SIN2T=2D0*TANT3/(TANT3**2+1D0)
27410 SINT3=TANT3/SQRT(TANT3**2+1D0)
27411 CSXPP=RTCM(22)
27412 RM82=RTCM(27)**2
27413 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
27414 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)
27415 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
27416 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)
27417 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
27418 & SINT3**2)*2D0
27419 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
27420 & SINT3**2)*2D0
27421 CALL PYWIDX(KTECHN+100021,SH,WDTPP,WDTEP)
27422
27423 IF(WDTPP(0).GT.RTCM(33)*SHR) WDTPP(0)=RTCM(33)*SHR
27424 GMV8=SHR*WDTPP(0)
27425 RMV8=PMAS(PYCOMP(KTECHN+100021),1)
27426 FV8RE=SH*(SH-RMV8**2)/((SH-RMV8**2)**2+GMV8**2)
27427 FV8IM=SH*GMV8/((SH-RMV8**2)**2+GMV8**2)
27428 IF(ITCM(2).EQ.0) THEN
27429 IMDL=1
27430 ELSE
27431 IMDL=2
27432 ENDIF
27433 DO 420 I=1,MDCY(KC,3)
27434 IF(I.EQ.7.AND.(KFLA.EQ.KTECHN+200113.OR.
27435 & KFLA.EQ.KTECHN+300113)) GOTO 420
27436 IDC=I+MDCY(KC,2)-1
27437 IF(MDME(IDC,1).LT.0) GOTO 420
27438 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27439 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27440 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 420
27441 WID2=1D0
27442 IF(I.LE.6) THEN
27443 IF(I.EQ.6) WID2=WIDS(6,1)
27444 XIG=1D0
27445 IF(KFLA.EQ.KTECHN+200113) THEN
27446 XIG=0D0
27447 XIJ=X12
27448 ELSEIF(KFLA.EQ.KTECHN+300113) THEN
27449 XIG=0D0
27450 XIJ=X21
27451 ELSEIF(KFLA.EQ.KTECHN+100113) THEN
27452 XIJ=X11
27453 ELSE
27454 XIJ=X22
27455 ENDIF
27456 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
27457 FMIX=1D0/TANT3/SIN2T
27458 ELSE
27459 FMIX=-TANT3/SIN2T
27460 ENDIF
27461 XFAC=(XIG+FMIX*XIJ*FV8RE)**2+(FMIX*XIJ*FV8IM)**2
27462 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*AS/ALPRHT*XFAC
27463 ELSEIF(I.EQ.7) THEN
27464 WDTP(I)=SHR*AS**2/(4D0*ALPRHT)
27465 ELSEIF(KFLA.EQ.KTECHN+400113.AND.I.LE.9) THEN
27466 PSH=SHR*(1D0-RM1)/2D0
27467 WDTP(I)=AS/9D0*PSH**3/RM82
27468 IF(I.EQ.8) THEN
27469 WDTP(I)=2D0*WDTP(I)*CSXPP**2
27470 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
27471 ELSE
27472 WDTP(I)=5D0*WDTP(I)
27473 WID2=WIDS(PYCOMP(KFDP(IDC,1)),2)
27474 ENDIF
27475 ENDIF
27476 WDTP(I)=FUDGE*WDTP(I)
27477 WDTP(0)=WDTP(0)+WDTP(I)
27478 IF(MDME(IDC,1).GT.0) THEN
27479 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27480 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27481 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27482 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27483 ENDIF
27484 420 CONTINUE
27485
27486 ELSEIF(KFLA.EQ.KEXCIT+1) THEN
27487C...d* excited quark.
27488 FAC=(SH/RTCM(41)**2)*SHR
27489 DO 430 I=1,MDCY(KC,3)
27490 IDC=I+MDCY(KC,2)-1
27491 IF(MDME(IDC,1).LT.0) GOTO 430
27492 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27493 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27494 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 430
27495 WID2=1D0
27496 IF(I.EQ.1) THEN
27497C...d* -> g + d.
27498 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
27499 WID2=1D0
27500 ELSEIF(I.EQ.2) THEN
27501C...d* -> gamma + d.
27502 QF=-RTCM(43)/2D0+RTCM(44)/6D0
27503 WDTP(I)=FAC*AEM*QF**2/4D0
27504 WID2=1D0
27505 ELSEIF(I.EQ.3) THEN
27506C...d* -> Z0 + d.
27507 QF=-RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
27508 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27509 & (1D0-RM1)**2*(2D0+RM1)
27510 WID2=WIDS(23,2)
27511 ELSEIF(I.EQ.4) THEN
27512C...d* -> W- + u.
27513 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27514 & (1D0-RM1)**2*(2D0+RM1)
27515 IF(KFLR.GT.0) WID2=WIDS(24,3)
27516 IF(KFLR.LT.0) WID2=WIDS(24,2)
27517 ENDIF
27518 WDTP(I)=FUDGE*WDTP(I)
27519 WDTP(0)=WDTP(0)+WDTP(I)
27520 IF(MDME(IDC,1).GT.0) THEN
27521 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27522 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27523 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27524 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27525 ENDIF
27526 430 CONTINUE
27527
27528 ELSEIF(KFLA.EQ.KEXCIT+2) THEN
27529C...u* excited quark.
27530 FAC=(SH/RTCM(41)**2)*SHR
27531 DO 440 I=1,MDCY(KC,3)
27532 IDC=I+MDCY(KC,2)-1
27533 IF(MDME(IDC,1).LT.0) GOTO 440
27534 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27535 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27536 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 440
27537 WID2=1D0
27538 IF(I.EQ.1) THEN
27539C...u* -> g + u.
27540 WDTP(I)=FAC*AS*RTCM(45)**2/3D0
27541 WID2=1D0
27542 ELSEIF(I.EQ.2) THEN
27543C...u* -> gamma + u.
27544 QF=RTCM(43)/2D0+RTCM(44)/6D0
27545 WDTP(I)=FAC*AEM*QF**2/4D0
27546 WID2=1D0
27547 ELSEIF(I.EQ.3) THEN
27548C...u* -> Z0 + u.
27549 QF=RTCM(43)*XW1/2D0-RTCM(44)*XW/6D0
27550 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27551 & (1D0-RM1)**2*(2D0+RM1)
27552 WID2=WIDS(23,2)
27553 ELSEIF(I.EQ.4) THEN
27554C...u* -> W+ + d.
27555 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27556 & (1D0-RM1)**2*(2D0+RM1)
27557 IF(KFLR.GT.0) WID2=WIDS(24,2)
27558 IF(KFLR.LT.0) WID2=WIDS(24,3)
27559 ENDIF
27560 WDTP(I)=FUDGE*WDTP(I)
27561 WDTP(0)=WDTP(0)+WDTP(I)
27562 IF(MDME(IDC,1).GT.0) THEN
27563 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27564 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27565 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27566 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27567 ENDIF
27568 440 CONTINUE
27569
27570 ELSEIF(KFLA.EQ.KEXCIT+11) THEN
27571C...e* excited lepton.
27572 FAC=(SH/RTCM(41)**2)*SHR
27573 DO 450 I=1,MDCY(KC,3)
27574 IDC=I+MDCY(KC,2)-1
27575 IF(MDME(IDC,1).LT.0) GOTO 450
27576 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27577 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27578 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 450
27579 WID2=1D0
27580 IF(I.EQ.1) THEN
27581C...e* -> gamma + e.
27582 QF=-RTCM(43)/2D0-RTCM(44)/2D0
27583 WDTP(I)=FAC*AEM*QF**2/4D0
27584 WID2=1D0
27585 ELSEIF(I.EQ.2) THEN
27586C...e* -> Z0 + e.
27587 QF=-RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
27588 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27589 & (1D0-RM1)**2*(2D0+RM1)
27590 WID2=WIDS(23,2)
27591 ELSEIF(I.EQ.3) THEN
27592C...e* -> W- + nu.
27593 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27594 & (1D0-RM1)**2*(2D0+RM1)
27595 IF(KFLR.GT.0) WID2=WIDS(24,3)
27596 IF(KFLR.LT.0) WID2=WIDS(24,2)
27597 ENDIF
27598 WDTP(I)=FUDGE*WDTP(I)
27599 WDTP(0)=WDTP(0)+WDTP(I)
27600 IF(MDME(IDC,1).GT.0) THEN
27601 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27602 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27603 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27604 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27605 ENDIF
27606 450 CONTINUE
27607
27608 ELSEIF(KFLA.EQ.KEXCIT+12) THEN
27609C...nu*_e excited neutrino.
27610 FAC=(SH/RTCM(41)**2)*SHR
27611 DO 460 I=1,MDCY(KC,3)
27612 IDC=I+MDCY(KC,2)-1
27613 IF(MDME(IDC,1).LT.0) GOTO 460
27614 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27615 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27616 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 460
27617 WID2=1D0
27618 IF(I.EQ.1) THEN
27619C...nu*_e -> Z0 + nu*_e.
27620 QF=RTCM(43)*XW1/2D0+RTCM(44)*XW/2D0
27621 WDTP(I)=FAC*AEM*QF**2/(8D0*XW*XW1)*
27622 & (1D0-RM1)**2*(2D0+RM1)
27623 WID2=WIDS(23,2)
27624 ELSEIF(I.EQ.2) THEN
27625C...nu*_e -> W+ + e.
27626 WDTP(I)=FAC*AEM*RTCM(43)**2/(16D0*XW)*
27627 & (1D0-RM1)**2*(2D0+RM1)
27628 IF(KFLR.GT.0) WID2=WIDS(24,2)
27629 IF(KFLR.LT.0) WID2=WIDS(24,3)
27630 ENDIF
27631 WDTP(I)=FUDGE*WDTP(I)
27632 WDTP(0)=WDTP(0)+WDTP(I)
27633 IF(MDME(IDC,1).GT.0) THEN
27634 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27635 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27636 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27637 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27638 ENDIF
27639 460 CONTINUE
27640
27641 ELSEIF(KFLA.EQ.KDIMEN+39) THEN
27642C...G* (graviton resonance):
27643 FAC=(PARP(50)**2/PARU(1))*SHR
27644 DO 470 I=1,MDCY(KC,3)
27645 IDC=I+MDCY(KC,2)-1
27646 IF(MDME(IDC,1).LT.0) GOTO 470
27647 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27648 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27649 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 470
27650 WID2=1D0
27651 IF(I.LE.8) THEN
27652C...G* -> q + qbar
27653 FCOF=3D0*RADC
27654 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*
27655 & PYHFTH(SH,SH*RM1,1D0)
27656 WDTP(I)=FAC*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27657 & (1D0+8D0*RM1/3D0)/320D0
27658 IF(I.EQ.6) WID2=WIDS(6,1)
27659 IF(I.EQ.7.OR.I.EQ.8) WID2=WIDS(I,1)
27660 ELSEIF(I.LE.16) THEN
27661C...G* -> l+ + l-, nu + nubar
27662 FCOF=1D0
27663 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))**3*
27664 & (1D0+8D0*RM1/3D0)/320D0
27665 IF(I.EQ.15.OR.I.EQ.16) WID2=WIDS(2+I,1)
27666 ELSEIF(I.EQ.17) THEN
27667C...G* -> g + g.
27668 WDTP(I)=FAC/20D0
27669 ELSEIF(I.EQ.18) THEN
27670C...G* -> gamma + gamma.
27671 WDTP(I)=FAC/160D0
27672 ELSEIF(I.EQ.19) THEN
27673C...G* -> Z0 + Z0.
27674 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27675 & 14D0*RM1/3D0+4D0*RM1**2)/160D0
27676 WID2=WIDS(23,1)
27677 ELSEIF(I.EQ.20) THEN
27678C...G* -> W+ + W-.
27679 WDTP(I)=FAC*SQRT(MAX(0D0,1D0-4D0*RM1))*(13D0/12D0+
27680 & 14D0*RM1/3D0+4D0*RM1**2)/80D0
27681 WID2=WIDS(24,1)
27682 ENDIF
27683 WDTP(I)=FUDGE*WDTP(I)
27684 WDTP(0)=WDTP(0)+WDTP(I)
27685 IF(MDME(IDC,1).GT.0) THEN
27686 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27687 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27688 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27689 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27690 ENDIF
27691 470 CONTINUE
27692
27693 ELSEIF(KFLA.EQ.9900012.OR.KFLA.EQ.9900014.OR.KFLA.EQ.9900016) THEN
27694C...nu_eR, nu_muR, nu_tauR: righthanded Majorana neutrinos.
27695 PMWR=MAX(1.001D0*SHR,PMAS(PYCOMP(9900024),1))
27696 FAC=(AEM**2/(768D0*PARU(1)*XW**2))*SHR**5/PMWR**4
27697 DO 480 I=1,MDCY(KC,3)
27698 IDC=I+MDCY(KC,2)-1
27699 IF(MDME(IDC,1).LT.0) GOTO 480
27700 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
27701 PM2=PMAS(PYCOMP(KFDP(IDC,2)),1)
27702 PM3=PMAS(PYCOMP(KFDP(IDC,3)),1)
27703 IF(PM1+PM2+PM3.GE.SHR) GOTO 480
27704 WID2=1D0
27705 IF(I.LE.9) THEN
27706C...nu_lR -> l- qbar q'
27707 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27708 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27709 ELSEIF(I.LE.18) THEN
27710C...nu_lR -> l+ q qbar'
27711 FCOF=3D0*RADC*VCKM((I-10)/3+1,MOD(I-10,3)+1)
27712 IF(MOD(I-9,3).EQ.0) WID2=WIDS(6,3)
27713 ELSE
27714C...nu_lR -> l- l'+ nu_lR' + charge conjugate.
27715 FCOF=1D0
27716 WID2=WIDS(PYCOMP(KFDP(IDC,3)),2)
27717 ENDIF
27718 X=(PM1+PM2+PM3)/SHR
27719 FX=1D0-8D0*X**2+8D0*X**6-X**8-24D0*X**4*LOG(X)
27720 Y=(SHR/PMWR)**2
27721 FY=(12D0*(1D0-Y)*LOG(1D0-Y)+12D0*Y-6D0*Y**2-2D0*Y**3)/Y**4
27722 WDTP(I)=FAC*FCOF*FX*FY
27723 WDTP(I)=FUDGE*WDTP(I)
27724 WDTP(0)=WDTP(0)+WDTP(I)
27725 IF(MDME(IDC,1).GT.0) THEN
27726 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27727 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27728 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27729 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27730 ENDIF
27731 480 CONTINUE
27732
27733 ELSEIF(KFLA.EQ.9900023) THEN
27734C...Z_R0:
27735 FAC=(AEM/(48D0*XW*XW1*(1D0-2D0*XW)))*SHR
27736 DO 490 I=1,MDCY(KC,3)
27737 IDC=I+MDCY(KC,2)-1
27738 IF(MDME(IDC,1).LT.0) GOTO 490
27739 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27740 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27741 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 490
27742 WID2=1D0
27743 SYMMET=1D0
27744 IF(I.LE.6) THEN
27745C...Z_R0 -> q + qbar
27746 EF=KCHG(I,1)/3D0
27747 AF=SIGN(1D0,EF+0.1D0)*(1D0-2D0*XW)
27748 VF=SIGN(1D0,EF+0.1D0)-4D0*EF*XW
27749 FCOF=3D0*RADC
27750 IF(I.EQ.6) WID2=WIDS(6,1)
27751 ELSEIF(I.EQ.7.OR.I.EQ.10.OR.I.EQ.13) THEN
27752C...Z_R0 -> l+ + l-
27753 AF=-(1D0-2D0*XW)
27754 VF=-1D0+4D0*XW
27755 FCOF=1D0
27756 ELSEIF(I.EQ.8.OR.I.EQ.11.OR.I.EQ.14) THEN
27757C...Z0 -> nu_L + nu_Lbar, assumed Majorana.
27758 AF=-2D0*XW
27759 VF=0D0
27760 FCOF=1D0
27761 SYMMET=0.5D0
27762 ELSEIF(I.LE.15) THEN
27763C...Z0 -> nu_R + nu_R, assumed Majorana.
27764 AF=2D0*XW1
27765 VF=0D0
27766 FCOF=1D0
27767 WID2=WIDS(PYCOMP(KFDP(IDC,1)),1)
27768 SYMMET=0.5D0
27769 ENDIF
27770 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
27771 & SQRT(MAX(0D0,1D0-4D0*RM1))*SYMMET
27772 WDTP(I)=FUDGE*WDTP(I)
27773 WDTP(0)=WDTP(0)+WDTP(I)
27774 IF(MDME(IDC,1).GT.0) THEN
27775 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27776 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27777 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27778 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27779 ENDIF
27780 490 CONTINUE
27781
27782 ELSEIF(KFLA.EQ.9900024) THEN
27783C...W_R+/-:
27784 FAC=(AEM/(24D0*XW))*SHR
27785 DO 500 I=1,MDCY(KC,3)
27786 IDC=I+MDCY(KC,2)-1
27787 IF(MDME(IDC,1).LT.0) GOTO 500
27788 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27789 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27790 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 500
27791 WID2=1D0
27792 IF(I.LE.9) THEN
27793C...W_R+/- -> q + qbar'
27794 FCOF=3D0*RADC*VCKM((I-1)/3+1,MOD(I-1,3)+1)
27795 IF(KFLR.GT.0) THEN
27796 IF(MOD(I,3).EQ.0) WID2=WIDS(6,2)
27797 ELSE
27798 IF(MOD(I,3).EQ.0) WID2=WIDS(6,3)
27799 ENDIF
27800 ELSEIF(I.LE.12) THEN
27801C...W_R+/- -> l+/- + nu_R
27802 FCOF=1D0
27803 ENDIF
27804 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
27805 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27806 WDTP(I)=FUDGE*WDTP(I)
27807 WDTP(0)=WDTP(0)+WDTP(I)
27808 IF(MDME(IDC,1).GT.0) THEN
27809 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27810 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27811 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27812 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27813 ENDIF
27814 500 CONTINUE
27815
27816 ELSEIF(KFLA.EQ.9900041) THEN
27817C...H_L++/--:
27818 FAC=(1D0/(8D0*PARU(1)))*SHR
27819 DO 510 I=1,MDCY(KC,3)
27820 IDC=I+MDCY(KC,2)-1
27821 IF(MDME(IDC,1).LT.0) GOTO 510
27822 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27823 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27824 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 510
27825 WID2=1D0
27826 IF(I.LE.6) THEN
27827C...H_L++/-- -> l+/- + l'+/-
27828 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27829 & (IABS(KFDP(IDC,2))-9)/2)**2
27830 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27831 ELSEIF(I.EQ.7) THEN
27832C...H_L++/-- -> W_L+/- + W_L+/-
27833 FCOF=0.5D0*PARP(190)**4*PARP(192)**2/PMAS(24,1)**2*
27834 & (3D0*RM1+0.25D0/RM1-1D0)
27835 WID2=WIDS(24,4+(1-KFLS)/2)
27836 ENDIF
27837 WDTP(I)=FAC*FCOF*
27838 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27839 WDTP(I)=FUDGE*WDTP(I)
27840 WDTP(0)=WDTP(0)+WDTP(I)
27841 IF(MDME(IDC,1).GT.0) THEN
27842 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27843 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27844 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27845 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27846 ENDIF
27847 510 CONTINUE
27848
27849 ELSEIF(KFLA.EQ.9900042) THEN
27850C...H_R++/--:
27851 FAC=(1D0/(8D0*PARU(1)))*SHR
27852 DO 520 I=1,MDCY(KC,3)
27853 IDC=I+MDCY(KC,2)-1
27854 IF(MDME(IDC,1).LT.0) GOTO 520
27855 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27856 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27857 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 520
27858 WID2=1D0
27859 IF(I.LE.6) THEN
27860C...H_R++/-- -> l+/- + l'+/-
27861 FCOF=PARP(180+3*((IABS(KFDP(IDC,1))-11)/2)+
27862 & (IABS(KFDP(IDC,2))-9)/2)**2
27863 IF(KFDP(IDC,1).NE.KFDP(IDC,2)) FCOF=2D0*FCOF
27864 ELSEIF(I.EQ.7) THEN
27865C...H_R++/-- -> W_R+/- + W_R+/-
27866 FCOF=PARP(191)**2*(3D0*RM1+0.25D0/RM1-1D0)
27867 WID2=WIDS(PYCOMP(9900024),4+(1-KFLS)/2)
27868 ENDIF
27869 WDTP(I)=FAC*FCOF*
27870 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27871 WDTP(I)=FUDGE*WDTP(I)
27872 WDTP(0)=WDTP(0)+WDTP(I)
27873 IF(MDME(IDC,1).GT.0) THEN
27874 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27875 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27876 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27877 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27878 ENDIF
27879 520 CONTINUE
27880
27881 ELSEIF(KFLA.EQ.KTECHN+115) THEN
27882C...Techni-a2:
27883C...Need to update to alpha_rho
27884 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27885 FAC=(ALPRHT/12D0)*SHR
27886 FACF=(1D0/6D0)*(AEM**2/ALPRHT)*SHR
27887 SQMZ=PMAS(23,1)**2
27888 SQMW=PMAS(24,1)**2
27889 SHP=SH
27890 CALL PYWIDX(23,SHP,WDTPP,WDTEP)
27891 GMMZ=SHR*WDTPP(0)
27892 XWRHT=1D0/(4D0*XW*(1D0-XW))
27893 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
27894 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
27895 DO 530 I=1,MDCY(KC,3)
27896 IDC=I+MDCY(KC,2)-1
27897 IF(MDME(IDC,1).LT.0) GOTO 530
27898 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
27899 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
27900 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 530
27901 WID2=1D0
27902 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
27903 IF(I.LE.4) THEN
27904 FACPV=PCM**2
27905 FACPA=PCM**2+1.5D0*RM1
27906 VA2=0D0
27907 AA2=0D0
27908C...a2_tc0 -> W+ + W-
27909 IF(I.EQ.1) THEN
27910 AA2=2D0*RTCM(3)**2/4D0/XW/RTCM(49)**2
27911C...Multiplied by 2 for W^+_T W^-_L + W^+_L W^-_T.(KL)
27912 WID2=WIDS(24,1)
27913C...a2_tc0 -> W+ + pi_tc- + c.c.
27914 ELSEIF(I.EQ.2.OR.I.EQ.3) THEN
27915 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
27916 IF(I.EQ.6) THEN
27917 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+211),3)
27918 ELSE
27919 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+211),2)
27920 ENDIF
27921 ELSEIF(I.EQ.4) THEN
27922C...a2_tc0 -> Z0 + pi_tc0'
27923 VA2=(1D0-RTCM(4)**2)/4D0/XW/XW1/RTCM(48)**2
27924 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+221),2)
27925 ENDIF
27926 WDTP(I)=AEM*SHR**3*PCM/3D0*(VA2*FACPV+AA2*FACPA)
27927 ELSEIF(I.GE.5.AND.I.LE.10) THEN
27928 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
27929 FACPA=PCM**2*(1D0+RM1+RM2)
27930 VA2=0D0
27931 AA2=0D0
27932 IF(I.EQ.5) THEN
27933C...a_T^0 -> gamma rho_T^0
27934 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
27935 WID2=WIDS(PYCOMP(KTECHN+113),2)
27936 ELSEIF(I.EQ.6) THEN
27937C...a_T^0 -> gamma omega_T
27938 VA2=1D0/RTCM(50)**4
27939 WID2=WIDS(PYCOMP(KTECHN+223),2)
27940 ELSEIF(I.EQ.7.OR.I.EQ.8) THEN
27941C...a_T^0 -> W^+- rho_T^-+
27942 AA2=.25D0/XW/RTCM(51)**4
27943 IF(I.EQ.7) THEN
27944 WID2=WIDS(24,2)*WIDS(PYCOMP(KTECHN+213),3)
27945 ELSE
27946 WID2=WIDS(24,3)*WIDS(PYCOMP(KTECHN+213),2)
27947 ENDIF
27948 ELSEIF(I.EQ.9) THEN
27949C...a_T^0 -> Z^0 rho_T^0
27950 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
27951 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+113),2)
27952 ELSEIF(I.EQ.10) THEN
27953C...a_T^0 -> Z^0 omega_T
27954 VA2=.25D0*(1D0-2D0*XW)**2/XW/XW1/RTCM(50)**4
27955 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+223),2)
27956 ENDIF
27957 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
27958 ELSE
27959C...a2_tc0 -> f + fbar.
27960 WID2=1D0
27961 IF(I.LE.18) THEN
27962 IA=I-10
27963 FCOF=3D0*RADC
27964 IF(IA.GE.6.AND.IA.LE.8) WID2=WIDS(IA,1)
27965 ELSE
27966 IA=I-8
27967 FCOF=1D0
27968 IF(IA.GE.17) WID2=WIDS(IA,1)
27969 ENDIF
27970 EI=KCHG(IA,1)/3D0
27971 AI=SIGN(1D0,EI+0.1D0)
27972 VI=AI-4D0*EI*XWV
27973 VALI=0.5D0*(VI+AI)
27974 VARI=0.5D0*(VI-AI)
27975 WDTP(I)=FACF*FCOF*SQRT(MAX(0D0,1D0-4D0*RM1))*((1D0-RM1)*
27976 & ((VALI*BWZR)**2+(VALI*BWZI)**2+
27977 & (VARI*BWZR)**2+(VARI*BWZI)**2)+6D0*RM1*(
27978 & (VALI*BWZR)*(VARI*BWZR)+VALI*VARI*BWZI**2))
27979 ENDIF
27980 WDTP(I)=FUDGE*WDTP(I)
27981 WDTP(0)=WDTP(0)+WDTP(I)
27982 IF(MDME(IDC,1).GT.0) THEN
27983 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
27984 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
27985 WDTE(I,0)=WDTE(I,MDME(IDC,1))
27986 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
27987 ENDIF
27988 530 CONTINUE
27989
27990 ELSEIF(KFLA.EQ.KTECHN+215) THEN
27991C...Techni-a2+/-:
27992 ALPRHT=2.16D0*(3D0/ITCM(1))*RTCM(47)**2
27993 FAC=(ALPRHT/12D0)*SHR
27994 SQMZ=PMAS(23,1)**2
27995 SQMW=PMAS(24,1)**2
27996 SHP=SH
27997 CALL PYWIDX(24,SHP,WDTPP,WDTEP)
27998 GMMW=SHR*WDTPP(0)
27999 FACF=(1D0/12D0)*(AEM**2/ALPRHT)*SHR*
28000 & (0.125D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
28001 DO 540 I=1,MDCY(KC,3)
28002 IDC=I+MDCY(KC,2)-1
28003 IF(MDME(IDC,1).LT.0) GOTO 540
28004 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
28005 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
28006 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 540
28007 WID2=1D0
28008 PCM=.5D0*SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28009 IF(KFLR.GT.0) THEN
28010 ICHANN=2
28011 ELSE
28012 ICHANN=3
28013 ENDIF
28014 IF(I.LE.7) THEN
28015 AA2=0
28016 VA2=0
28017C...a2_tc+ -> gamma + W+.
28018 IF(I.EQ.1) THEN
28019 AA2=RTCM(3)**2/RTCM(49)**2
28020 WID2=WIDS(24,ICHANN)
28021C...a2_tc+ -> gamma + pi_tc+.
28022 ELSEIF(I.EQ.2) THEN
28023 AA2=(1D0-RTCM(3)**2)/RTCM(49)**2
28024 WID2=WIDS(PYCOMP(KTECHN+211),ICHANN)
28025C...a2_tc+ -> W+ + Z
28026 ELSEIF(I.EQ.3) THEN
28027 AA2=RTCM(3)**2*(1D0/4D0/XW1 +
28028 & (XW-XW1)**2/4./XW/XW1)/RTCM(49)**2
28029 WID2=WIDS(24,ICHANN)*WIDS(23,2)
28030C...a2_tc+ -> W+ + pi_tc0.
28031 ELSEIF(I.EQ.4) THEN
28032 AA2=(1D0-RTCM(3)**2)/4D0/XW/RTCM(49)**2
28033 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+111),2)
28034C...a2_tc+ -> W+ + pi_tc'0.
28035 ELSEIF(I.EQ.5) THEN
28036 VA2=(1D0-RTCM(4)**2)/4D0/XW/RTCM(48)**2
28037 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+221),2)
28038C...a2_tc+ -> Z0 + pi_tc+.
28039 ELSEIF(I.EQ.6) THEN
28040 AA2=(1D0-RTCM(3)**2)/4D0/XW/XW1*(1D0-2D0*XW)**2/
28041 & RTCM(49)**2
28042 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+211),ICHANN)
28043 ENDIF
28044 WDTP(I)=AEM*PCM*(AA2*(PCM**2+1.5D0*RM1)+PCM**2*VA2)
28045 & /3D0*SHR**3
28046 ELSEIF(I.LE.10) THEN
28047 FACPV=PCM**2*(1D0+RM1+RM2)+3D0*RM1*RM2
28048 FACPA=PCM**2*(1D0+RM1+RM2)
28049 VA2=0D0
28050 AA2=0D0
28051C...a2_tc+ -> gamma + rho_tc+
28052 IF(I.EQ.7) THEN
28053 VA2=(2D0*RTCM(2)-1D0)**2/RTCM(50)**4
28054 WID2=WIDS(PYCOMP(KTECHN+213),ICHANN)
28055C...a2_tc+ -> W+ + rho_T^0
28056 ELSEIF(I.EQ.8) THEN
28057 AA2=1D0/(4D0*XW)/RTCM(51)**4
28058 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+113),2)
28059C...a2_tc+ -> W+ + omega_T
28060 ELSEIF(I.EQ.9) THEN
28061 VA2=.25D0/XW/RTCM(50)**4
28062 WID2=WIDS(24,ICHANN)*WIDS(PYCOMP(KTECHN+223),2)
28063C...a2_tc+ -> Z^0 + rho_T^+
28064 ELSEIF(I.EQ.10) THEN
28065 VA2=(2D0*RTCM(2)-1D0)**2*XW/XW1/RTCM(50)**4
28066 AA2=1D0/(4D0*XW*XW1)/RTCM(51)**4
28067 WID2=WIDS(23,2)*WIDS(PYCOMP(KTECHN+213),ICHANN)
28068 ENDIF
28069 WDTP(I)=AEM*SHR**5*PCM/12D0*(VA2*FACPV+AA2*FACPA)
28070 ELSE
28071C...a2_tc+ -> f + fbar'.
28072 IA=I-10
28073 WID2=1D0
28074 IF(IA.LE.16) THEN
28075 FCOF=3D0*RADC*VCKM((IA-1)/4+1,MOD(IA-1,4)+1)
28076 IF(KFLR.GT.0) THEN
28077 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,2)
28078 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,2)
28079 IF(IA.GE.13) WID2=WID2*WIDS(7,3)
28080 ELSE
28081 IF(MOD(IA,4).EQ.3) WID2=WIDS(6,3)
28082 IF(MOD(IA,4).EQ.0) WID2=WIDS(8,3)
28083 IF(IA.GE.13) WID2=WID2*WIDS(7,2)
28084 ENDIF
28085 ELSE
28086 FCOF=1D0
28087 IF(KFLR.GT.0) THEN
28088 IF(IA.EQ.20) WID2=WIDS(17,3)*WIDS(18,2)
28089 ELSE
28090 IF(IA.EQ.20) WID2=WIDS(17,2)*WIDS(18,3)
28091 ENDIF
28092 ENDIF
28093 WDTP(I)=FACF*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
28094 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28095 ENDIF
28096 WDTP(I)=FUDGE*WDTP(I)
28097 WDTP(0)=WDTP(0)+WDTP(I)
28098 IF(MDME(IDC,1).GT.0) THEN
28099 WDTE(I,MDME(IDC,1))=WDTP(I)*WID2
28100 WDTE(0,MDME(IDC,1))=WDTE(0,MDME(IDC,1))+WDTE(I,MDME(IDC,1))
28101 WDTE(I,0)=WDTE(I,MDME(IDC,1))
28102 WDTE(0,0)=WDTE(0,0)+WDTE(I,0)
28103 ENDIF
28104 540 CONTINUE
28105
28106 ENDIF
28107 MINT(61)=0
28108 MINT(62)=0
28109 MINT(63)=0
28110 RETURN
28111 END
28112
28113C***********************************************************************
28114
28115C...PYOFSH
28116C...Calculates partial width and differential cross-section maxima
28117C...of channels/processes not allowed on mass-shell, and selects
28118C...masses in such channels/processes.
28119
28120 SUBROUTINE PYOFSH(MOFSH,KFMO,KFD1,KFD2,PMMO,RET1,RET2)
28121
28122C...Double precision and integer declarations.
28123 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28124 IMPLICIT INTEGER(I-N)
28125 INTEGER PYK,PYCHGE,PYCOMP
28126C...Commonblocks.
28127 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28128 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28129 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
28130 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
28131 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28132 COMMON/PYINT1/MINT(400),VINT(400)
28133 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
28134 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
28135 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
28136 &/PYINT2/,/PYINT5/
28137C...Local arrays.
28138 DIMENSION KFD(2),MBW(2),PMD(2),PGD(2),PMG(2),PML(2),PMU(2),
28139 &PMH(2),ATL(2),ATU(2),ATH(2),RMG(2),INX1(100),XPT1(100),
28140 &FPT1(100),INX2(100),XPT2(100),FPT2(100),WDTP(0:400),
28141 &WDTE(0:400,0:5)
28142
28143C...Find if particles equal, maximum mass, matrix elements, etc.
28144 MINT(51)=0
28145 ISUB=MINT(1)
28146 KFD(1)=IABS(KFD1)
28147 KFD(2)=IABS(KFD2)
28148 MEQL=0
28149 IF(KFD(1).EQ.KFD(2)) MEQL=1
28150 MLM=0
28151 IF(MOFSH.GE.2.AND.MEQL.EQ.1) MLM=INT(1.5D0+PYR(0))
28152 IF(MOFSH.LE.2.OR.MOFSH.EQ.5) THEN
28153 NOFF=44
28154 PMMX=PMMO
28155 ELSE
28156 NOFF=40
28157 PMMX=VINT(1)
28158 IF(CKIN(2).GT.CKIN(1)) PMMX=MIN(CKIN(2),VINT(1))
28159 ENDIF
28160 MMED=0
28161 IF((KFMO.EQ.25.OR.KFMO.EQ.35.OR.KFMO.EQ.36).AND.MEQL.EQ.1.AND.
28162 &(KFD(1).EQ.23.OR.KFD(1).EQ.24)) MMED=1
28163 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(1).EQ.23.OR.
28164 &KFD(1).EQ.24).AND.(KFD(2).EQ.23.OR.KFD(2).EQ.24)) MMED=2
28165 IF((KFMO.EQ.32.OR.IABS(KFMO).EQ.34).AND.(KFD(2).EQ.25.OR.
28166 &KFD(2).EQ.35.OR.KFD(2).EQ.36)) MMED=3
28167 LOOP=1
28168
28169C...Find where Breit-Wigners are required, else select discrete masses.
28170 100 DO 110 I=1,2
28171 KFCA=PYCOMP(KFD(I))
28172 IF(KFCA.GT.0) THEN
28173 PMD(I)=PMAS(KFCA,1)
28174 PGD(I)=PMAS(KFCA,2)
28175 ELSE
28176 PMD(I)=0D0
28177 PGD(I)=0D0
28178 ENDIF
28179 IF(MSTP(42).LE.0.OR.PGD(I).LT.PARP(41)) THEN
28180 MBW(I)=0
28181 PMG(I)=PMD(I)
28182 RMG(I)=(PMG(I)/PMMX)**2
28183 ELSE
28184 MBW(I)=1
28185 ENDIF
28186 110 CONTINUE
28187
28188C...Find allowed mass range and Breit-Wigner parameters.
28189 DO 120 I=1,2
28190 IF(MOFSH.EQ.1.AND.LOOP.EQ.1.AND.MBW(I).EQ.1) THEN
28191 PML(I)=PARP(42)
28192 PMU(I)=PMMX-PARP(42)
28193 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
28194 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
28195 ELSEIF(MBW(I).EQ.1.AND.MOFSH.NE.5) THEN
28196 ILM=I
28197 IF(MLM.EQ.2) ILM=3-I
28198 PML(I)=MAX(CKIN(NOFF+2*ILM-1),PARP(42))
28199 IF(MBW(3-I).EQ.0) THEN
28200 PMU(I)=PMMX-PMD(3-I)
28201 ELSE
28202 PMU(I)=PMMX-MAX(CKIN(NOFF+5-2*ILM),PARP(42))
28203 ENDIF
28204 IF(CKIN(NOFF+2*ILM).GT.CKIN(NOFF+2*ILM-1)) PMU(I)=
28205 & MIN(PMU(I),CKIN(NOFF+2*ILM))
28206 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
28207 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
28208 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
28209 IF(MBW(I).EQ.1) THEN
28210 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28211 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28212 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
28213 & PGD(I)))
28214 ENDIF
28215 ELSEIF(MBW(I).EQ.1.AND.MOFSH.EQ.5) THEN
28216 ILM=I
28217 IF(MLM.EQ.2) ILM=3-I
28218 PML(I)=MAX(CKIN(48+I),PARP(42))
28219 PMU(I)=PMMX-MAX(CKIN(51-I),PARP(42))
28220 IF(MBW(3-I).EQ.0) PMU(I)=MIN(PMU(I),PMMX-PMD(3-I))
28221 IF(I.EQ.MLM) PMU(I)=MIN(PMU(I),0.5D0*PMMX)
28222 IF(MEQL.EQ.0) PMH(I)=MIN(PMU(I),0.5D0*PMMX)
28223 IF(PMU(I).LT.PML(I)+PARJ(64)) MBW(I)=-1
28224 IF(MBW(I).EQ.1) THEN
28225 ATL(I)=ATAN((PML(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28226 ATU(I)=ATAN((PMU(I)**2-PMD(I)**2)/(PMD(I)*PGD(I)))
28227 IF(MEQL.EQ.0) ATH(I)=ATAN((PMH(I)**2-PMD(I)**2)/(PMD(I)*
28228 & PGD(I)))
28229 ENDIF
28230 ENDIF
28231 120 CONTINUE
28232 IF(MBW(1).LT.0.OR.MBW(2).LT.0.OR.(MBW(1).EQ.0.AND.MBW(2).EQ.0))
28233 &THEN
28234 CALL PYERRM(3,'(PYOFSH:) no allowed decay product masses')
28235 MINT(51)=1
28236 RETURN
28237 ENDIF
28238
28239C...Calculation of partial width of resonance.
28240 IF(MOFSH.EQ.1) THEN
28241
28242C..If only one integration, pick that to be the inner.
28243 IF(MBW(1).EQ.0) THEN
28244 PM2=PMD(1)
28245 PMD(1)=PMD(2)
28246 PGD(1)=PGD(2)
28247 PML(1)=PML(2)
28248 PMU(1)=PMU(2)
28249 ELSEIF(MBW(2).EQ.0) THEN
28250 PM2=PMD(2)
28251 ENDIF
28252
28253C...Start outer loop of integration.
28254 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
28255 ATL2=ATAN((PML(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
28256 ATU2=ATAN((PMU(2)**2-PMD(2)**2)/(PMD(2)*PGD(2)))
28257 NPT2=1
28258 XPT2(1)=1D0
28259 INX2(1)=0
28260 FMAX2=0D0
28261 ENDIF
28262 130 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
28263 PM2S=PMD(2)**2+PMD(2)*PGD(2)*TAN(ATL2+XPT2(NPT2)*(ATU2-ATL2))
28264 PM2=MIN(PMU(2),MAX(PML(2),SQRT(MAX(0D0,PM2S))))
28265 ENDIF
28266 RM2=(PM2/PMMX)**2
28267
28268C...Start inner loop of integration.
28269 PML1=PML(1)
28270 PMU1=MIN(PMU(1),PMMX-PM2)
28271 IF(MEQL.EQ.1) PMU1=MIN(PMU1,PM2)
28272 ATL1=ATAN((PML1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
28273 ATU1=ATAN((PMU1**2-PMD(1)**2)/(PMD(1)*PGD(1)))
28274 IF(PML1+PARJ(64).GE.PMU1.OR.ATL1+1D-7.GE.ATU1) THEN
28275 FUNC2=0D0
28276 GOTO 180
28277 ENDIF
28278 NPT1=1
28279 XPT1(1)=1D0
28280 INX1(1)=0
28281 FMAX1=0D0
28282 140 PM1S=PMD(1)**2+PMD(1)*PGD(1)*TAN(ATL1+XPT1(NPT1)*(ATU1-ATL1))
28283 PM1=MIN(PMU1,MAX(PML1,SQRT(MAX(0D0,PM1S))))
28284 RM1=(PM1/PMMX)**2
28285
28286C...Evaluate function value - inner loop.
28287 FUNC1=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
28288 IF(MMED.EQ.1) FUNC1=FUNC1*((1D0-RM1-RM2)**2+8D0*RM1*RM2)
28289 IF(MMED.EQ.2) FUNC1=FUNC1**3*(1D0+10D0*RM1+10D0*RM2+RM1**2+
28290 & RM2**2+10D0*RM1*RM2)
28291 IF(FUNC1.GT.FMAX1) FMAX1=FUNC1
28292 FPT1(NPT1)=FUNC1
28293
28294C...Go to next position in inner loop.
28295 IF(NPT1.EQ.1) THEN
28296 NPT1=NPT1+1
28297 XPT1(NPT1)=0D0
28298 INX1(NPT1)=1
28299 GOTO 140
28300 ELSEIF(NPT1.LE.8) THEN
28301 NPT1=NPT1+1
28302 IF(NPT1.LE.4.OR.NPT1.EQ.6) ISH1=1
28303 ISH1=ISH1+1
28304 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
28305 INX1(NPT1)=INX1(ISH1)
28306 INX1(ISH1)=NPT1
28307 GOTO 140
28308 ELSEIF(NPT1.LT.100) THEN
28309 ISN1=ISH1
28310 150 ISH1=ISH1+1
28311 IF(ISH1.GT.NPT1) ISH1=2
28312 IF(ISH1.EQ.ISN1) GOTO 160
28313 DFPT1=ABS(FPT1(ISH1)-FPT1(INX1(ISH1)))
28314 IF(DFPT1.LT.PARP(43)*FMAX1) GOTO 150
28315 NPT1=NPT1+1
28316 XPT1(NPT1)=0.5D0*(XPT1(ISH1)+XPT1(INX1(ISH1)))
28317 INX1(NPT1)=INX1(ISH1)
28318 INX1(ISH1)=NPT1
28319 GOTO 140
28320 ENDIF
28321
28322C...Calculate integral over inner loop.
28323 160 FSUM1=0D0
28324 DO 170 IPT1=2,NPT1
28325 FSUM1=FSUM1+0.5D0*(FPT1(IPT1)+FPT1(INX1(IPT1)))*
28326 & (XPT1(INX1(IPT1))-XPT1(IPT1))
28327 170 CONTINUE
28328 FUNC2=FSUM1*(ATU1-ATL1)/PARU(1)
28329 180 IF(MBW(1).EQ.1.AND.MBW(2).EQ.1) THEN
28330 IF(FUNC2.GT.FMAX2) FMAX2=FUNC2
28331 FPT2(NPT2)=FUNC2
28332
28333C...Go to next position in outer loop.
28334 IF(NPT2.EQ.1) THEN
28335 NPT2=NPT2+1
28336 XPT2(NPT2)=0D0
28337 INX2(NPT2)=1
28338 GOTO 130
28339 ELSEIF(NPT2.LE.8) THEN
28340 NPT2=NPT2+1
28341 IF(NPT2.LE.4.OR.NPT2.EQ.6) ISH2=1
28342 ISH2=ISH2+1
28343 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
28344 INX2(NPT2)=INX2(ISH2)
28345 INX2(ISH2)=NPT2
28346 GOTO 130
28347 ELSEIF(NPT2.LT.100) THEN
28348 ISN2=ISH2
28349 190 ISH2=ISH2+1
28350 IF(ISH2.GT.NPT2) ISH2=2
28351 IF(ISH2.EQ.ISN2) GOTO 200
28352 DFPT2=ABS(FPT2(ISH2)-FPT2(INX2(ISH2)))
28353 IF(DFPT2.LT.PARP(43)*FMAX2) GOTO 190
28354 NPT2=NPT2+1
28355 XPT2(NPT2)=0.5D0*(XPT2(ISH2)+XPT2(INX2(ISH2)))
28356 INX2(NPT2)=INX2(ISH2)
28357 INX2(ISH2)=NPT2
28358 GOTO 130
28359 ENDIF
28360
28361C...Calculate integral over outer loop.
28362 200 FSUM2=0D0
28363 DO 210 IPT2=2,NPT2
28364 FSUM2=FSUM2+0.5D0*(FPT2(IPT2)+FPT2(INX2(IPT2)))*
28365 & (XPT2(INX2(IPT2))-XPT2(IPT2))
28366 210 CONTINUE
28367 FSUM2=FSUM2*(ATU2-ATL2)/PARU(1)
28368 IF(MEQL.EQ.1) FSUM2=2D0*FSUM2
28369 ELSE
28370 FSUM2=FUNC2
28371 ENDIF
28372
28373C...Save result; second integration for user-selected mass range.
28374 IF(LOOP.EQ.1) WIDW=FSUM2
28375 WID2=FSUM2
28376 IF(LOOP.EQ.1.AND.(CKIN(46).GE.CKIN(45).OR.CKIN(48).GE.CKIN(47)
28377 & .OR.MAX(CKIN(45),CKIN(47)).GE.1.01D0*PARP(42))) THEN
28378 LOOP=2
28379 GOTO 100
28380 ENDIF
28381 RET1=WIDW
28382 RET2=WID2/WIDW
28383
28384C...Select two decay product masses of a resonance.
28385 ELSEIF(MOFSH.EQ.2.OR.MOFSH.EQ.5) THEN
28386 220 DO 230 I=1,2
28387 IF(MBW(I).EQ.0) GOTO 230
28388 PMBW=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*
28389 & (ATU(I)-ATL(I)))
28390 PMG(I)=MIN(PMU(I),MAX(PML(I),SQRT(MAX(0D0,PMBW))))
28391 RMG(I)=(PMG(I)/PMMX)**2
28392 230 CONTINUE
28393 IF((MEQL.EQ.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
28394 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) GOTO 220
28395
28396C...Weight with matrix element (if none known, use beta factor).
28397 FLAM=SQRT(MAX(0D0,(1D0-RMG(1)-RMG(2))**2-4D0*RMG(1)*RMG(2)))
28398 IF(MMED.EQ.1) THEN
28399 WTBE=FLAM*((1D0-RMG(1)-RMG(2))**2+8D0*RMG(1)*RMG(2))
28400 ELSEIF(MMED.EQ.2) THEN
28401 WTBE=FLAM**3*(1D0+10D0*RMG(1)+10D0*RMG(2)+RMG(1)**2+
28402 & RMG(2)**2+10D0*RMG(1)*RMG(2))
28403 ELSEIF(MMED.EQ.3) THEN
28404 WTBE=FLAM*(RMG(1)+FLAM**2/12D0)
28405 ELSE
28406 WTBE=FLAM
28407 ENDIF
28408 IF(WTBE.LT.PYR(0)) GOTO 220
28409 RET1=PMG(1)
28410 RET2=PMG(2)
28411
28412C...Find suitable set of masses for initialization of 2 -> 2 processes.
28413 ELSEIF(MOFSH.EQ.3) THEN
28414 IF(MBW(1).NE.0.AND.MBW(2).EQ.0) THEN
28415 PMG(1)=MIN(PMD(1),0.5D0*(PML(1)+PMU(1)))
28416 PMG(2)=PMD(2)
28417 ELSEIF(MBW(2).NE.0.AND.MBW(1).EQ.0) THEN
28418 PMG(1)=PMD(1)
28419 PMG(2)=MIN(PMD(2),0.5D0*(PML(2)+PMU(2)))
28420 ELSE
28421 IDIV=-1
28422 240 IDIV=IDIV+1
28423 PMG(1)=MIN(PMD(1),0.1D0*(IDIV*PML(1)+(10-IDIV)*PMU(1)))
28424 PMG(2)=MIN(PMD(2),0.1D0*(IDIV*PML(2)+(10-IDIV)*PMU(2)))
28425 IF(IDIV.LE.9.AND.PMG(1)+PMG(2).GT.0.9D0*PMMX) GOTO 240
28426 ENDIF
28427 RET1=PMG(1)
28428 RET2=PMG(2)
28429
28430C...Evaluate importance of excluded tails of Breit-Wigners.
28431 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
28432 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
28433 IF(MEQL.LE.1) THEN
28434 VINT(80)=1D0
28435 DO 250 I=1,2
28436 IF(MBW(I).NE.0) VINT(80)=VINT(80)*1.25D0*(ATU(I)-ATL(I))/
28437 & PARU(1)
28438 250 CONTINUE
28439 ELSE
28440 VINT(80)=(1.25D0/PARU(1))**2*MAX((ATU(1)-ATL(1))*
28441 & (ATH(2)-ATL(2)),(ATH(1)-ATL(1))*(ATU(2)-ATL(2)))
28442 ENDIF
28443 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.30.OR.ISUB.EQ.35).AND.
28444 & MSTP(43).NE.2) VINT(80)=2D0*VINT(80)
28445 IF(ISUB.EQ.22.AND.MSTP(43).NE.2) VINT(80)=4D0*VINT(80)
28446 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
28447
28448C...Pick one particle to be the lighter (if improves efficiency).
28449 ELSEIF(MOFSH.EQ.4) THEN
28450 IF(MEQL.EQ.0.AND.MBW(1).EQ.1.AND.MBW(2).EQ.1.AND.PMD(1)+PMD(2)
28451 & .GT.PMMX.AND.PMH(1).GT.PML(1).AND.PMH(2).GT.PML(2)) MEQL=2
28452 260 IF(MEQL.EQ.2) MLM=INT(1.5D0+PYR(0))
28453
28454C...Select two masses according to Breit-Wigner + flat in s + 1/s.
28455 DO 270 I=1,2
28456 IF(MBW(I).EQ.0) GOTO 270
28457 PMV=PMU(I)
28458 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
28459 ATV=ATU(I)
28460 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
28461 RBR=PYR(0)
28462 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
28463 & ISUB.EQ.35).AND.MSTP(43).NE.2) RBR=2D0*RBR
28464 IF(RBR.LT.0.8D0) THEN
28465 PMSR=PMD(I)**2+PMD(I)*PGD(I)*TAN(ATL(I)+PYR(0)*(ATV-ATL(I)))
28466 PMG(I)=MIN(PMV,MAX(PML(I),SQRT(MAX(0D0,PMSR))))
28467 ELSEIF(RBR.LT.0.9D0) THEN
28468 PMG(I)=SQRT(MAX(0D0,PML(I)**2+PYR(0)*(PMV**2-PML(I)**2)))
28469 ELSEIF(RBR.LT.1.5D0) THEN
28470 PMG(I)=PML(I)*(PMV/PML(I))**PYR(0)
28471 ELSE
28472 PMG(I)=SQRT(MAX(0D0,PML(I)**2*PMV**2/(PML(I)**2+PYR(0)*
28473 & (PMV**2-PML(I)**2))))
28474 ENDIF
28475 270 CONTINUE
28476 IF((MEQL.GE.1.AND.PMG(MAX(1,MLM)).GT.PMG(MIN(2,3-MLM))).OR.
28477 & PMG(1)+PMG(2)+PARJ(64).GT.PMMX) THEN
28478 IF(MINT(48).EQ.1.AND.MSTP(171).EQ.0) THEN
28479 NGEN(0,1)=NGEN(0,1)+1
28480 NGEN(MINT(1),1)=NGEN(MINT(1),1)+1
28481 GOTO 260
28482 ELSE
28483 MINT(51)=1
28484 RETURN
28485 ENDIF
28486 ENDIF
28487 RET1=PMG(1)
28488 RET2=PMG(2)
28489
28490C...Give weight for selected mass distribution.
28491 VINT(80)=1D0
28492 DO 280 I=1,2
28493 IF(MBW(I).EQ.0) GOTO 280
28494 PMV=PMU(I)
28495 IF(MEQL.EQ.2.AND.I.EQ.MLM) PMV=PMH(I)
28496 ATV=ATU(I)
28497 IF(MEQL.EQ.2.AND.I.EQ.MLM) ATV=ATH(I)
28498 F0=PMD(I)*PGD(I)/((PMG(I)**2-PMD(I)**2)**2+
28499 & (PMD(I)*PGD(I))**2)/PARU(1)
28500 F1=1D0
28501 F2=1D0/PMG(I)**2
28502 F3=1D0/PMG(I)**4
28503 FI0=(ATV-ATL(I))/PARU(1)
28504 FI1=PMV**2-PML(I)**2
28505 FI2=2D0*LOG(PMV/PML(I))
28506 FI3=1D0/PML(I)**2-1D0/PMV**2
28507 IF((ISUB.EQ.15.OR.ISUB.EQ.19.OR.ISUB.EQ.22.OR.ISUB.EQ.30.OR.
28508 & ISUB.EQ.35).AND.MSTP(43).NE.2) THEN
28509 VINT(80)=VINT(80)*20D0/(8D0+(FI0/F0)*(F1/FI1+6D0*F2/FI2+
28510 & 5D0*F3/FI3))
28511 ELSE
28512 VINT(80)=VINT(80)*10D0/(8D0+(FI0/F0)*(F1/FI1+F2/FI2))
28513 ENDIF
28514 VINT(80)=VINT(80)*FI0
28515 280 CONTINUE
28516 IF(MEQL.GE.1) VINT(80)=2D0*VINT(80)
28517 ENDIF
28518
28519 RETURN
28520 END
28521
28522C***********************************************************************
28523
28524C...PYRECO
28525C...Handles the possibility of colour reconnection in W+W- events,
28526C...Based on the main scenarios of the Sjostrand and Khoze study:
28527C...I, II, II', intermediate and instantaneous; plus one model
28528C...along the lines of the Gustafson and Hakkinen: GH.
28529C...Note: also handles Z0 Z0 and W-W+ events, but notation below
28530C...is as if first resonance is W+ and second W-.
28531
28532 SUBROUTINE PYRECO(IW1,IW2,NSD1,NAFT1)
28533
28534C...Double precision and integer declarations.
28535 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
28536 IMPLICIT INTEGER(I-N)
28537 INTEGER PYK,PYCHGE,PYCOMP
28538C...Parameter value; number of points in MC integration.
28539 PARAMETER (NPT=100)
28540C...Commonblocks.
28541 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
28542 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
28543 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
28544 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
28545 COMMON/PYINT1/MINT(400),VINT(400)
28546 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
28547C...Local arrays.
28548 DIMENSION NBEG(2),NEND(2),INP(50),INM(50),BEWW(3),XP(3),XM(3),
28549 &V1(3),V2(3),BETP(50,4),DIRP(50,3),BETM(50,4),DIRM(50,3),
28550 &XD(4),XB(4),IAP(NPT),IAM(NPT),WTA(NPT),V1P(3),V2P(3),V1M(3),
28551 &V2M(3),Q(4,3),XPP(3),XMM(3),IPC(20),IMC(20),TC(0:20),TPC(20),
28552 &TMC(20),IJOIN(100)
28553
28554C...Functions to give four-product and to do determinants.
28555 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)
28556 DETER(I,J,L)=Q(I,1)*Q(J,2)*Q(L,3)-Q(I,1)*Q(L,2)*Q(J,3)+
28557 &Q(J,1)*Q(L,2)*Q(I,3)-Q(J,1)*Q(I,2)*Q(L,3)+
28558 &Q(L,1)*Q(I,2)*Q(J,3)-Q(L,1)*Q(J,2)*Q(I,3)
28559
28560C...Only allow fraction of recoupling for GH, intermediate and
28561C...instantaneous.
28562 IF(MSTP(115).EQ.5.OR.MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
28563 IF(PYR(0).GT.PARP(120)) RETURN
28564 ENDIF
28565 ISUB=MINT(1)
28566
28567C...Common part for scenarios I, II, II', and GH.
28568 IF(MSTP(115).EQ.1.OR.MSTP(115).EQ.2.OR.MSTP(115).EQ.3.OR.
28569 &MSTP(115).EQ.5) THEN
28570
28571C...Read out frequently-used parameters.
28572 PI=PARU(1)
28573 HBAR=PARU(3)
28574 PMW=PMAS(24,1)
28575 IF(ISUB.EQ.22) PMW=PMAS(23,1)
28576 PGW=PMAS(24,2)
28577 IF(ISUB.EQ.22) PGW=PMAS(23,2)
28578 TFRAG=PARP(115)
28579 RHAD=PARP(116)
28580 FACT=PARP(117)
28581 BLOWR=PARP(118)
28582 BLOWT=PARP(119)
28583
28584C...Find range of decay products of the W's.
28585C...Background: the W's are stored in IW1 and IW2.
28586C...Their direct decay products in NSD1+1 through NSD1+4.
28587C...Products after shower (if any) in NSD1+5 through NAFT1
28588C...for first W and in NAFT1+1 through N for the second.
28589 IF(NAFT1.GT.NSD1+4) THEN
28590 NBEG(1)=NSD1+5
28591 NEND(1)=NAFT1
28592 ELSE
28593 NBEG(1)=NSD1+1
28594 NEND(1)=NSD1+2
28595 ENDIF
28596 IF(N.GT.NAFT1) THEN
28597 NBEG(2)=NAFT1+1
28598 NEND(2)=N
28599 ELSE
28600 NBEG(2)=NSD1+3
28601 NEND(2)=NSD1+4
28602 ENDIF
28603
28604C...Rearrange parton shower products along strings.
28605 NOLD=N
28606 CALL PYPREP(NSD1+1)
28607 IF(MINT(51).NE.0) RETURN
28608
28609C...Find partons pointing back to W+ and W-; store them with quark
28610C...end of string first.
28611 NNP=0
28612 NNM=0
28613 ISGP=0
28614 ISGM=0
28615 DO 120 I=NOLD+1,N
28616 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 120
28617 IF(IABS(K(I,2)).GE.22) GOTO 120
28618 IF(K(I,3).GE.NBEG(1).AND.K(I,3).LE.NEND(1)) THEN
28619 IF(ISGP.EQ.0) ISGP=ISIGN(1,K(I,2))
28620 NNP=NNP+1
28621 IF(ISGP.EQ.1) THEN
28622 INP(NNP)=I
28623 ELSE
28624 DO 100 I1=NNP,2,-1
28625 INP(I1)=INP(I1-1)
28626 100 CONTINUE
28627 INP(1)=I
28628 ENDIF
28629 IF(K(I,1).EQ.1) ISGP=0
28630 ELSEIF(K(I,3).GE.NBEG(2).AND.K(I,3).LE.NEND(2)) THEN
28631 IF(ISGM.EQ.0) ISGM=ISIGN(1,K(I,2))
28632 NNM=NNM+1
28633 IF(ISGM.EQ.1) THEN
28634 INM(NNM)=I
28635 ELSE
28636 DO 110 I1=NNM,2,-1
28637 INM(I1)=INM(I1-1)
28638 110 CONTINUE
28639 INM(1)=I
28640 ENDIF
28641 IF(K(I,1).EQ.1) ISGM=0
28642 ENDIF
28643 120 CONTINUE
28644
28645C...Boost to W+W- rest frame (not strictly needed).
28646 DO 130 J=1,3
28647 BEWW(J)=(P(IW1,J)+P(IW2,J))/(P(IW1,4)+P(IW2,4))
28648 130 CONTINUE
28649 CALL PYROBO(IW1,IW1,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28650 CALL PYROBO(IW2,IW2,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28651 CALL PYROBO(NOLD+1,N,0D0,0D0,-BEWW(1),-BEWW(2),-BEWW(3))
28652
28653C...Select decay vertices of W+ and W-.
28654 TP=HBAR*(-LOG(PYR(0)))*P(IW1,4)/
28655 & SQRT((P(IW1,5)**2-PMW**2)**2+(P(IW1,5)**2*PGW/PMW)**2)
28656 TM=HBAR*(-LOG(PYR(0)))*P(IW2,4)/
28657 & SQRT((P(IW2,5)**2-PMW**2)**2+(P(IW2,5)**2*PGW/PMW)**2)
28658 GTMAX=MAX(TP,TM)
28659 DO 140 J=1,3
28660 XP(J)=TP*P(IW1,J)/P(IW1,4)
28661 XM(J)=TM*P(IW2,J)/P(IW2,4)
28662 140 CONTINUE
28663
28664C...Begin scenario I specifics.
28665 IF(MSTP(115).EQ.1) THEN
28666
28667C...Reconstruct velocity and direction of W+ string pieces.
28668 DO 170 IIP=1,NNP-1
28669 IF(K(INP(IIP),2).LT.0) GOTO 170
28670 I1=INP(IIP)
28671 I2=INP(IIP+1)
28672 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28673 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28674 DO 150 J=1,3
28675 V1(J)=P(I1,J)/P1A
28676 V2(J)=P(I2,J)/P2A
28677 BETP(IIP,J)=0.5D0*(V1(J)+V2(J))
28678 DIRP(IIP,J)=V1(J)-V2(J)
28679 150 CONTINUE
28680 BETP(IIP,4)=1D0/SQRT(1D0-BETP(IIP,1)**2-BETP(IIP,2)**2-
28681 & BETP(IIP,3)**2)
28682 DIRL=SQRT(DIRP(IIP,1)**2+DIRP(IIP,2)**2+DIRP(IIP,3)**2)
28683 DO 160 J=1,3
28684 DIRP(IIP,J)=DIRP(IIP,J)/DIRL
28685 160 CONTINUE
28686 170 CONTINUE
28687
28688C...Reconstruct velocity and direction of W- string pieces.
28689 DO 200 IIM=1,NNM-1
28690 IF(K(INM(IIM),2).LT.0) GOTO 200
28691 I1=INM(IIM)
28692 I2=INM(IIM+1)
28693 P1A=SQRT(P(I1,1)**2+P(I1,2)**2+P(I1,3)**2)
28694 P2A=SQRT(P(I2,1)**2+P(I2,2)**2+P(I2,3)**2)
28695 DO 180 J=1,3
28696 V1(J)=P(I1,J)/P1A
28697 V2(J)=P(I2,J)/P2A
28698 BETM(IIM,J)=0.5D0*(V1(J)+V2(J))
28699 DIRM(IIM,J)=V1(J)-V2(J)
28700 180 CONTINUE
28701 BETM(IIM,4)=1D0/SQRT(1D0-BETM(IIM,1)**2-BETM(IIM,2)**2-
28702 & BETM(IIM,3)**2)
28703 DIRL=SQRT(DIRM(IIM,1)**2+DIRM(IIM,2)**2+DIRM(IIM,3)**2)
28704 DO 190 J=1,3
28705 DIRM(IIM,J)=DIRM(IIM,J)/DIRL
28706 190 CONTINUE
28707 200 CONTINUE
28708
28709C...Loop over number of space-time points.
28710 NACC=0
28711 SUM=0D0
28712 DO 250 IPT=1,NPT
28713
28714C...Pick x,y,z,t Gaussian (width RHAD and TFRAG, respectively).
28715 R=SQRT(-LOG(PYR(0)))
28716 PHI=2D0*PI*PYR(0)
28717 X=BLOWR*RHAD*R*COS(PHI)
28718 Y=BLOWR*RHAD*R*SIN(PHI)
28719 R=SQRT(-LOG(PYR(0)))
28720 PHI=2D0*PI*PYR(0)
28721 Z=BLOWR*RHAD*R*COS(PHI)
28722 T=GTMAX+BLOWT*SQRT(0.5D0)*TFRAG*R*ABS(SIN(PHI))
28723
28724C...Reject impossible points. Weight for sample distribution.
28725 IF(T**2-X**2-Y**2-Z**2.LT.0D0) GOTO 250
28726 WTSMP=EXP(-(X**2+Y**2+Z**2)/(BLOWR*RHAD)**2)*
28727 & EXP(-2D0*(T-GTMAX)**2/(BLOWT*TFRAG)**2)
28728
28729C...Loop over W+ string pieces and find one with largest weight.
28730 IMAXP=0
28731 WTMAXP=1D-10
28732 XD(1)=X-XP(1)
28733 XD(2)=Y-XP(2)
28734 XD(3)=Z-XP(3)
28735 XD(4)=T-TP
28736 DO 220 IIP=1,NNP-1
28737 IF(K(INP(IIP),2).LT.0) GOTO 220
28738 BED=BETP(IIP,1)*XD(1)+BETP(IIP,2)*XD(2)+BETP(IIP,3)*XD(3)
28739 BEDG=BETP(IIP,4)*(BETP(IIP,4)*BED/(1D0+BETP(IIP,4))-XD(4))
28740 DO 210 J=1,3
28741 XB(J)=XD(J)+BEDG*BETP(IIP,J)
28742 210 CONTINUE
28743 XB(4)=BETP(IIP,4)*(XD(4)-BED)
28744 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28745 SZ2=(DIRP(IIP,1)*XB(1)+DIRP(IIP,2)*XB(2)+
28746 & DIRP(IIP,3)*XB(3))**2
28747 WTP=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28748 & TFRAG**2)
28749 IF(XB(4)-SQRT(SR2).LT.0D0) WTP=0D0
28750 IF(WTP.GT.WTMAXP) THEN
28751 IMAXP=IIP
28752 WTMAXP=WTP
28753 ENDIF
28754 220 CONTINUE
28755
28756C...Loop over W- string pieces and find one with largest weight.
28757 IMAXM=0
28758 WTMAXM=1D-10
28759 XD(1)=X-XM(1)
28760 XD(2)=Y-XM(2)
28761 XD(3)=Z-XM(3)
28762 XD(4)=T-TM
28763 DO 240 IIM=1,NNM-1
28764 IF(K(INM(IIM),2).LT.0) GOTO 240
28765 BED=BETM(IIM,1)*XD(1)+BETM(IIM,2)*XD(2)+BETM(IIM,3)*XD(3)
28766 BEDG=BETM(IIM,4)*(BETM(IIM,4)*BED/(1D0+BETM(IIM,4))-XD(4))
28767 DO 230 J=1,3
28768 XB(J)=XD(J)+BEDG*BETM(IIM,J)
28769 230 CONTINUE
28770 XB(4)=BETM(IIM,4)*(XD(4)-BED)
28771 SR2=XB(1)**2+XB(2)**2+XB(3)**2
28772 SZ2=(DIRM(IIM,1)*XB(1)+DIRM(IIM,2)*XB(2)+
28773 & DIRM(IIM,3)*XB(3))**2
28774 WTM=EXP(-(SR2-SZ2)/(2D0*RHAD**2))*EXP(-(XB(4)**2-SZ2)/
28775 & TFRAG**2)
28776 IF(XB(4)-SQRT(SR2).LT.0D0) WTM=0D0
28777 IF(WTM.GT.WTMAXM) THEN
28778 IMAXM=IIM
28779 WTMAXM=WTM
28780 ENDIF
28781 240 CONTINUE
28782
28783C...Result of integration.
28784 WT=0D0
28785 IF(IMAXP.NE.0.AND.IMAXM.NE.0) THEN
28786 WT=WTMAXP*WTMAXM/WTSMP
28787 SUM=SUM+WT
28788 NACC=NACC+1
28789 IAP(NACC)=IMAXP
28790 IAM(NACC)=IMAXM
28791 WTA(NACC)=WT
28792 ENDIF
28793 250 CONTINUE
28794 RES=BLOWR**3*BLOWT*SUM/NPT
28795
28796C...Decide whether to reconnect and, if so, where.
28797 IACC=0
28798 PREC=1D0-EXP(-FACT*RES)
28799 IF(PREC.GT.PYR(0)) THEN
28800 RSUM=PYR(0)*SUM
28801 DO 260 IA=1,NACC
28802 IACC=IA
28803 RSUM=RSUM-WTA(IA)
28804 IF(RSUM.LE.0D0) GOTO 270
28805 260 CONTINUE
28806 270 IIP=IAP(IACC)
28807 IIM=IAM(IACC)
28808 ENDIF
28809
28810C...Begin scenario II and II' specifics.
28811 ELSEIF(MSTP(115).EQ.2.OR.MSTP(115).EQ.3) THEN
28812
28813C...Loop through all string pieces, one from W+ and one from W-.
28814 NCROSS=0
28815 TC(0)=0D0
28816 DO 340 IIP=1,NNP-1
28817 IF(K(INP(IIP),2).LT.0) GOTO 340
28818 I1P=INP(IIP)
28819 I2P=INP(IIP+1)
28820 DO 330 IIM=1,NNM-1
28821 IF(K(INM(IIM),2).LT.0) GOTO 330
28822 I1M=INM(IIM)
28823 I2M=INM(IIM+1)
28824
28825C...Find endpoint velocity vectors.
28826 DO 280 J=1,3
28827 V1P(J)=P(I1P,J)/P(I1P,4)
28828 V2P(J)=P(I2P,J)/P(I2P,4)
28829 V1M(J)=P(I1M,J)/P(I1M,4)
28830 V2M(J)=P(I2M,J)/P(I2M,4)
28831 280 CONTINUE
28832
28833C...Define q matrix and find t.
28834 DO 290 J=1,3
28835 Q(1,J)=V2P(J)-V1P(J)
28836 Q(2,J)=-(V2M(J)-V1M(J))
28837 Q(3,J)=XP(J)-XM(J)-TP*V1P(J)+TM*V1M(J)
28838 Q(4,J)=V1P(J)-V1M(J)
28839 290 CONTINUE
28840 T=-DETER(1,2,3)/DETER(1,2,4)
28841
28842C...Find alpha and beta; i.e. coordinates of crossing point.
28843 S11=Q(1,1)*(T-TP)
28844 S12=Q(2,1)*(T-TM)
28845 S13=Q(3,1)+Q(4,1)*T
28846 S21=Q(1,2)*(T-TP)
28847 S22=Q(2,2)*(T-TM)
28848 S23=Q(3,2)+Q(4,2)*T
28849 DEN=S11*S22-S12*S21
28850 ALP=(S12*S23-S22*S13)/DEN
28851 BET=(S21*S13-S11*S23)/DEN
28852
28853C...Check if solution acceptable.
28854 IANSW=1
28855 IF(T.LT.GTMAX) IANSW=0
28856 IF(ALP.LT.0D0.OR.ALP.GT.1D0) IANSW=0
28857 IF(BET.LT.0D0.OR.BET.GT.1D0) IANSW=0
28858
28859C...Find point of crossing and check that not inconsistent.
28860 DO 300 J=1,3
28861 XPP(J)=XP(J)+(V1P(J)+ALP*(V2P(J)-V1P(J)))*(T-TP)
28862 XMM(J)=XM(J)+(V1M(J)+BET*(V2M(J)-V1M(J)))*(T-TM)
28863 300 CONTINUE
28864 D2PM=(XPP(1)-XMM(1))**2+(XPP(2)-XMM(2))**2+
28865 & (XPP(3)-XMM(3))**2
28866 D2P=XPP(1)**2+XPP(2)**2+XPP(3)**2
28867 D2M=XMM(1)**2+XMM(2)**2+XMM(3)**2
28868 IF(D2PM.GT.1D-4*(D2P+D2M)) IANSW=-1
28869
28870C...Find string eigentimes at crossing.
28871 IF(IANSW.EQ.1) THEN
28872 TAUP=SQRT(MAX(0D0,(T-TP)**2-(XPP(1)-XP(1))**2-
28873 & (XPP(2)-XP(2))**2-(XPP(3)-XP(3))**2))
28874 TAUM=SQRT(MAX(0D0,(T-TM)**2-(XMM(1)-XM(1))**2-
28875 & (XMM(2)-XM(2))**2-(XMM(3)-XM(3))**2))
28876 ELSE
28877 TAUP=0D0
28878 TAUM=0D0
28879 ENDIF
28880
28881C...Order crossings by time. End loop over crossings.
28882 IF(IANSW.EQ.1.AND.NCROSS.LT.20) THEN
28883 NCROSS=NCROSS+1
28884 DO 310 I1=NCROSS,1,-1
28885 IF(T.GT.TC(I1-1).OR.I1.EQ.1) THEN
28886 IPC(I1)=IIP
28887 IMC(I1)=IIM
28888 TC(I1)=T
28889 TPC(I1)=TAUP
28890 TMC(I1)=TAUM
28891 GOTO 320
28892 ELSE
28893 IPC(I1)=IPC(I1-1)
28894 IMC(I1)=IMC(I1-1)
28895 TC(I1)=TC(I1-1)
28896 TPC(I1)=TPC(I1-1)
28897 TMC(I1)=TMC(I1-1)
28898 ENDIF
28899 310 CONTINUE
28900 320 CONTINUE
28901 ENDIF
28902 330 CONTINUE
28903 340 CONTINUE
28904
28905C...Loop over crossings; find first (if any) acceptable one.
28906 IACC=0
28907 IF(NCROSS.GE.1) THEN
28908 DO 350 IC=1,NCROSS
28909 PNFRAG=EXP(-(TPC(IC)**2+TMC(IC)**2)/TFRAG**2)
28910 IF(PNFRAG.GT.PYR(0)) THEN
28911C...Scenario II: only compare with fragmentation time.
28912 IF(MSTP(115).EQ.2) THEN
28913 IACC=IC
28914 IIP=IPC(IACC)
28915 IIM=IMC(IACC)
28916 GOTO 360
28917C...Scenario II': also require that string length decreases.
28918 ELSE
28919 IIP=IPC(IC)
28920 IIM=IMC(IC)
28921 I1P=INP(IIP)
28922 I2P=INP(IIP+1)
28923 I1M=INM(IIM)
28924 I2M=INM(IIM+1)
28925 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28926 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28927 IF(ELNEW.LT.ELOLD) THEN
28928 IACC=IC
28929 IIP=IPC(IACC)
28930 IIM=IMC(IACC)
28931 GOTO 360
28932 ENDIF
28933 ENDIF
28934 ENDIF
28935 350 CONTINUE
28936 360 CONTINUE
28937 ENDIF
28938
28939C...Begin scenario GH specifics.
28940 ELSEIF(MSTP(115).EQ.5) THEN
28941
28942C...Loop through all string pieces, one from W+ and one from W-.
28943 IACC=0
28944 ELMIN=1D0
28945 DO 380 IIP=1,NNP-1
28946 IF(K(INP(IIP),2).LT.0) GOTO 380
28947 I1P=INP(IIP)
28948 I2P=INP(IIP+1)
28949 DO 370 IIM=1,NNM-1
28950 IF(K(INM(IIM),2).LT.0) GOTO 370
28951 I1M=INM(IIM)
28952 I2M=INM(IIM+1)
28953
28954C...Look for largest decrease of (exponent of) Lambda measure.
28955 ELOLD=FOUR(I1P,I2P)*FOUR(I1M,I2M)
28956 ELNEW=FOUR(I1P,I2M)*FOUR(I1M,I2P)
28957 ELDIF=ELNEW/MAX(1D-10,ELOLD)
28958 IF(ELDIF.LT.ELMIN) THEN
28959 IACC=IIP+IIM
28960 ELMIN=ELDIF
28961 IPC(1)=IIP
28962 IMC(1)=IIM
28963 ENDIF
28964 370 CONTINUE
28965 380 CONTINUE
28966 IIP=IPC(1)
28967 IIM=IMC(1)
28968 ENDIF
28969
28970C...Common for scenarios I, II, II' and GH: reconnect strings.
28971 IF(IACC.NE.0) THEN
28972 MINT(32)=1
28973 NJOIN=0
28974 DO 390 IS=1,NNP+NNM
28975 NJOIN=NJOIN+1
28976 IF(IS.LE.IIP) THEN
28977 I=INP(IS)
28978 ELSEIF(IS.LE.IIP+NNM-IIM) THEN
28979 I=INM(IS-IIP+IIM)
28980 ELSEIF(IS.LE.IIP+NNM) THEN
28981 I=INM(IS-IIP-NNM+IIM)
28982 ELSE
28983 I=INP(IS-NNM)
28984 ENDIF
28985 IJOIN(NJOIN)=I
28986 IF(K(I,2).LT.0) THEN
28987 CALL PYJOIN(NJOIN,IJOIN)
28988 NJOIN=0
28989 ENDIF
28990 390 CONTINUE
28991
28992C...Restore original event record if no reconnection.
28993 ELSE
28994 DO 400 I=NSD1+1,NOLD
28995 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14) THEN
28996 K(I,4)=MOD(K(I,4),MSTU(5)**2)
28997 K(I,5)=MOD(K(I,5),MSTU(5)**2)
28998 ENDIF
28999 400 CONTINUE
29000 DO 410 I=NOLD+1,N
29001 K(K(I,3),1)=3
29002 410 CONTINUE
29003 N=NOLD
29004 ENDIF
29005
29006C...Boost back system.
29007 CALL PYROBO(IW1,IW1,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
29008 CALL PYROBO(IW2,IW2,0D0,0D0,BEWW(1),BEWW(2),BEWW(3))
29009 IF(N.GT.NOLD) CALL PYROBO(NOLD+1,N,0D0,0D0,
29010 & BEWW(1),BEWW(2),BEWW(3))
29011
29012C...Common part for intermediate and instantaneous scenarios.
29013 ELSEIF(MSTP(115).EQ.11.OR.MSTP(115).EQ.12) THEN
29014 MINT(32)=1
29015
29016C...Remove old shower products and reset showering ones.
29017 N=NSD1+4
29018 DO 420 I=NSD1+1,NSD1+4
29019 K(I,1)=3
29020 K(I,4)=MOD(K(I,4),MSTU(5)**2)
29021 K(I,5)=MOD(K(I,5),MSTU(5)**2)
29022 420 CONTINUE
29023
29024C...Identify quark-antiquark pairs.
29025 IQ1=NSD1+1
29026 IQ2=NSD1+2
29027 IQ3=NSD1+3
29028 IF(K(IQ1,2)*K(IQ3,2).LT.0) IQ3=NSD1+4
29029 IQ4=2*NSD1+7-IQ3
29030
29031C...Reconnect strings.
29032 IJOIN(1)=IQ1
29033 IJOIN(2)=IQ4
29034 CALL PYJOIN(2,IJOIN)
29035 IJOIN(1)=IQ3
29036 IJOIN(2)=IQ2
29037 CALL PYJOIN(2,IJOIN)
29038
29039C...Do new parton showers in intermediate scenario.
29040 IF(MSTP(71).GE.1.AND.MSTP(115).EQ.11) THEN
29041 MSTJ50=MSTJ(50)
29042 MSTJ(50)=0
29043 CALL PYSHOW(IQ1,IQ2,P(IW1,5))
29044 CALL PYSHOW(IQ3,IQ4,P(IW2,5))
29045 MSTJ(50)=MSTJ50
29046
29047C...Do new parton showers in instantaneous scenario.
29048 ELSEIF(MSTP(71).GE.1.AND.MSTP(115).EQ.12) THEN
29049 PPM2=(P(IQ1,4)+P(IQ4,4))**2-(P(IQ1,1)+P(IQ4,1))**2-
29050 & (P(IQ1,2)+P(IQ4,2))**2-(P(IQ1,3)+P(IQ4,3))**2
29051 PPM=SQRT(MAX(0D0,PPM2))
29052 CALL PYSHOW(IQ1,IQ4,PPM)
29053 PPM2=(P(IQ3,4)+P(IQ2,4))**2-(P(IQ3,1)+P(IQ2,1))**2-
29054 & (P(IQ3,2)+P(IQ2,2))**2-(P(IQ3,3)+P(IQ2,3))**2
29055 PPM=SQRT(MAX(0D0,PPM2))
29056 CALL PYSHOW(IQ3,IQ2,PPM)
29057 ENDIF
29058 ENDIF
29059
29060 RETURN
29061 END
29062
29063C***********************************************************************
29064
29065C...PYKLIM
29066C...Checks generated variables against pre-set kinematical limits;
29067C...also calculates limits on variables used in generation.
29068
29069 SUBROUTINE PYKLIM(ILIM)
29070
29071C...Double precision and integer declarations.
29072 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29073 IMPLICIT INTEGER(I-N)
29074 INTEGER PYK,PYCHGE,PYCOMP
29075C...Commonblocks.
29076 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
29077 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29078 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29079 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29080 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29081 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29082 COMMON/PYINT1/MINT(400),VINT(400)
29083 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29084 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
29085 &/PYINT1/,/PYINT2/
29086
29087C...Common kinematical expressions.
29088 MINT(51)=0
29089 ISUB=MINT(1)
29090 ISTSB=ISET(ISUB)
29091 IF(ISUB.EQ.96) GOTO 100
29092 SQM3=VINT(63)
29093 SQM4=VINT(64)
29094 IF(ILIM.NE.0) THEN
29095 IF(ABS(SQM3).LT.1D-4.AND.ABS(SQM4).LT.1D-4) THEN
29096 CKIN09=MAX(CKIN(9),CKIN(13))
29097 CKIN10=MIN(CKIN(10),CKIN(14))
29098 CKIN11=MAX(CKIN(11),CKIN(15))
29099 CKIN12=MIN(CKIN(12),CKIN(16))
29100 ELSE
29101 CKIN09=MAX(CKIN(9),MIN(0D0,CKIN(13)))
29102 CKIN10=MIN(CKIN(10),MAX(0D0,CKIN(14)))
29103 CKIN11=MAX(CKIN(11),MIN(0D0,CKIN(15)))
29104 CKIN12=MIN(CKIN(12),MAX(0D0,CKIN(16)))
29105 ENDIF
29106 ENDIF
29107 IF(ILIM.NE.1) THEN
29108 TAU=VINT(21)
29109 RM3=SQM3/(TAU*VINT(2))
29110 RM4=SQM4/(TAU*VINT(2))
29111 BE34=SQRT(MAX(1D-20,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
29112 ENDIF
29113 PTHMIN=CKIN(3)
29114 IF(MIN(SQM3,SQM4).LT.CKIN(6)**2.AND.ISTSB.NE.1.AND.ISTSB.NE.3)
29115 &PTHMIN=MAX(CKIN(3),CKIN(5))
29116
29117 IF(ILIM.EQ.0) THEN
29118C...Check generated values of tau, y*, cos(theta-hat), and tau' against
29119C...pre-set kinematical limits.
29120 YST=VINT(22)
29121 CTH=VINT(23)
29122 TAUP=VINT(26)
29123 TAUE=TAU
29124 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
29125 X1=SQRT(TAUE)*EXP(YST)
29126 X2=SQRT(TAUE)*EXP(-YST)
29127 XF=X1-X2
29128 IF(MINT(47).NE.1) THEN
29129 IF(TAU*VINT(2).LT.CKIN(1)**2) MINT(51)=1
29130 IF(CKIN(2).GE.0D0.AND.TAU*VINT(2).GT.CKIN(2)**2) MINT(51)=1
29131 IF(YST.LT.CKIN(7).OR.YST.GT.CKIN(8)) MINT(51)=1
29132 IF(XF.LT.CKIN(25).OR.XF.GT.CKIN(26)) MINT(51)=1
29133 ENDIF
29134 IF(MINT(45).NE.1) THEN
29135 IF(X1.LT.CKIN(21).OR.X1.GT.CKIN(22)) MINT(51)=1
29136 ENDIF
29137 IF(MINT(46).NE.1) THEN
29138 IF(X2.LT.CKIN(23).OR.X2.GT.CKIN(24)) MINT(51)=1
29139 ENDIF
29140 IF(MINT(45).EQ.2) THEN
29141 IF(X1.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
29142 ENDIF
29143 IF(MINT(46).EQ.2) THEN
29144 IF(X2.GT.1D0-2D0*PARP(111)/VINT(1)) MINT(51)=1
29145 ENDIF
29146 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
29147 PTH=0.5D0*BE34*SQRT(TAU*VINT(2)*MAX(0D0,1D0-CTH**2))
29148 EXPY3=MAX(1D-20,(1D0+RM3-RM4+BE34*CTH)/
29149 & MAX(1D-20,(1D0+RM3-RM4-BE34*CTH)))
29150 EXPY4=MAX(1D-20,(1D0-RM3+RM4-BE34*CTH)/
29151 & MAX(1D-20,(1D0-RM3+RM4+BE34*CTH)))
29152 Y3=YST+0.5D0*LOG(EXPY3)
29153 Y4=YST+0.5D0*LOG(EXPY4)
29154 YLARGE=MAX(Y3,Y4)
29155 YSMALL=MIN(Y3,Y4)
29156 ETALAR=20D0
29157 ETASMA=-20D0
29158 STH=SQRT(MAX(0D0,1D0-CTH**2))
29159 EXSQ3=SQRT(MAX(1D-20,((1D0+RM3-RM4)*COSH(YST)+BE34*SINH(YST)*
29160 & CTH)**2-4D0*RM3))
29161 EXSQ4=SQRT(MAX(1D-20,((1D0-RM3+RM4)*COSH(YST)-BE34*SINH(YST)*
29162 & CTH)**2-4D0*RM4))
29163 IF(STH.GE.1D-10) THEN
29164 EXPET3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH+EXSQ3)/
29165 & (BE34*STH)
29166 EXPET4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH+EXSQ4)/
29167 & (BE34*STH)
29168 ETA3=LOG(MIN(1D10,MAX(1D-10,EXPET3)))
29169 ETA4=LOG(MIN(1D10,MAX(1D-10,EXPET4)))
29170 ETALAR=MAX(ETA3,ETA4)
29171 ETASMA=MIN(ETA3,ETA4)
29172 ENDIF
29173 CTS3=((1D0+RM3-RM4)*SINH(YST)+BE34*COSH(YST)*CTH)/EXSQ3
29174 CTS4=((1D0-RM3+RM4)*SINH(YST)-BE34*COSH(YST)*CTH)/EXSQ4
29175 CTSLAR=MIN(1D0,MAX(-1D0,CTS3,CTS4))
29176 CTSSMA=MAX(-1D0,MIN(1D0,CTS3,CTS4))
29177 SH=TAU*VINT(2)
29178 RPTS=4D0*VINT(71)**2/SH
29179 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
29180 RM34=MAX(1D-20,2D0*RM3*RM4)
29181 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
29182 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
29183 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
29184 THA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
29185 UHA=0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
29186 IF(PTH.LT.PTHMIN) MINT(51)=1
29187 IF(CKIN(4).GE.0D0.AND.PTH.GT.CKIN(4)) MINT(51)=1
29188 IF(YLARGE.LT.CKIN(9).OR.YLARGE.GT.CKIN(10)) MINT(51)=1
29189 IF(YSMALL.LT.CKIN(11).OR.YSMALL.GT.CKIN(12)) MINT(51)=1
29190 IF(ETALAR.LT.CKIN(13).OR.ETALAR.GT.CKIN(14)) MINT(51)=1
29191 IF(ETASMA.LT.CKIN(15).OR.ETASMA.GT.CKIN(16)) MINT(51)=1
29192 IF(CTSLAR.LT.CKIN(17).OR.CTSLAR.GT.CKIN(18)) MINT(51)=1
29193 IF(CTSSMA.LT.CKIN(19).OR.CTSSMA.GT.CKIN(20)) MINT(51)=1
29194 IF(CTH.LT.CKIN(27).OR.CTH.GT.CKIN(28)) MINT(51)=1
29195 IF(THA.LT.CKIN(35)) MINT(51)=1
29196 IF(CKIN(36).GE.0D0.AND.THA.GT.CKIN(36)) MINT(51)=1
29197 IF(UHA.LT.CKIN(37)) MINT(51)=1
29198 IF(CKIN(38).GE.0D0.AND.UHA.GT.CKIN(38)) MINT(51)=1
29199 ENDIF
29200 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
29201 IF(TAUP*VINT(2).LT.CKIN(31)**2) MINT(51)=1
29202 IF(CKIN(32).GE.0D0.AND.TAUP*VINT(2).GT.CKIN(32)**2) MINT(51)=1
29203 ENDIF
29204
29205C...Additional cuts on W2 (approximately) in DIS.
29206 IF(ISUB.EQ.10.AND.MINT(43).GE.2) THEN
29207 XBJ=X2
29208 IF(IABS(MINT(12)).LT.20) XBJ=X1
29209 Q2BJ=THA
29210 W2BJ=Q2BJ*(1D0-XBJ)/XBJ
29211 IF(W2BJ.LT.CKIN(39)) MINT(51)=1
29212 IF(CKIN(40).GT.0D0.AND.W2BJ.GT.CKIN(40)) MINT(51)=1
29213 ENDIF
29214
29215 ELSEIF(ILIM.EQ.1) THEN
29216C...Calculate limits on tau
29217C...0) due to definition
29218 TAUMN0=0D0
29219 TAUMX0=1D0
29220C...1) due to limits on subsystem mass
29221 TAUMN1=CKIN(1)**2/VINT(2)
29222 TAUMX1=1D0
29223 IF(CKIN(2).GE.0D0) TAUMX1=CKIN(2)**2/VINT(2)
29224C...2) due to limits on pT-hat (and non-overlapping rapidity intervals)
29225 TM3=SQRT(SQM3+PTHMIN**2)
29226 TM4=SQRT(SQM4+PTHMIN**2)
29227 YDCOSH=1D0
29228 IF(CKIN09.GT.CKIN12) YDCOSH=COSH(CKIN09-CKIN12)
29229 TAUMN2=(TM3**2+2D0*TM3*TM4*YDCOSH+TM4**2)/VINT(2)
29230 TAUMX2=1D0
29231C...3) due to limits on pT-hat and cos(theta-hat)
29232 CTH2MN=MIN(CKIN(27)**2,CKIN(28)**2)
29233 CTH2MX=MAX(CKIN(27)**2,CKIN(28)**2)
29234 TAUMN3=0D0
29235 IF(CKIN(27)*CKIN(28).GT.0D0) TAUMN3=
29236 & (SQRT(SQM3+PTHMIN**2/(1D0-CTH2MN))+
29237 & SQRT(SQM4+PTHMIN**2/(1D0-CTH2MN)))**2/VINT(2)
29238 TAUMX3=1D0
29239 IF(CKIN(4).GE.0D0.AND.CTH2MX.LT.1D0) TAUMX3=
29240 & (SQRT(SQM3+CKIN(4)**2/(1D0-CTH2MX))+
29241 & SQRT(SQM4+CKIN(4)**2/(1D0-CTH2MX)))**2/VINT(2)
29242C...4) due to limits on x1 and x2
29243 TAUMN4=CKIN(21)*CKIN(23)
29244 TAUMX4=CKIN(22)*CKIN(24)
29245C...5) due to limits on xF
29246 TAUMN5=0D0
29247 TAUMX5=MAX(1D0-CKIN(25),1D0+CKIN(26))
29248C...6) due to limits on that and uhat
29249 TAUMN6=(SQM3+SQM4+CKIN(35)+CKIN(37))/VINT(2)
29250 TAUMX6=1D0
29251 IF(CKIN(36).GT.0D0.AND.CKIN(38).GT.0D0) TAUMX6=
29252 & (SQM3+SQM4+CKIN(36)+CKIN(38))/VINT(2)
29253
29254C...Net effect of all separate limits.
29255 VINT(11)=MAX(TAUMN0,TAUMN1,TAUMN2,TAUMN3,TAUMN4,TAUMN5,TAUMN6)
29256 VINT(31)=MIN(TAUMX0,TAUMX1,TAUMX2,TAUMX3,TAUMX4,TAUMX5,TAUMX6)
29257 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
29258 VINT(11)=1D0-1D-9
29259 VINT(31)=1D0+1D-9
29260 ELSEIF(MINT(47).EQ.5) THEN
29261 VINT(31)=MIN(VINT(31),1D0-2D-10)
29262 ELSEIF(MINT(47).GE.6) THEN
29263 VINT(31)=MIN(VINT(31),1D0-1D-10)
29264 ENDIF
29265 IF(VINT(31).LE.VINT(11)) MINT(51)=1
29266
29267 ELSEIF(ILIM.EQ.2) THEN
29268C...Calculate limits on y*
29269 TAUE=TAU
29270 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
29271 TAURT=SQRT(TAUE)
29272C...0) due to kinematics
29273 YSTMN0=LOG(TAURT)
29274 YSTMX0=-YSTMN0
29275C...1) due to explicit limits
29276 YSTMN1=CKIN(7)
29277 YSTMX1=CKIN(8)
29278C...2) due to limits on x1
29279 YSTMN2=LOG(MAX(TAUE,CKIN(21))/TAURT)
29280 YSTMX2=LOG(MAX(TAUE,CKIN(22))/TAURT)
29281C...3) due to limits on x2
29282 YSTMN3=-LOG(MAX(TAUE,CKIN(24))/TAURT)
29283 YSTMX3=-LOG(MAX(TAUE,CKIN(23))/TAURT)
29284C...4) due to limits on xF
29285 YEPMN4=0.5D0*ABS(CKIN(25))/TAURT
29286 YSTMN4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMN4**2)+YEPMN4)),CKIN(25))
29287 YEPMX4=0.5D0*ABS(CKIN(26))/TAURT
29288 YSTMX4=SIGN(LOG(MAX(1D-20,SQRT(1D0+YEPMX4**2)+YEPMX4)),CKIN(26))
29289C...5) due to simultaneous limits on y-large and y-small
29290 YEPSMN=(RM3-RM4)*SINH(CKIN09-CKIN11)
29291 YEPSMX=(RM3-RM4)*SINH(CKIN10-CKIN12)
29292 YDIFMN=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMN**2)-YEPSMN)))
29293 YDIFMX=ABS(LOG(MAX(1D-20,SQRT(1D0+YEPSMX**2)-YEPSMX)))
29294 YSTMN5=0.5D0*(CKIN09+CKIN11-YDIFMN)
29295 YSTMX5=0.5D0*(CKIN10+CKIN12+YDIFMX)
29296C...6) due to simultaneous limits on cos(theta-hat) and y-large or
29297C... y-small
29298 CTHLIM=SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAUE*VINT(2))))
29299 RZMN=BE34*MAX(CKIN(27),-CTHLIM)
29300 RZMX=BE34*MIN(CKIN(28),CTHLIM)
29301 YEX3MX=(1D0+RM3-RM4+RZMX)/MAX(1D-10,1D0+RM3-RM4-RZMX)
29302 YEX4MX=(1D0+RM4-RM3-RZMN)/MAX(1D-10,1D0+RM4-RM3+RZMN)
29303 YEX3MN=MAX(1D-10,1D0+RM3-RM4+RZMN)/(1D0+RM3-RM4-RZMN)
29304 YEX4MN=MAX(1D-10,1D0+RM4-RM3-RZMX)/(1D0+RM4-RM3+RZMX)
29305 YSTMN6=CKIN09-0.5D0*LOG(MAX(YEX3MX,YEX4MX))
29306 YSTMX6=CKIN12-0.5D0*LOG(MIN(YEX3MN,YEX4MN))
29307
29308C...Net effect of all separate limits.
29309 VINT(12)=MAX(YSTMN0,YSTMN1,YSTMN2,YSTMN3,YSTMN4,YSTMN5,YSTMN6)
29310 VINT(32)=MIN(YSTMX0,YSTMX1,YSTMX2,YSTMX3,YSTMX4,YSTMX5,YSTMX6)
29311 IF(MINT(47).EQ.1) THEN
29312 VINT(12)=-1D-9
29313 VINT(32)=1D-9
29314 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
29315 VINT(12)=(1D0-1D-9)*YSTMX0
29316 VINT(32)=(1D0+1D-9)*YSTMX0
29317 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
29318 VINT(12)=-(1D0+1D-9)*YSTMX0
29319 VINT(32)=-(1D0-1D-9)*YSTMX0
29320 ELSEIF(MINT(47).EQ.5) THEN
29321 YSTEE=LOG((1D0-1D-10)/TAURT)
29322 VINT(12)=MAX(VINT(12),-YSTEE)
29323 VINT(32)=MIN(VINT(32),YSTEE)
29324 ENDIF
29325 IF(VINT(32).LE.VINT(12)) MINT(51)=1
29326
29327 ELSEIF(ILIM.EQ.3) THEN
29328C...Calculate limits on cos(theta-hat)
29329 YST=VINT(22)
29330C...0) due to definition
29331 CTNMN0=-1D0
29332 CTNMX0=0D0
29333 CTPMN0=0D0
29334 CTPMX0=1D0
29335C...1) due to explicit limits
29336 CTNMN1=MIN(0D0,CKIN(27))
29337 CTNMX1=MIN(0D0,CKIN(28))
29338 CTPMN1=MAX(0D0,CKIN(27))
29339 CTPMX1=MAX(0D0,CKIN(28))
29340C...2) due to limits on pT-hat
29341 CTNMN2=-SQRT(MAX(0D0,1D0-4D0*PTHMIN**2/(BE34**2*TAU*VINT(2))))
29342 CTPMX2=-CTNMN2
29343 CTNMX2=0D0
29344 CTPMN2=0D0
29345 IF(CKIN(4).GE.0D0) THEN
29346 CTNMX2=-SQRT(MAX(0D0,1D0-4D0*CKIN(4)**2/
29347 & (BE34**2*TAU*VINT(2))))
29348 CTPMN2=-CTNMX2
29349 ENDIF
29350C...3) due to limits on y-large and y-small
29351 CTNMN3=MIN(0D0,MAX((1D0+RM3-RM4)/BE34*TANH(CKIN11-YST),
29352 & -(1D0-RM3+RM4)/BE34*TANH(CKIN10-YST)))
29353 CTNMX3=MIN(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN12-YST),
29354 & -(1D0-RM3+RM4)/BE34*TANH(CKIN09-YST))
29355 CTPMN3=MAX(0D0,(1D0+RM3-RM4)/BE34*TANH(CKIN09-YST),
29356 & -(1D0-RM3+RM4)/BE34*TANH(CKIN12-YST))
29357 CTPMX3=MAX(0D0,MIN((1D0+RM3-RM4)/BE34*TANH(CKIN10-YST),
29358 & -(1D0-RM3+RM4)/BE34*TANH(CKIN11-YST)))
29359C...4) due to limits on that
29360 CTNMN4=-1D0
29361 CTNMX4=0D0
29362 CTPMN4=0D0
29363 CTPMX4=1D0
29364 SH=TAU*VINT(2)
29365 IF(CKIN(35).GT.0D0) THEN
29366 CTLIM=(1D0-RM3-RM4-2D0*CKIN(35)/SH)/BE34
29367 IF(CTLIM.GT.0D0) THEN
29368 CTPMX4=CTLIM
29369 ELSE
29370 CTPMX4=0D0
29371 CTNMX4=CTLIM
29372 ENDIF
29373 ENDIF
29374 IF(CKIN(36).GT.0D0) THEN
29375 CTLIM=(1D0-RM3-RM4-2D0*CKIN(36)/SH)/BE34
29376 IF(CTLIM.LT.0D0) THEN
29377 CTNMN4=CTLIM
29378 ELSE
29379 CTNMN4=0D0
29380 CTPMN4=CTLIM
29381 ENDIF
29382 ENDIF
29383C...5) due to limits on uhat
29384 CTNMN5=-1D0
29385 CTNMX5=0D0
29386 CTPMN5=0D0
29387 CTPMX5=1D0
29388 IF(CKIN(37).GT.0D0) THEN
29389 CTLIM=(2D0*CKIN(37)/SH-(1D0-RM3-RM4))/BE34
29390 IF(CTLIM.LT.0D0) THEN
29391 CTNMN5=CTLIM
29392 ELSE
29393 CTNMN5=0D0
29394 CTPMN5=CTLIM
29395 ENDIF
29396 ENDIF
29397 IF(CKIN(38).GT.0D0) THEN
29398 CTLIM=(2D0*CKIN(38)/SH-(1D0-RM3-RM4))/BE34
29399 IF(CTLIM.GT.0D0) THEN
29400 CTPMX5=CTLIM
29401 ELSE
29402 CTPMX5=0D0
29403 CTNMX5=CTLIM
29404 ENDIF
29405 ENDIF
29406
29407C...Net effect of all separate limits.
29408 VINT(13)=MAX(CTNMN0,CTNMN1,CTNMN2,CTNMN3,CTNMN4,CTNMN5)
29409 VINT(33)=MIN(CTNMX0,CTNMX1,CTNMX2,CTNMX3,CTNMX4,CTNMX5)
29410 VINT(14)=MAX(CTPMN0,CTPMN1,CTPMN2,CTPMN3,CTPMN4,CTPMN5)
29411 VINT(34)=MIN(CTPMX0,CTPMX1,CTPMX2,CTPMX3,CTPMX4,CTPMX5)
29412 IF(VINT(33).LE.VINT(13).AND.VINT(34).LE.VINT(14)) MINT(51)=1
29413
29414 IF(VINT(14).GT.VINT(34)) VINT(34)=VINT(14)
29415 IF(VINT(13).GT.VINT(33)) VINT(33)=VINT(13)
29416
29417 ELSEIF(ILIM.EQ.4) THEN
29418C...Calculate limits on tau'
29419C...0) due to kinematics
29420 TAPMN0=TAU
29421 IF(ISTSB.EQ.5.AND.VINT(201).GT.0D0) THEN
29422 PQRAT=(VINT(201)+VINT(206))/VINT(1)
29423 TAPMN0=(SQRT(TAU)+PQRAT)**2
29424 ENDIF
29425 TAPMX0=1D0
29426C...1) due to explicit limits
29427 TAPMN1=CKIN(31)**2/VINT(2)
29428 TAPMX1=1D0
29429 IF(CKIN(32).GE.0D0) TAPMX1=CKIN(32)**2/VINT(2)
29430
29431C...Net effect of all separate limits.
29432 VINT(16)=MAX(TAPMN0,TAPMN1)
29433 VINT(36)=MIN(TAPMX0,TAPMX1)
29434 IF(MINT(47).EQ.1) THEN
29435 VINT(16)=1D0-1D-9
29436 VINT(36)=1D0+1D-9
29437 ELSEIF(MINT(47).EQ.5) THEN
29438 VINT(36)=MIN(VINT(36),1D0-2D-10)
29439 ELSEIF(MINT(47).EQ.6.OR.MINT(47).EQ.7) THEN
29440 VINT(36)=MIN(VINT(36),1D0-1D-10)
29441 ENDIF
29442 IF(VINT(36).LE.VINT(16)) MINT(51)=1
29443
29444 ENDIF
29445 RETURN
29446
29447C...Special case for low-pT and multiple interactions:
29448C...effective kinematical limits for tau, y*, cos(theta-hat).
29449 100 IF(ILIM.EQ.0) THEN
29450 ELSEIF(ILIM.EQ.1) THEN
29451 IF(MSTP(82).LE.1) THEN
29452 VINT(11)=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
29453 & VINT(2)
29454 ELSE
29455 VINT(11)=(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/VINT(2)
29456 ENDIF
29457 VINT(31)=1D0
29458 ELSEIF(ILIM.EQ.2) THEN
29459 VINT(12)=0.5D0*LOG(VINT(21))
29460 VINT(32)=-VINT(12)
29461 ELSEIF(ILIM.EQ.3) THEN
29462 IF(MSTP(82).LE.1) THEN
29463 ST2EFF=4D0*(PARP(81)*(VINT(1)/PARP(89))**PARP(90))**2/
29464 & (VINT(21)*VINT(2))
29465 ELSE
29466 ST2EFF=0.01D0*(PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2/
29467 & (VINT(21)*VINT(2))
29468 ENDIF
29469 VINT(13)=-SQRT(MAX(0D0,1D0-ST2EFF))
29470 VINT(33)=0D0
29471 VINT(14)=0D0
29472 VINT(34)=-VINT(13)
29473 ENDIF
29474
29475 RETURN
29476 END
29477
29478C*********************************************************************
29479
29480C...PYKMAP
29481C...Maps a uniform distribution into a distribution of a kinematical
29482C...variable according to one of the possibilities allowed. It is
29483C...assumed that kinematical limits have been set by a PYKLIM call.
29484
29485 SUBROUTINE PYKMAP(IVAR,MVAR,VVAR)
29486
29487C...Double precision and integer declarations.
29488 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29489 IMPLICIT INTEGER(I-N)
29490 INTEGER PYK,PYCHGE,PYCOMP
29491C...Commonblocks.
29492 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29493 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29494 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29495 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29496 COMMON/PYINT1/MINT(400),VINT(400)
29497 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29498 SAVE /PYDAT1/,/PYDAT2/,/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/
29499
29500C...Convert VVAR to tau variable.
29501 ISUB=MINT(1)
29502 ISTSB=ISET(ISUB)
29503 IF(IVAR.EQ.1) THEN
29504 TAUMIN=VINT(11)
29505 TAUMAX=VINT(31)
29506 IF(MVAR.EQ.3.OR.MVAR.EQ.4) THEN
29507 TAURE=VINT(73)
29508 GAMRE=VINT(74)
29509 ELSEIF(MVAR.EQ.5.OR.MVAR.EQ.6) THEN
29510 TAURE=VINT(75)
29511 GAMRE=VINT(76)
29512 ELSEIF(MVAR.EQ.8.OR.MVAR.EQ.9) THEN
29513 TAURE=VINT(77)
29514 GAMRE=VINT(78)
29515 ENDIF
29516 IF(MINT(47).EQ.1.AND.(ISTSB.EQ.1.OR.ISTSB.EQ.2)) THEN
29517 TAU=1D0
29518 ELSEIF(MVAR.EQ.1) THEN
29519 TAU=TAUMIN*(TAUMAX/TAUMIN)**VVAR
29520 ELSEIF(MVAR.EQ.2) THEN
29521 TAU=TAUMAX*TAUMIN/(TAUMIN+(TAUMAX-TAUMIN)*VVAR)
29522 ELSEIF(MVAR.EQ.3.OR.MVAR.EQ.5.OR.MVAR.EQ.8) THEN
29523 RATGEN=(TAURE+TAUMAX)/(TAURE+TAUMIN)*TAUMIN/TAUMAX
29524 TAU=TAURE*TAUMIN/((TAURE+TAUMIN)*RATGEN**VVAR-TAUMIN)
29525 ELSEIF(MVAR.EQ.4.OR.MVAR.EQ.6.OR.MVAR.EQ.9) THEN
29526 AUPP=ATAN((TAUMAX-TAURE)/GAMRE)
29527 ALOW=ATAN((TAUMIN-TAURE)/GAMRE)
29528 TAU=TAURE+GAMRE*TAN(ALOW+(AUPP-ALOW)*VVAR)
29529 ELSEIF(MINT(47).EQ.5) THEN
29530 AUPP=LOG(MAX(2D-10,1D0-TAUMAX))
29531 ALOW=LOG(MAX(2D-10,1D0-TAUMIN))
29532 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29533 ELSE
29534 AUPP=LOG(MAX(1D-10,1D0-TAUMAX))
29535 ALOW=LOG(MAX(1D-10,1D0-TAUMIN))
29536 TAU=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29537 ENDIF
29538 VINT(21)=MIN(TAUMAX,MAX(TAUMIN,TAU))
29539
29540C...Convert VVAR to y* variable.
29541 ELSEIF(IVAR.EQ.2) THEN
29542 YSTMIN=VINT(12)
29543 YSTMAX=VINT(32)
29544 TAUE=VINT(21)
29545 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=VINT(26)
29546 IF(MINT(47).EQ.1) THEN
29547 YST=0D0
29548 ELSEIF(MINT(47).EQ.2.OR.MINT(47).EQ.6) THEN
29549 YST=-0.5D0*LOG(TAUE)
29550 ELSEIF(MINT(47).EQ.3.OR.MINT(47).EQ.7) THEN
29551 YST=0.5D0*LOG(TAUE)
29552 ELSEIF(MVAR.EQ.1) THEN
29553 YST=YSTMIN+(YSTMAX-YSTMIN)*SQRT(VVAR)
29554 ELSEIF(MVAR.EQ.2) THEN
29555 YST=YSTMAX-(YSTMAX-YSTMIN)*SQRT(1D0-VVAR)
29556 ELSEIF(MVAR.EQ.3) THEN
29557 AUPP=ATAN(EXP(YSTMAX))
29558 ALOW=ATAN(EXP(YSTMIN))
29559 YST=LOG(TAN(ALOW+(AUPP-ALOW)*VVAR))
29560 ELSEIF(MVAR.EQ.4) THEN
29561 YST0=-0.5D0*LOG(TAUE)
29562 AUPP=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0))
29563 ALOW=LOG(MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
29564 YST=YST0-LOG(1D0+EXP(ALOW+VVAR*(AUPP-ALOW)))
29565 ELSE
29566 YST0=-0.5D0*LOG(TAUE)
29567 AUPP=LOG(MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
29568 ALOW=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0))
29569 YST=LOG(1D0+EXP(AUPP+VVAR*(ALOW-AUPP)))-YST0
29570 ENDIF
29571 VINT(22)=MIN(YSTMAX,MAX(YSTMIN,YST))
29572
29573C...Convert VVAR to cos(theta-hat) variable.
29574 ELSEIF(IVAR.EQ.3) THEN
29575 RM34=MAX(1D-20,2D0*VINT(63)*VINT(64)/(VINT(21)*VINT(2))**2)
29576 RSQM=1D0+RM34
29577 IF(2D0*VINT(71)**2/(VINT(21)*VINT(2)).LT.0.0001D0)
29578 & RM34=MAX(RM34,2D0*VINT(71)**2/(VINT(21)*VINT(2)))
29579 CTNMIN=VINT(13)
29580 CTNMAX=VINT(33)
29581 CTPMIN=VINT(14)
29582 CTPMAX=VINT(34)
29583 IF(MVAR.EQ.1) THEN
29584 ANEG=CTNMAX-CTNMIN
29585 APOS=CTPMAX-CTPMIN
29586 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29587 VCTN=VVAR*(ANEG+APOS)/ANEG
29588 CTH=CTNMIN+(CTNMAX-CTNMIN)*VCTN
29589 ELSE
29590 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29591 CTH=CTPMIN+(CTPMAX-CTPMIN)*VCTP
29592 ENDIF
29593 ELSEIF(MVAR.EQ.2) THEN
29594 RMNMIN=MAX(RM34,RSQM-CTNMIN)
29595 RMNMAX=MAX(RM34,RSQM-CTNMAX)
29596 RMPMIN=MAX(RM34,RSQM-CTPMIN)
29597 RMPMAX=MAX(RM34,RSQM-CTPMAX)
29598 ANEG=LOG(RMNMIN/RMNMAX)
29599 APOS=LOG(RMPMIN/RMPMAX)
29600 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29601 VCTN=VVAR*(ANEG+APOS)/ANEG
29602 CTH=RSQM-RMNMIN*(RMNMAX/RMNMIN)**VCTN
29603 ELSE
29604 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29605 CTH=RSQM-RMPMIN*(RMPMAX/RMPMIN)**VCTP
29606 ENDIF
29607 ELSEIF(MVAR.EQ.3) THEN
29608 RMNMIN=MAX(RM34,RSQM+CTNMIN)
29609 RMNMAX=MAX(RM34,RSQM+CTNMAX)
29610 RMPMIN=MAX(RM34,RSQM+CTPMIN)
29611 RMPMAX=MAX(RM34,RSQM+CTPMAX)
29612 ANEG=LOG(RMNMAX/RMNMIN)
29613 APOS=LOG(RMPMAX/RMPMIN)
29614 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29615 VCTN=VVAR*(ANEG+APOS)/ANEG
29616 CTH=RMNMIN*(RMNMAX/RMNMIN)**VCTN-RSQM
29617 ELSE
29618 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29619 CTH=RMPMIN*(RMPMAX/RMPMIN)**VCTP-RSQM
29620 ENDIF
29621 ELSEIF(MVAR.EQ.4) THEN
29622 RMNMIN=MAX(RM34,RSQM-CTNMIN)
29623 RMNMAX=MAX(RM34,RSQM-CTNMAX)
29624 RMPMIN=MAX(RM34,RSQM-CTPMIN)
29625 RMPMAX=MAX(RM34,RSQM-CTPMAX)
29626 ANEG=1D0/RMNMAX-1D0/RMNMIN
29627 APOS=1D0/RMPMAX-1D0/RMPMIN
29628 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29629 VCTN=VVAR*(ANEG+APOS)/ANEG
29630 CTH=RSQM-1D0/(1D0/RMNMIN+ANEG*VCTN)
29631 ELSE
29632 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29633 CTH=RSQM-1D0/(1D0/RMPMIN+APOS*VCTP)
29634 ENDIF
29635 ELSEIF(MVAR.EQ.5) THEN
29636 RMNMIN=MAX(RM34,RSQM+CTNMIN)
29637 RMNMAX=MAX(RM34,RSQM+CTNMAX)
29638 RMPMIN=MAX(RM34,RSQM+CTPMIN)
29639 RMPMAX=MAX(RM34,RSQM+CTPMAX)
29640 ANEG=1D0/RMNMIN-1D0/RMNMAX
29641 APOS=1D0/RMPMIN-1D0/RMPMAX
29642 IF(ANEG.GT.0D0.AND.VVAR*(ANEG+APOS).LE.ANEG) THEN
29643 VCTN=VVAR*(ANEG+APOS)/ANEG
29644 CTH=1D0/(1D0/RMNMIN-ANEG*VCTN)-RSQM
29645 ELSE
29646 VCTP=(VVAR*(ANEG+APOS)-ANEG)/APOS
29647 CTH=1D0/(1D0/RMPMIN-APOS*VCTP)-RSQM
29648 ENDIF
29649 ENDIF
29650 IF(CTH.LT.0D0) CTH=MIN(CTNMAX,MAX(CTNMIN,CTH))
29651 IF(CTH.GT.0D0) CTH=MIN(CTPMAX,MAX(CTPMIN,CTH))
29652 VINT(23)=CTH
29653
29654C...Convert VVAR to tau' variable.
29655 ELSEIF(IVAR.EQ.4) THEN
29656 TAU=VINT(21)
29657 TAUPMN=VINT(16)
29658 TAUPMX=VINT(36)
29659 IF(MINT(47).EQ.1) THEN
29660 TAUP=1D0
29661 ELSEIF(MVAR.EQ.1) THEN
29662 TAUP=TAUPMN*(TAUPMX/TAUPMN)**VVAR
29663 ELSEIF(MVAR.EQ.2) THEN
29664 AUPP=(1D0-TAU/TAUPMX)**4
29665 ALOW=(1D0-TAU/TAUPMN)**4
29666 TAUP=TAU/MAX(1D-10,1D0-(ALOW+(AUPP-ALOW)*VVAR)**0.25D0)
29667 ELSEIF(MINT(47).EQ.5) THEN
29668 AUPP=LOG(MAX(2D-10,1D0-TAUPMX))
29669 ALOW=LOG(MAX(2D-10,1D0-TAUPMN))
29670 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29671 ELSE
29672 AUPP=LOG(MAX(1D-10,1D0-TAUPMX))
29673 ALOW=LOG(MAX(1D-10,1D0-TAUPMN))
29674 TAUP=1D0-EXP(AUPP+VVAR*(ALOW-AUPP))
29675 ENDIF
29676 VINT(26)=MIN(TAUPMX,MAX(TAUPMN,TAUP))
29677
29678C...Selection of extra variables needed in 2 -> 3 process:
29679C...pT1, pT2, phi1, phi2, y3 for three outgoing particles.
29680C...Since no options are available, the functions of PYKLIM
29681C...and PYKMAP are joint for these choices.
29682 ELSEIF(IVAR.EQ.5) THEN
29683
29684C...Read out total energy and particle masses.
29685 MINT(51)=0
29686 MPTPK=1
29687 IF(ISUB.EQ.123.OR.ISUB.EQ.124.OR.ISUB.EQ.173.OR.ISUB.EQ.174
29688 & .OR.ISUB.EQ.178.OR.ISUB.EQ.179.OR.ISUB.EQ.351.OR.ISUB.EQ.352)
29689 & MPTPK=2
29690 SHP=VINT(26)*VINT(2)
29691 SHPR=SQRT(SHP)
29692 PM1=VINT(201)
29693 PM2=VINT(206)
29694 PM3=SQRT(VINT(21))*VINT(1)
29695 IF(PM1+PM2+PM3.GT.0.9999D0*SHPR) THEN
29696 MINT(51)=1
29697 RETURN
29698 ENDIF
29699 PMRS1=VINT(204)**2
29700 PMRS2=VINT(209)**2
29701
29702C...Specify coefficients of pT choice; upper and lower limits.
29703 IF(MPTPK.EQ.1) THEN
29704 HWT1=0.4D0
29705 HWT2=0.4D0
29706 ELSE
29707 HWT1=0.05D0
29708 HWT2=0.05D0
29709 ENDIF
29710 HWT3=1D0-HWT1-HWT2
29711 PTSMX1=((SHP-PM1**2-(PM2+PM3)**2)**2-(2D0*PM1*(PM2+PM3))**2)/
29712 & (4D0*SHP)
29713 IF(CKIN(52).GT.0D0) PTSMX1=MIN(PTSMX1,CKIN(52)**2)
29714 PTSMN1=CKIN(51)**2
29715 PTSMX2=((SHP-PM2**2-(PM1+PM3)**2)**2-(2D0*PM2*(PM1+PM3))**2)/
29716 & (4D0*SHP)
29717 IF(CKIN(54).GT.0D0) PTSMX2=MIN(PTSMX2,CKIN(54)**2)
29718 PTSMN2=CKIN(53)**2
29719
29720C...Select transverse momenta according to
29721C...dp_T^2 * (a + b/(M^2 + p_T^2) + c/(M^2 + p_T^2)^2).
29722 HMX=PMRS1+PTSMX1
29723 HMN=PMRS1+PTSMN1
29724 IF(HMX.LT.1.0001D0*HMN) THEN
29725 MINT(51)=1
29726 RETURN
29727 ENDIF
29728 HDE=PTSMX1-PTSMN1
29729 RPT=PYR(0)
29730 IF(RPT.LT.HWT1) THEN
29731 PTS1=PTSMN1+PYR(0)*HDE
29732 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29733 PTS1=MAX(PTSMN1,HMN*(HMX/HMN)**PYR(0)-PMRS1)
29734 ELSE
29735 PTS1=MAX(PTSMN1,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS1)
29736 ENDIF
29737 WTPTS1=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS1+PTS1))+
29738 & HWT3*HMN*HMX/(PMRS1+PTS1)**2)
29739 HMX=PMRS2+PTSMX2
29740 HMN=PMRS2+PTSMN2
29741 IF(HMX.LT.1.0001D0*HMN) THEN
29742 MINT(51)=1
29743 RETURN
29744 ENDIF
29745 HDE=PTSMX2-PTSMN2
29746 RPT=PYR(0)
29747 IF(RPT.LT.HWT1) THEN
29748 PTS2=PTSMN2+PYR(0)*HDE
29749 ELSEIF(RPT.LT.HWT1+HWT2) THEN
29750 PTS2=MAX(PTSMN2,HMN*(HMX/HMN)**PYR(0)-PMRS2)
29751 ELSE
29752 PTS2=MAX(PTSMN2,HMN*HMX/(HMN+PYR(0)*HDE)-PMRS2)
29753 ENDIF
29754 WTPTS2=HDE/(HWT1+HWT2*HDE/(LOG(HMX/HMN)*(PMRS2+PTS2))+
29755 & HWT3*HMN*HMX/(PMRS2+PTS2)**2)
29756
29757C...Select azimuthal angles and check pT choice.
29758 PHI1=PARU(2)*PYR(0)
29759 PHI2=PARU(2)*PYR(0)
29760 PHIR=PHI2-PHI1
29761 PTS3=MAX(0D0,PTS1+PTS2+2D0*SQRT(PTS1*PTS2)*COS(PHIR))
29762 IF(PTS3.LT.CKIN(55)**2.OR.(CKIN(56).GT.0D0.AND.PTS3.GT.
29763 & CKIN(56)**2)) THEN
29764 MINT(51)=1
29765 RETURN
29766 ENDIF
29767
29768C...Calculate transverse masses and check phase space not closed.
29769 PMS1=PM1**2+PTS1
29770 PMS2=PM2**2+PTS2
29771 PMS3=PM3**2+PTS3
29772 PMT1=SQRT(PMS1)
29773 PMT2=SQRT(PMS2)
29774 PMT3=SQRT(PMS3)
29775 PM12=(PMT1+PMT2)**2
29776 IF(PMT1+PMT2+PMT3.GT.0.9999D0*SHPR) THEN
29777 MINT(51)=1
29778 RETURN
29779 ENDIF
29780
29781C...Select rapidity for particle 3 and check phase space not closed.
29782 Y3MAX=LOG((SHP+PMS3-PM12+SQRT(MAX(0D0,(SHP-PMS3-PM12)**2-
29783 & 4D0*PMS3*PM12)))/(2D0*SHPR*PMT3))
29784 IF(Y3MAX.LT.1D-6) THEN
29785 MINT(51)=1
29786 RETURN
29787 ENDIF
29788 Y3=(2D0*PYR(0)-1D0)*0.999999D0*Y3MAX
29789 PZ3=PMT3*SINH(Y3)
29790 PE3=PMT3*COSH(Y3)
29791
29792C...Find momentum transfers in two mirror solutions (in 1-2 frame).
29793 PZ12=-PZ3
29794 PE12=SHPR-PE3
29795 PMS12=PE12**2-PZ12**2
29796 SQL12=SQRT(MAX(0D0,(PMS12-PMS1-PMS2)**2-4D0*PMS1*PMS2))
29797 IF(SQL12.LT.1D-6*SHP) THEN
29798 MINT(51)=1
29799 RETURN
29800 ENDIF
29801 PMM1=PMS12+PMS1-PMS2
29802 PMM2=PMS12+PMS2-PMS1
29803 TFAC=-SHPR/(2D0*PMS12)
29804 T1P=TFAC*(PE12-PZ12)*(PMM1-SQL12)
29805 T1N=TFAC*(PE12-PZ12)*(PMM1+SQL12)
29806 T2P=TFAC*(PE12+PZ12)*(PMM2-SQL12)
29807 T2N=TFAC*(PE12+PZ12)*(PMM2+SQL12)
29808
29809C...Construct relative mirror weights and make choice.
29810 IF(MPTPK.EQ.1.OR.ISUB.EQ.351.OR.ISUB.EQ.352) THEN
29811 WTPU=1D0
29812 WTNU=1D0
29813 ELSE
29814 WTPU=1D0/((T1P-PMRS1)*(T2P-PMRS2))**2
29815 WTNU=1D0/((T1N-PMRS1)*(T2N-PMRS2))**2
29816 ENDIF
29817 WTP=WTPU/(WTPU+WTNU)
29818 WTN=WTNU/(WTPU+WTNU)
29819 EPS=1D0
29820 IF(WTN.GT.PYR(0)) EPS=-1D0
29821
29822C...Store result of variable choice and associated weights.
29823 VINT(202)=PTS1
29824 VINT(207)=PTS2
29825 VINT(203)=PHI1
29826 VINT(208)=PHI2
29827 VINT(205)=WTPTS1
29828 VINT(210)=WTPTS2
29829 VINT(211)=Y3
29830 VINT(212)=Y3MAX
29831 VINT(213)=EPS
29832 IF(EPS.GT.0D0) THEN
29833 VINT(214)=1D0/WTP
29834 VINT(215)=T1P
29835 VINT(216)=T2P
29836 ELSE
29837 VINT(214)=1D0/WTN
29838 VINT(215)=T1N
29839 VINT(216)=T2N
29840 ENDIF
29841 VINT(217)=-0.5D0*TFAC*(PE12-PZ12)*(PMM2+EPS*SQL12)
29842 VINT(218)=-0.5D0*TFAC*(PE12+PZ12)*(PMM1+EPS*SQL12)
29843 VINT(219)=0.5D0*(PMS12-PTS3)
29844 VINT(220)=SQL12
29845 ENDIF
29846
29847 RETURN
29848 END
29849
29850C***********************************************************************
29851
29852C...PYSIGH
29853C...Differential matrix elements for all included subprocesses
29854C...Note that what is coded is (disregarding the COMFAC factor)
29855C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
29856C...when d(sigma-hat) is given in the zero-width limit, the delta
29857C...function in tau is replaced by a (modified) Breit-Wigner:
29858C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
29859C...where H_res = s-hat/m_res*Gamma_res(s-hat);
29860C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
29861C...i.e., dimensionless quantities
29862C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
29863C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
29864C...(2pi)^4 delta^4(P - sum p_i)
29865C...COMFAC contains the factor pi/s (or equivalent) and
29866C...the conversion factor from GeV^-2 to mb
29867
29868 SUBROUTINE PYSIGH(NCHN,SIGS)
29869
29870C...Double precision and integer declarations
29871 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
29872 IMPLICIT INTEGER(I-N)
29873 INTEGER PYK,PYCHGE,PYCOMP
29874C...Parameter statement to help give large particle numbers.
29875 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
29876 &KEXCIT=4000000,KDIMEN=5000000)
29877C...Commonblocks
29878 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
29879 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
29880 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
29881 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
29882 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
29883 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
29884 COMMON/PYINT1/MINT(400),VINT(400)
29885 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
29886 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
29887 COMMON/PYINT4/MWID(500),WIDS(500,5)
29888 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
29889 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
29890 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
29891 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
29892 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
29893 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
29894 COMMON/PYPUED/IUED(0:99),RUED(0:99)
29895 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
29896 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
29897 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
29898 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
29899 COMMON/PYTCCO/COEFX(194:380,2)
29900 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,
29901 &/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,/PYINT7/,
29902 &/PYMSSM/,/PYSSMT/,/PYTCSM/,/PYPUED/,/PYSGCM/,/PYTCCO/
29903C...Local arrays and complex variables
29904 DIMENSION XPQ(-25:25)
29905
29906C...Map of processes onto which routine to call
29907C...in order to evaluate cross section:
29908C...0 = not implemented;
29909C...1 = standard QCD (including photons);
29910C...2 = heavy flavours;
29911C...3 = W/Z;
29912C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
29913C...5 = SUSY;
29914C...6 = Technicolor;
29915C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
29916C...8 = Universal Extra Dimensions
29917 DIMENSION MAPPR(500)
29918 DATA (MAPPR(I),I=1,180)/
29919 & 3, 3, 4, 0, 4, 0, 0, 4, 0, 1,
29920 1 1, 1, 1, 1, 3, 3, 0, 1, 3, 3,
29921 2 0, 3, 3, 4, 3, 4, 0, 1, 1, 3,
29922 3 3, 4, 1, 1, 3, 3, 0, 0, 0, 0,
29923 4 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29924 5 0, 0, 1, 1, 0, 0, 0, 1, 0, 0,
29925 6 0, 0, 0, 0, 0, 0, 0, 1, 3, 3,
29926 7 4, 4, 4, 0, 0, 4, 4, 0, 0, 1,
29927 8 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29928 9 1, 1, 1, 1, 1, 1, 0, 0, 1, 0,
29929 & 0, 4, 4, 2, 2, 2, 2, 2, 0, 4,
29930 1 4, 4, 4, 1, 1, 0, 0, 0, 0, 0,
29931 2 4, 4, 4, 4, 0, 0, 0, 0, 0, 0,
29932 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
29933 4 7, 7, 4, 7, 7, 7, 7, 7, 6, 0,
29934 5 4, 4, 4, 0, 0, 4, 4, 4, 0, 0,
29935 6 4, 7, 7, 7, 6, 6, 7, 7, 7, 0,
29936 7 4, 4, 4, 4, 0, 4, 4, 4, 4, 0/
29937 DATA (MAPPR(I),I=181,500)/
29938 8 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
29939 9 6, 6, 6, 6, 6, 0, 0, 0, 0, 0,
29940 & 100*5,
29941 & 5, 0, 0, 0, 0, 0, 0, 0, 0, 0,
29942 & 8, 8, 8, 8, 8, 8, 8, 8, 8, 0,
29943 1 20*0,
29944 4 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
29945 5 7, 7, 7, 7, 0, 0, 0, 0, 0, 0,
29946 6 6, 6, 6, 6, 6, 6, 6, 6, 0, 6,
29947 7 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
29948 8 6, 6, 6, 6, 6, 6, 6, 6, 0, 0,
29949 9 7, 7, 7, 7, 7, 0, 0, 0, 0, 0,
29950 & 4, 4, 18*0,
29951 2 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29952 3 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29953 4 20*0,
29954 6 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
29955 7 2, 2, 2, 2, 2, 2, 2, 2, 2, 0,
29956 8 7, 7, 18*0/
29957
29958C...Reset number of channels and cross-section
29959 NCHN=0
29960 SIGS=0D0
29961
29962C...Read process to consider.
29963 ISUB=MINT(1)
29964 ISUBSV=ISUB
29965 MAP=MAPPR(ISUB)
29966
29967C...Read kinematical variables and limits
29968 ISTSB=ISET(ISUBSV)
29969 TAUMIN=VINT(11)
29970 YSTMIN=VINT(12)
29971 CTNMIN=VINT(13)
29972 CTPMIN=VINT(14)
29973 TAUPMN=VINT(16)
29974 TAU=VINT(21)
29975 YST=VINT(22)
29976 CTH=VINT(23)
29977 XT2=VINT(25)
29978 TAUP=VINT(26)
29979 TAUMAX=VINT(31)
29980 YSTMAX=VINT(32)
29981 CTNMAX=VINT(33)
29982 CTPMAX=VINT(34)
29983 TAUPMX=VINT(36)
29984
29985C...Derive kinematical quantities
29986 TAUE=TAU
29987 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
29988 X(1)=SQRT(TAUE)*EXP(YST)
29989 X(2)=SQRT(TAUE)*EXP(-YST)
29990 IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
29991 IF(X(1).GT.1D0-1D-7) RETURN
29992 ELSEIF(MINT(45).EQ.3) THEN
29993 X(1)=MIN(1D0-1.1D-10,X(1))
29994 ENDIF
29995 IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
29996 IF(X(2).GT.1D0-1D-7) RETURN
29997 ELSEIF(MINT(46).EQ.3) THEN
29998 X(2)=MIN(1D0-1.1D-10,X(2))
29999 ENDIF
30000 SH=MAX(1D0,TAU*VINT(2))
30001 SQM3=VINT(63)
30002 SQM4=VINT(64)
30003 RM3=SQM3/SH
30004 RM4=SQM4/SH
30005 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
30006 RPTS=4D0*VINT(71)**2/SH
30007 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
30008 RM34=MAX(1D-20,2D0*RM3*RM4)
30009 RSQM=1D0+RM34
30010 IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
30011 &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
30012 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
30013 IF(ISTSB.EQ.0) THEN
30014 TH=VINT(45)
30015 UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
30016 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
30017 ELSE
30018C...Kinematics with incoming masses tricky: now depends on how
30019C...subprocess has been set up w.r.t. order of incoming partons.
30020 RM1=0D0
30021 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
30022 RM2=0D0
30023 IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
30024 IF(ISUB.EQ.35) THEN
30025 RM2=MIN(RM1,RM2)
30026 RM1=0D0
30027 ENDIF
30028 BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
30029 TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
30030 TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
30031 & BE12*BE34*CTH)
30032 UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
30033 & BE12*BE34*CTH)
30034 SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
30035 ENDIF
30036 SHR=SQRT(SH)
30037 SH2=SH**2
30038 TH2=TH**2
30039 UH2=UH**2
30040
30041C...Choice of Q2 scale for hard process (e.g. alpha_s).
30042 IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
30043 Q2=SH
30044 ELSEIF(ISTSB.EQ.8) THEN
30045 IF(MINT(107).EQ.4) Q2=VINT(307)
30046 IF(MINT(108).EQ.4) Q2=VINT(308)
30047 ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
30048 Q2IN1=0D0
30049 IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
30050 Q2IN2=0D0
30051 IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
30052 IF(MSTP(32).EQ.1) THEN
30053 Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
30054 ELSEIF(MSTP(32).EQ.2) THEN
30055 Q2=SQPTH+0.5D0*(SQM3+SQM4)
30056 ELSEIF(MSTP(32).EQ.3) THEN
30057 Q2=MIN(-TH,-UH)
30058 ELSEIF(MSTP(32).EQ.4) THEN
30059 Q2=SH
30060 ELSEIF(MSTP(32).EQ.5) THEN
30061 Q2=-TH
30062 ELSEIF(MSTP(32).EQ.6) THEN
30063 XSF1=X(1)
30064 IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
30065 XSF2=X(2)
30066 IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
30067 Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
30068 & (SQPTH+0.5D0*(SQM3+SQM4))
30069 ELSEIF(MSTP(32).EQ.7) THEN
30070 Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
30071 ELSEIF(MSTP(32).EQ.8) THEN
30072 Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
30073 ELSEIF(MSTP(32).EQ.9) THEN
30074 Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
30075 ELSEIF(MSTP(32).EQ.10) THEN
30076 Q2=VINT(2)
30077C..Begin JA 040914
30078 ELSEIF(MSTP(32).EQ.11) THEN
30079 Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
30080 ELSEIF(MSTP(32).EQ.12) THEN
30081 Q2=PARP(193)
30082C..End JA
30083 ELSEIF(MSTP(32).EQ.13) THEN
30084 Q2=SQPTH
30085 ENDIF
30086 IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
30087 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
30088 & (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
30089 ENDIF
30090
30091C...Choice of Q2 scale for parton densities.
30092 Q2SF=Q2
30093C..Begin JA 040914
30094 IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
30095 & .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
30096 & Q2=PARP(194)
30097C..End JA
30098 IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
30099 Q2SF=PMAS(23,1)**2
30100 IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
30101 & ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
30102 IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
30103 IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
30104 & ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402) THEN
30105 Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
30106 IF(MSTP(39).EQ.2) Q2SF=
30107 & MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
30108 IF(MSTP(39).EQ.3) Q2SF=SH
30109 IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
30110 IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
30111C..Begin JA 040914
30112 IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
30113 IF(MSTP(39).EQ.7) Q2SF=
30114 & (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
30115 IF(MSTP(39).EQ.8) Q2SF=PARP(193)
30116C..End JA
30117 ENDIF
30118 ENDIF
30119 IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH
30120
30121 Q2PS=Q2SF
30122 Q2SF=Q2SF*PARP(34)
30123 IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
30124 IF(MSTP(69).GE.2) Q2SF=VINT(2)
30125
30126C...Identify to which class(es) subprocess belongs
30127 ISMECR=0
30128 ISQCD=0
30129 ISJETS=0
30130 IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
30131 & ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
30132 & ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
30133 & ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
30134 IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
30135 & ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
30136 IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
30137 IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
30138 IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
30139 IF (ISTSB.EQ.9) ISQCD=1
30140 IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
30141 & (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
30142 & ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
30143 & ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
30144 & (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
30145 & ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
30146 & ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
30147 & (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
30148C...WBF is special case of ISJETS
30149 IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
30150 & (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
30151 & ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
30152 & (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
30153 & ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
30154 & ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
30155 & ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
30156 & ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
30157 & ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
30158C...Some processes with photons also belong here.
30159 IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
30160 & (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
30161 & ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
30162 & ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
30163 & (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
30164 & (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3
30165
30166C...Choice of Q2 scale for parton-shower activity.
30167 IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
30168 &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
30169 XBJ=X(2)
30170 IF(MINT(43).EQ.3) XBJ=X(1)
30171 IF(MSTP(22).EQ.1) THEN
30172 Q2PS=-TH
30173 ELSEIF(MSTP(22).EQ.2) THEN
30174 Q2PS=((1D0-XBJ)/XBJ)*(-TH)
30175 ELSEIF(MSTP(22).EQ.3) THEN
30176 Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
30177 ELSE
30178 Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
30179 ENDIF
30180 ENDIF
30181C...For multiple interactions, start from scale defined above
30182C...For all other QCD or "+jets"-type events, start shower from pThard.
30183 IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
30184 IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
30185C...Max shower scale = s for ME corrected processes.
30186C...(pT-ordering: max pT2 is s/4)
30187 Q2PS=VINT(2)
30188 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
30189 ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
30190C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
30191C...(pT-ordering: max pT2 is s/4)
30192 Q2PS=VINT(2)
30193 IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
30194 ENDIF
30195 IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH
30196
30197C...Elastic and diffractive events not associated with scales so set 0.
30198 IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
30199 Q2SF=0D0
30200 Q2PS=0D0
30201 ENDIF
30202
30203C...Store derived kinematical quantities
30204 VINT(41)=X(1)
30205 VINT(42)=X(2)
30206 VINT(44)=SH
30207 VINT(43)=SQRT(SH)
30208 VINT(45)=TH
30209 VINT(46)=UH
30210 IF(ISTSB.NE.8) VINT(48)=SQPTH
30211 IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
30212 VINT(50)=TAUP*VINT(2)
30213 VINT(49)=SQRT(MAX(0D0,VINT(50)))
30214 VINT(52)=Q2
30215 VINT(51)=SQRT(Q2)
30216 VINT(54)=Q2SF
30217 VINT(53)=SQRT(Q2SF)
30218 VINT(56)=Q2PS
30219 VINT(55)=SQRT(Q2PS)
30220
30221C...Set starting scale for multiple interactions
30222 IF (ISUBSV.EQ.95) THEN
30223 XT2GMX=0D0
30224 ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
30225 & ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
30226 & ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
30227 & ISUBSV.NE.96)) THEN
30228C...All accessible phase space allowed.
30229 XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
30230 ELSE
30231C...Scale of hard process sets limit.
30232C...2 -> 1. Limit is tau = x1*x2.
30233C...2 -> 2. Limit is XT2 for hard process + FS masses.
30234C...2 -> n > 2. Limit is tau' = tau of outer process.
30235 XT2GMX=VINT(25)
30236 IF(ISTSB.EQ.1) XT2GMX=VINT(21)
30237 IF(ISTSB.EQ.2)
30238 & XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
30239 IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
30240 ENDIF
30241 VINT(62)=0.25D0*XT2GMX*VINT(2)
30242 VINT(61)=SQRT(MAX(0D0,VINT(62)))
30243
30244C...Calculate parton distributions
30245 IF(ISTSB.LE.0) GOTO 160
30246 IF(MINT(47).GE.2) THEN
30247 DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
30248 XSF=X(I)
30249 IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
30250 IF(ISUB.EQ.99) THEN
30251 IF(MINT(140+I).EQ.0) THEN
30252 XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
30253 ELSE
30254 XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
30255 ENDIF
30256 VINT(40+I)=XSF
30257 Q2SF=VINT(309-I)
30258 ENDIF
30259 MINT(105)=MINT(102+I)
30260 MINT(109)=MINT(106+I)
30261 VINT(120)=VINT(2+I)
30262C...Default is to use standard PDFs, but for interactions after the first
30263C...in the new multiple-parton-interactions framework, set which side to
30264C...evaluate the MPI-modified PDFs on.
30265 MINT(30)=0
30266 IF (MINT(31).GE.1) MINT(30)=I
30267C.... ALICE
30268C.... Store side in MINT(124)
30269 MINT(124) = I
30270C....
30271 IF(MSTP(57).LE.1) THEN
30272 CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
30273 ELSE
30274 CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
30275 ENDIF
30276C...Safety margin against heavy flavour very close to threshold,
30277C...e.g. caused by mismatch in c and b masses.
30278 IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
30279 XPQ(4)=0D0
30280 XPQ(-4)=0D0
30281 ENDIF
30282 IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
30283 XPQ(5)=0D0
30284 XPQ(-5)=0D0
30285 ENDIF
30286 DO 100 KFL=-25,25
30287 XSFX(I,KFL)=XPQ(KFL)
30288 100 CONTINUE
30289 110 CONTINUE
30290 ENDIF
30291
30292C...Calculate alpha_em, alpha_strong and K-factor
30293 XW=PARU(102)
30294 XWV=XW
30295 IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
30296 &1D0-(PMAS(24,1)/PMAS(23,1))**2
30297 XW1=1D0-XW
30298 XWC=1D0/(16D0*XW*XW1)
30299 AEM=PYALEM(Q2)
30300 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
30301 IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
30302 FACK=1D0
30303 FACA=1D0
30304 IF(MSTP(33).EQ.1) THEN
30305 FACK=PARP(31)
30306 ELSEIF(MSTP(33).EQ.2) THEN
30307 FACK=PARP(31)
30308 FACA=PARP(32)/PARP(31)
30309 ELSEIF(MSTP(33).EQ.3) THEN
30310 Q2AS=PARP(33)*Q2
30311 IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
30312 & PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
30313 AS=PYALPS(Q2AS)
30314C...PS (12 Feb 2010)
30315C...New options MSTP(33) = 10 and 11
30316C... 10: use K-factor = PARP(32) only for process 96 (MPI)
30317C... 11: as for 10, but also use K-factor = PARP(31) for other procs
30318 ELSEIF(MSTP(33).GE.10) THEN
30319 IF (ISUB.EQ.96) THEN
30320 FACK = PARP(32)
30321 ELSEIF (ISUB.NE.96.AND.MSTP(33).EQ.11) THEN
30322 FACK = PARP(31)
30323 ENDIF
30324 ENDIF
30325 VINT(138)=1D0
30326 VINT(57)=AEM
30327 VINT(58)=AS
30328
30329C...Set flags for allowed reacting partons/leptons
30330 DO 140 I=1,2
30331 DO 120 J=-25,25
30332 KFAC(I,J)=0
30333 120 CONTINUE
30334 IF(MINT(44+I).EQ.1) THEN
30335 KFAC(I,MINT(10+I))=1
30336 ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
30337 KFAC(I,MINT(10+I))=1
30338 KFAC(I,22)=1
30339 KFAC(I,24)=1
30340 KFAC(I,-24)=1
30341 ELSE
30342 DO 130 J=-25,25
30343 KFAC(I,J)=KFIN(I,J)
30344 IF(IABS(J).GT.MSTP(58).AND.IABS(J).LE.10) KFAC(I,J)=0
30345 IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
30346 130 CONTINUE
30347 ENDIF
30348 140 CONTINUE
30349
30350C...Lower and upper limit for fermion flavour loops
30351 MMIN1=0
30352 MMAX1=0
30353 MMIN2=0
30354 MMAX2=0
30355 DO 150 J=-20,20
30356 IF(KFAC(1,-J).EQ.1) MMIN1=-J
30357 IF(KFAC(1,J).EQ.1) MMAX1=J
30358 IF(KFAC(2,-J).EQ.1) MMIN2=-J
30359 IF(KFAC(2,J).EQ.1) MMAX2=J
30360 150 CONTINUE
30361 MMINA=MIN(MMIN1,MMIN2)
30362 MMAXA=MAX(MMAX1,MMAX2)
30363
30364C...Common resonance mass and width combinations
30365 SQMZ=PMAS(23,1)**2
30366 SQMW=PMAS(24,1)**2
30367 GMMZ=PMAS(23,1)*PMAS(23,2)
30368 GMMW=PMAS(24,1)*PMAS(24,2)
30369
30370C...Polarization factors...implemented so far for W+W-(25)
30371 POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
30372 POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
30373 POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
30374 POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))
30375
30376C...Phase space integral in tau
30377 COMFAC=PARU(1)*PARU(5)/VINT(2)
30378 IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
30379 IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
30380 &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
30381 ATAU1=LOG(TAUMAX/TAUMIN)
30382 ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
30383 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
30384 IF(MINT(72).GE.1) THEN
30385 TAUR1=VINT(73)
30386 GAMR1=VINT(74)
30387 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
30388 ATAU3=ATAUD/TAUR1
30389 IF(ATAUD.GT.1D-10) H1=H1+
30390 & (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
30391 ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
30392 ATAU4=ATAUD/GAMR1
30393 IF(ATAUD.GT.1D-10) H1=H1+
30394 & (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
30395 ENDIF
30396 IF(MINT(72).GE.2) THEN
30397 TAUR2=VINT(75)
30398 GAMR2=VINT(76)
30399 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
30400 ATAU5=ATAUD/TAUR2
30401 IF(ATAUD.GT.1D-10) H1=H1+
30402 & (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
30403 ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
30404 ATAU6=ATAUD/GAMR2
30405 IF(ATAUD.GT.1D-10) H1=H1+
30406 & (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
30407 ENDIF
30408 IF(MINT(72).EQ.3) THEN
30409 TAUR3=VINT(77)
30410 GAMR3=VINT(78)
30411 ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
30412 ATAU50=ATAUD/TAUR3
30413 IF(ATAUD.GT.1D-10) H1=H1+
30414 & (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
30415 ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
30416 ATAU60=ATAUD/GAMR3
30417 IF(ATAUD.GT.1D-10) H1=H1+
30418 & (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
30419 ENDIF
30420 IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
30421 ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
30422 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
30423 & MAX(2D-10,1D0-TAU)
30424 ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
30425 ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
30426 IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
30427 & MAX(1D-10,1D0-TAU)
30428 ENDIF
30429 COMFAC=COMFAC*ATAU1/(TAU*H1)
30430 ENDIF
30431
30432C...Phase space integral in y*
30433 IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
30434 &THEN
30435 AYST0=YSTMAX-YSTMIN
30436 IF(AYST0.LT.1D-10) THEN
30437 COMFAC=0D0
30438 ELSE
30439 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
30440 AYST2=AYST1
30441 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
30442 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
30443 & (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
30444 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
30445 IF(MINT(45).EQ.3) THEN
30446 YST0=-0.5D0*LOG(TAUE)
30447 AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
30448 & MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
30449 IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
30450 & MAX(1D-10,1D0-EXP(YST-YST0))
30451 ENDIF
30452 IF(MINT(46).EQ.3) THEN
30453 YST0=-0.5D0*LOG(TAUE)
30454 AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
30455 & MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
30456 IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
30457 & MAX(1D-10,1D0-EXP(-YST-YST0))
30458 ENDIF
30459 COMFAC=COMFAC*AYST0/H2
30460 ENDIF
30461 ENDIF
30462
30463C...2 -> 1 processes: reduction in angular part of phase space integral
30464C...for case of decaying resonance
30465 ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
30466 IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
30467 IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
30468 IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
30469 & KFPR(ISUB,1).EQ.39) THEN
30470 COMFAC=COMFAC*0.5D0*ACTH0
30471 ELSE
30472 COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
30473 & CTPMAX**3-CTPMIN**3)
30474 ENDIF
30475 ENDIF
30476
30477C...2 -> 2 processes: angular part of phase space integral
30478 ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
30479 ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
30480 & (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
30481 ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
30482 & (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
30483 ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
30484 & 1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
30485 ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
30486 & 1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
30487 H3=COEF(ISUBSV,13)+
30488 & (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
30489 & (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
30490 & (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
30491 & (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
30492 COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3
30493
30494C...2 -> 2 processes: take into account final state Breit-Wigners
30495 COMFAC=COMFAC*VINT(80)
30496 ENDIF
30497
30498C...2 -> 3, 4 processes: phace space integral in tau'
30499 IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
30500 ATAUP1=LOG(TAUPMX/TAUPMN)
30501 ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
30502 H4=COEF(ISUBSV,18)+
30503 & (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
30504 IF(MINT(47).EQ.5) THEN
30505 ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
30506 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
30507 ELSEIF(MINT(47).GE.6) THEN
30508 ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
30509 H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
30510 ENDIF
30511 COMFAC=COMFAC*ATAUP1/H4
30512 ENDIF
30513
30514C...2 -> 3, 4 processes: effective W/Z parton distributions
30515 IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
30516 IF(1D0-TAU/TAUP.GT.1D-4) THEN
30517 FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
30518 ELSE
30519 FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
30520 ENDIF
30521 COMFAC=COMFAC*FZW
30522 ENDIF
30523
30524C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
30525 IF(ISTSB.EQ.5) THEN
30526 COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
30527 & (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
30528 ENDIF
30529
30530C...Phase space integral for low-pT and multiple interactions
30531 IF(ISTSB.EQ.9) THEN
30532 COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
30533 ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
30534 ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
30535 H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
30536 COMFAC=COMFAC*ATAU1/H1
30537 AYST0=YSTMAX-YSTMIN
30538 AYST1=0.5D0*(YSTMAX-YSTMIN)**2
30539 AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
30540 H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
30541 & (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
30542 & (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
30543 COMFAC=COMFAC*AYST0/H2
30544 IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
30545C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
30546C...introduced to make cross-section finite for xT2 -> 0
30547 IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
30548 & (1D0+VINT(149)))
30549 ENDIF
30550
30551C...Real gamma + gamma: include factor 2 when different nature
30552 160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
30553 &MSTP(14).LE.10) COMFAC=2D0*COMFAC
30554
30555C...Extra factors to include the effects of
30556C...longitudinal resolved photons (but not direct or DIS ones).
30557 DO 170 ISDE=1,2
30558 IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
30559 & MINT(106+ISDE).LE.3) THEN
30560 VINT(314+ISDE)=1D0
30561 XY=PARP(166+ISDE)
30562 IF(MSTP(16).EQ.0) THEN
30563 IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
30564 & XY=VINT(304+ISDE)
30565 ELSE
30566 IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
30567 & XY=VINT(308+ISDE)
30568 ENDIF
30569 Q2GA=VINT(306+ISDE)
30570 IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
30571 & Q2GA.GT.0D0) THEN
30572 REDUCE=0D0
30573 IF(MSTP(17).EQ.1) THEN
30574 REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
30575 ELSEIF(MSTP(17).EQ.2) THEN
30576 REDUCE=4D0*Q2GA/(Q2+Q2GA)
30577 ELSEIF(MSTP(17).EQ.3) THEN
30578 PMVIRT=PMAS(PYCOMP(113),1)
30579 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
30580 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
30581 PMVIRT=PMAS(PYCOMP(113),1)
30582 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
30583 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
30584 PMVIRT=PMAS(PYCOMP(113),1)
30585 REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
30586 ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
30587 PMVSMN=4D0*PARP(15)**2
30588 PMVSMX=4D0*VINT(154)**2
30589 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
30590 REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
30591 & (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
30592 REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
30593 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
30594 PMVIRT=PMAS(PYCOMP(113),1)
30595 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
30596 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
30597 PMVIRT=PMAS(PYCOMP(113),1)
30598 REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
30599 ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
30600 PMVSMN=4D0*PARP(15)**2
30601 PMVSMX=4D0*VINT(154)**2
30602 REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
30603 REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
30604 REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
30605 ENDIF
30606 BEAMAS=PYMASS(11)
30607 IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
30608 FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
30609 & (1D0-2D0*BEAMAS**2/Q2GA))
30610 VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
30611 ENDIF
30612 ELSE
30613 VINT(314+ISDE)=1D0
30614 ENDIF
30615 COMFAC=COMFAC*VINT(314+ISDE)
30616 170 CONTINUE
30617
30618C...Evaluate cross sections - done in separate routines by kind
30619C...of physics, to keep PYSIGH of sensible size.
30620 IF(MAP.EQ.1) THEN
30621C...Standard QCD (including photons).
30622 CALL PYSGQC(NCHN,SIGS)
30623 ELSEIF(MAP.EQ.2) THEN
30624C...Heavy flavours.
30625 CALL PYSGHF(NCHN,SIGS)
30626 ELSEIF(MAP.EQ.3) THEN
30627C...W/Z.
30628 CALL PYSGWZ(NCHN,SIGS)
30629 ELSEIF(MAP.EQ.4) THEN
30630C...Higgs (2 doublets; including longitudinal W/Z scattering).
30631 CALL PYSGHG(NCHN,SIGS)
30632 ELSEIF(MAP.EQ.5) THEN
30633C...SUSY.
30634 CALL PYSGSU(NCHN,SIGS)
30635 ELSEIF(MAP.EQ.6) THEN
30636C...Technicolor.
30637 CALL PYSGTC(NCHN,SIGS)
30638 ELSEIF(MAP.EQ.7) THEN
30639C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
30640 CALL PYSGEX(NCHN,SIGS)
30641 ELSEIF(MAP.EQ.8) THEN
30642C... Universal Extra Dimensions
30643 CALL PYXUED(NCHN,SIGS)
30644 ENDIF
30645
30646C...Multiply with parton distributions
30647 IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
30648 DO 180 ICHN=1,NCHN
30649 IF(MINT(45).GE.2) THEN
30650 KFL1=ISIG(ICHN,1)
30651 SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
30652 ENDIF
30653 IF(MINT(46).GE.2) THEN
30654 KFL2=ISIG(ICHN,2)
30655 SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
30656 ENDIF
30657 SIGS=SIGS+SIGH(ICHN)
30658 180 CONTINUE
30659 ENDIF
30660
30661 RETURN
30662 END
30663
30664C*********************************************************************
30665
30666C...PYSGQC
30667C...Subprocess cross sections for QCD processes,
30668C...including photons.
30669C...Auxiliary to PYSIGH.
30670
30671 SUBROUTINE PYSGQC(NCHN,SIGS)
30672
30673C...Double precision and integer declarations
30674 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
30675 IMPLICIT INTEGER(I-N)
30676 INTEGER PYK,PYCHGE,PYCOMP
30677C...Parameter statement to help give large particle numbers.
30678 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
30679 &KEXCIT=4000000,KDIMEN=5000000)
30680C...Commonblocks
30681 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
30682 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
30683 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
30684 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
30685 COMMON/PYINT1/MINT(400),VINT(400)
30686 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
30687 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
30688 COMMON/PYINT4/MWID(500),WIDS(500,5)
30689 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
30690 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
30691 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
30692 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
30693 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
30694 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
30695 &/PYINT3/,/PYINT4/,/PYINT7/,/PYSGCM/
30696C...Local arrays
30697 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
30698
30699C...Differential cross section expressions.
30700
30701 IF(ISUB.LE.20) THEN
30702 IF(ISUB.EQ.10) THEN
30703C...f + f' -> f + f' (gamma/Z/W exchange)
30704 FACGGF=COMFAC*AEM**2*2D0*(SH2+UH2)/TH2
30705 FACGZF=COMFAC*AEM**2*XWC*4D0*SH2/(TH*(TH-SQMZ))
30706 FACZZF=COMFAC*(AEM*XWC)**2*2D0*SH2/(TH-SQMZ)**2
30707 FACWWF=COMFAC*(0.5D0*AEM/XW)**2*SH2/(TH-SQMW)**2
30708 DO 110 I=MMIN1,MMAX1
30709 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 110
30710 IA=IABS(I)
30711 DO 100 J=MMIN2,MMAX2
30712 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 100
30713 JA=IABS(J)
30714C...Electroweak couplings
30715 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
30716 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
30717 VI=AI-4D0*EI*XWV
30718 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
30719 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
30720 VJ=AJ-4D0*EJ*XWV
30721 EPSIJ=ISIGN(1,I*J)
30722C...gamma/Z exchange, only gamma exchange, or only Z exchange
30723 IF(MSTP(21).GE.1.AND.MSTP(21).LE.4) THEN
30724 IF(MSTP(21).EQ.1.OR.MSTP(21).EQ.4) THEN
30725 FACNCF=FACGGF*EI**2*EJ**2+FACGZF*EI*EJ*
30726 & (VI*VJ*(1D0+UH2/SH2)+AI*AJ*EPSIJ*(1D0-UH2/SH2))+
30727 & FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*(1D0+UH2/SH2)+
30728 & 4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30729 ELSEIF(MSTP(21).EQ.2) THEN
30730 FACNCF=FACGGF*EI**2*EJ**2
30731 ELSE
30732 FACNCF=FACZZF*((VI**2+AI**2)*(VJ**2+AJ**2)*
30733 & (1D0+UH2/SH2)+4D0*VI*VJ*AI*AJ*EPSIJ*(1D0-UH2/SH2))
30734 ENDIF
30735C...Extrafactor 2 for only one incoming neutrino spin state.
30736 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACNCF=2D0*FACNCF
30737 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACNCF=2D0*FACNCF
30738 NCHN=NCHN+1
30739 ISIG(NCHN,1)=I
30740 ISIG(NCHN,2)=J
30741 ISIG(NCHN,3)=1
30742 SIGH(NCHN)=FACNCF
30743 ENDIF
30744C...W exchange
30745 IF((MSTP(21).EQ.1.OR.MSTP(21).EQ.5).AND.AI*AJ.LT.0D0) THEN
30746 FACCCF=FACWWF*VINT(180+I)*VINT(180+J)
30747 IF(EPSIJ.LT.0D0) FACCCF=FACCCF*UH2/SH2
30748 IF(IA.GT.10.AND.MOD(IA,2).EQ.0) FACCCF=2D0*FACCCF
30749 IF(JA.GT.10.AND.MOD(JA,2).EQ.0) FACCCF=2D0*FACCCF
30750 NCHN=NCHN+1
30751 ISIG(NCHN,1)=I
30752 ISIG(NCHN,2)=J
30753 ISIG(NCHN,3)=2
30754 SIGH(NCHN)=FACCCF
30755 ENDIF
30756 100 CONTINUE
30757 110 CONTINUE
30758
30759 ELSEIF(ISUB.EQ.11) THEN
30760C...f + f' -> f + f' (g exchange)
30761 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
30762 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
30763 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
30764 FACQQ2=COMFAC*AS**2*4D0/9D0*((SH2+TH2)/UH2-
30765 & MSTP(34)*2D0/3D0*SH2/(TH*UH))
30766 DO 130 I=MMIN1,MMAX1
30767 IA=IABS(I)
30768 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 130
30769 DO 120 J=MMIN2,MMAX2
30770 JA=IABS(J)
30771 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 120
30772 NCHN=NCHN+1
30773 ISIG(NCHN,1)=I
30774 ISIG(NCHN,2)=J
30775 ISIG(NCHN,3)=1
30776 SIGH(NCHN)=FACQQ1
30777 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
30778 IF(I.EQ.J) THEN
30779 SIGH(NCHN)=0.5D0*SIGH(NCHN)
30780 NCHN=NCHN+1
30781 ISIG(NCHN,1)=I
30782 ISIG(NCHN,2)=J
30783 ISIG(NCHN,3)=2
30784 SIGH(NCHN)=0.5D0*FACQQ2
30785 ENDIF
30786 120 CONTINUE
30787 130 CONTINUE
30788
30789 ELSEIF(ISUB.EQ.12) THEN
30790C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
30791 CALL PYWIDT(21,SH,WDTP,WDTE)
30792 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
30793 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
30794 DO 140 I=MMINA,MMAXA
30795 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30796 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
30797 NCHN=NCHN+1
30798 ISIG(NCHN,1)=I
30799 ISIG(NCHN,2)=-I
30800 ISIG(NCHN,3)=1
30801 SIGH(NCHN)=FACQQB
30802 140 CONTINUE
30803
30804 ELSEIF(ISUB.EQ.13) THEN
30805C...f + fbar -> g + g (q + qbar -> g + g only)
30806 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30807 & UH2/SH2)
30808 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30809 & TH2/SH2)
30810 DO 150 I=MMINA,MMAXA
30811 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30812 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
30813 NCHN=NCHN+1
30814 ISIG(NCHN,1)=I
30815 ISIG(NCHN,2)=-I
30816 ISIG(NCHN,3)=1
30817 SIGH(NCHN)=0.5D0*FACGG1
30818 NCHN=NCHN+1
30819 ISIG(NCHN,1)=I
30820 ISIG(NCHN,2)=-I
30821 ISIG(NCHN,3)=2
30822 SIGH(NCHN)=0.5D0*FACGG2
30823 150 CONTINUE
30824
30825 ELSEIF(ISUB.EQ.14) THEN
30826C...f + fbar -> g + gamma (q + qbar -> g + gamma only)
30827 FACGG=COMFAC*AS*AEM*8D0/9D0*(TH2+UH2)/(TH*UH)
30828 DO 160 I=MMINA,MMAXA
30829 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
30830 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
30831 EI=KCHG(IABS(I),1)/3D0
30832 NCHN=NCHN+1
30833 ISIG(NCHN,1)=I
30834 ISIG(NCHN,2)=-I
30835 ISIG(NCHN,3)=1
30836 SIGH(NCHN)=FACGG*EI**2
30837 160 CONTINUE
30838
30839 ELSEIF(ISUB.EQ.18) THEN
30840C...f + fbar -> gamma + gamma
30841 FACGG=COMFAC*AEM**2*2D0*(TH2+UH2)/(TH*UH)
30842 DO 170 I=MMINA,MMAXA
30843 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 170
30844 EI=KCHG(IABS(I),1)/3D0
30845 FCOI=1D0
30846 IF(IABS(I).LE.10) FCOI=FACA/3D0
30847 NCHN=NCHN+1
30848 ISIG(NCHN,1)=I
30849 ISIG(NCHN,2)=-I
30850 ISIG(NCHN,3)=1
30851 SIGH(NCHN)=0.5D0*FACGG*FCOI*EI**4
30852 170 CONTINUE
30853 ENDIF
30854
30855 ELSEIF(ISUB.LE.40) THEN
30856 IF(ISUB.EQ.28) THEN
30857C...f + g -> f + g (q + g -> q + g only)
30858 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
30859 & UH/SH)*FACA
30860 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
30861 & SH/UH)
30862 DO 190 I=MMINA,MMAXA
30863 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
30864 DO 180 ISDE=1,2
30865 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
30866 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
30867 NCHN=NCHN+1
30868 ISIG(NCHN,ISDE)=I
30869 ISIG(NCHN,3-ISDE)=21
30870 ISIG(NCHN,3)=1
30871 SIGH(NCHN)=FACQG1
30872 NCHN=NCHN+1
30873 ISIG(NCHN,ISDE)=I
30874 ISIG(NCHN,3-ISDE)=21
30875 ISIG(NCHN,3)=2
30876 SIGH(NCHN)=FACQG2
30877 180 CONTINUE
30878 190 CONTINUE
30879
30880 ELSEIF(ISUB.EQ.29) THEN
30881C...f + g -> f + gamma (q + g -> q + gamma only)
30882 FGQ=COMFAC*FACA*AS*AEM*1D0/3D0*(SH2+UH2)/(-SH*UH)
30883 DO 210 I=MMINA,MMAXA
30884 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 210
30885 EI=KCHG(IABS(I),1)/3D0
30886 FACGQ=FGQ*EI**2
30887 DO 200 ISDE=1,2
30888 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 200
30889 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 200
30890 NCHN=NCHN+1
30891 ISIG(NCHN,ISDE)=I
30892 ISIG(NCHN,3-ISDE)=21
30893 ISIG(NCHN,3)=1
30894 SIGH(NCHN)=FACGQ
30895 200 CONTINUE
30896 210 CONTINUE
30897
30898 ELSEIF(ISUB.EQ.33) THEN
30899C...f + gamma -> f + g (q + gamma -> q + g only)
30900 FGQ=COMFAC*AS*AEM*8D0/3D0*(SH2+UH2)/(-SH*UH)
30901 DO 230 I=MMINA,MMAXA
30902 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 230
30903 EI=KCHG(IABS(I),1)/3D0
30904 FACGQ=FGQ*EI**2
30905 DO 220 ISDE=1,2
30906 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 220
30907 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 220
30908 NCHN=NCHN+1
30909 ISIG(NCHN,ISDE)=I
30910 ISIG(NCHN,3-ISDE)=22
30911 ISIG(NCHN,3)=1
30912 SIGH(NCHN)=FACGQ
30913 220 CONTINUE
30914 230 CONTINUE
30915
30916 ELSEIF(ISUB.EQ.34) THEN
30917C...f + gamma -> f + gamma
30918 FGQ=COMFAC*AEM**2*2D0*(SH2+UH2)/(-SH*UH)
30919 DO 250 I=MMINA,MMAXA
30920 IF(I.EQ.0) GOTO 250
30921 EI=KCHG(IABS(I),1)/3D0
30922 FACGQ=FGQ*EI**4
30923 DO 240 ISDE=1,2
30924 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 240
30925 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 240
30926 NCHN=NCHN+1
30927 ISIG(NCHN,ISDE)=I
30928 ISIG(NCHN,3-ISDE)=22
30929 ISIG(NCHN,3)=1
30930 SIGH(NCHN)=FACGQ
30931 240 CONTINUE
30932 250 CONTINUE
30933 ENDIF
30934
30935 ELSEIF(ISUB.LE.80) THEN
30936 IF(ISUB.EQ.53) THEN
30937C...g + g -> f + fbar (g + g -> q + qbar only)
30938 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 270
30939 IDC0=MDCY(21,2)-1
30940C...Begin by d, u, s flavours.
30941 FLAVWT=0D0
30942 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
30943 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
30944 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
30945 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
30946 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
30947 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
30948 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
30949 & UH2/SH2)*FLAVWT*FACA
30950 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
30951 & TH2/SH2)*FLAVWT*FACA
30952 NCHN=NCHN+1
30953 ISIG(NCHN,1)=21
30954 ISIG(NCHN,2)=21
30955 ISIG(NCHN,3)=1
30956 SIGH(NCHN)=FACQQ1
30957 NCHN=NCHN+1
30958 ISIG(NCHN,1)=21
30959 ISIG(NCHN,2)=21
30960 ISIG(NCHN,3)=2
30961 SIGH(NCHN)=FACQQ2
30962C...Next c and b flavours: modified that and uhat for fixed
30963C...cos(theta-hat).
30964 DO 260 IFL=4,5
30965 SQMAVG=PMAS(IFL,1)**2
30966 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
30967 BE34=SQRT(1D0-4D0*SQMAVG/SH)
30968 THQ=-0.5D0*SH*(1D0-BE34*CTH)
30969 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
30970 THUHQ=THQ*UHQ-SQMAVG*SH
30971 IF(MSTP(34).EQ.0) THEN
30972 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
30973 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
30974 ELSE
30975 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30976 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
30977 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
30978 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
30979 ENDIF
30980 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
30981 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
30982 NCHN=NCHN+1
30983 ISIG(NCHN,1)=21
30984 ISIG(NCHN,2)=21
30985 ISIG(NCHN,3)=1+2*(IFL-3)
30986 SIGH(NCHN)=FACQQ1
30987 NCHN=NCHN+1
30988 ISIG(NCHN,1)=21
30989 ISIG(NCHN,2)=21
30990 ISIG(NCHN,3)=2+2*(IFL-3)
30991 SIGH(NCHN)=FACQQ2
30992 ENDIF
30993 260 CONTINUE
30994 270 CONTINUE
30995
30996 ELSEIF(ISUB.EQ.54) THEN
30997C...g + gamma -> f + fbar (g + gamma -> q + qbar only)
30998 CALL PYWIDT(21,SH,WDTP,WDTE)
30999 WDTESU=0D0
31000 DO 280 I=1,MIN(8,MDCY(21,3))
31001 EF=KCHG(I,1)/3D0
31002 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
31003 & WDTE(I,4))
31004 280 CONTINUE
31005 FACQQ=COMFAC*AEM*AS*WDTESU*(TH2+UH2)/(TH*UH)
31006 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31007 NCHN=NCHN+1
31008 ISIG(NCHN,1)=21
31009 ISIG(NCHN,2)=22
31010 ISIG(NCHN,3)=1
31011 SIGH(NCHN)=FACQQ
31012 ENDIF
31013 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31014 NCHN=NCHN+1
31015 ISIG(NCHN,1)=22
31016 ISIG(NCHN,2)=21
31017 ISIG(NCHN,3)=1
31018 SIGH(NCHN)=FACQQ
31019 ENDIF
31020
31021 ELSEIF(ISUB.EQ.58) THEN
31022C...gamma + gamma -> f + fbar
31023 CALL PYWIDT(22,SH,WDTP,WDTE)
31024 WDTESU=0D0
31025 DO 290 I=1,MIN(12,MDCY(22,3))
31026 IF(I.LE.8) EF= KCHG(I,1)/3D0
31027 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
31028 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
31029 & WDTE(I,4))
31030 290 CONTINUE
31031 FACFF=COMFAC*AEM**2*WDTESU*2D0*(TH2+UH2)/(TH*UH)
31032 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31033 NCHN=NCHN+1
31034 ISIG(NCHN,1)=22
31035 ISIG(NCHN,2)=22
31036 ISIG(NCHN,3)=1
31037 SIGH(NCHN)=FACFF
31038 ENDIF
31039
31040 ELSEIF(ISUB.EQ.68) THEN
31041C...g + g -> g + g
31042 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 300
31043 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+2D0*TH/SH+
31044 & TH2/SH2)*FACA
31045 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+2D0*SH/UH+
31046 & SH2/UH2)*FACA
31047 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+2D0*UH/TH+
31048 & UH2/TH2)
31049 NCHN=NCHN+1
31050 ISIG(NCHN,1)=21
31051 ISIG(NCHN,2)=21
31052 ISIG(NCHN,3)=1
31053 SIGH(NCHN)=0.5D0*FACGG1
31054 NCHN=NCHN+1
31055 ISIG(NCHN,1)=21
31056 ISIG(NCHN,2)=21
31057 ISIG(NCHN,3)=2
31058 SIGH(NCHN)=0.5D0*FACGG2
31059 NCHN=NCHN+1
31060 ISIG(NCHN,1)=21
31061 ISIG(NCHN,2)=21
31062 ISIG(NCHN,3)=3
31063 SIGH(NCHN)=0.5D0*FACGG3
31064 300 CONTINUE
31065
31066 ELSEIF(ISUB.EQ.80) THEN
31067C...q + gamma -> q' + pi+/-
31068 FQPI=COMFAC*(2D0*AEM/9D0)*(-SH/TH)*(1D0/SH2+1D0/TH2)
31069 ASSH=PYALPS(MAX(0.5D0,0.5D0*SH))
31070 Q2FPSH=0.55D0/LOG(MAX(2D0,2D0*SH))
31071 DELSH=UH*SQRT(ASSH*Q2FPSH)
31072 ASUH=PYALPS(MAX(0.5D0,-0.5D0*UH))
31073 Q2FPUH=0.55D0/LOG(MAX(2D0,-2D0*UH))
31074 DELUH=SH*SQRT(ASUH*Q2FPUH)
31075 DO 320 I=MAX(-2,MMINA),MIN(2,MMAXA)
31076 IF(I.EQ.0) GOTO 320
31077 EI=KCHG(IABS(I),1)/3D0
31078 EJ=SIGN(1D0-ABS(EI),EI)
31079 DO 310 ISDE=1,2
31080 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 310
31081 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 310
31082 NCHN=NCHN+1
31083 ISIG(NCHN,ISDE)=I
31084 ISIG(NCHN,3-ISDE)=22
31085 ISIG(NCHN,3)=1
31086 SIGH(NCHN)=FQPI*(EI*DELSH+EJ*DELUH)**2
31087 310 CONTINUE
31088 320 CONTINUE
31089 ENDIF
31090
31091 ELSEIF(ISUB.LE.100) THEN
31092 IF(ISUB.EQ.91) THEN
31093C...Elastic scattering
31094 SIGS=VINT(315)*VINT(316)*SIGT(0,0,1)
31095
31096 ELSEIF(ISUB.EQ.92) THEN
31097C...Single diffractive scattering (first side, i.e. XB)
31098 SIGS=VINT(315)*VINT(316)*SIGT(0,0,2)
31099
31100 ELSEIF(ISUB.EQ.93) THEN
31101C...Single diffractive scattering (second side, i.e. AX)
31102 SIGS=VINT(315)*VINT(316)*SIGT(0,0,3)
31103
31104 ELSEIF(ISUB.EQ.94) THEN
31105C...Double diffractive scattering
31106 SIGS=VINT(315)*VINT(316)*SIGT(0,0,4)
31107
31108 ELSEIF(ISUB.EQ.95) THEN
31109C...Low-pT scattering
31110 SIGS=VINT(315)*VINT(316)*SIGT(0,0,5)
31111
31112 ELSEIF(ISUB.EQ.96) THEN
31113C...Multiple interactions: sum of QCD processes
31114 CALL PYWIDT(21,SH,WDTP,WDTE)
31115
31116C...q + q' -> q + q'
31117 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)/TH2
31118 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)/TH2*FACA-
31119 & MSTP(34)*2D0/3D0*UH2/(SH*TH))
31120 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)/UH2
31121 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
31122 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
31123 DO 340 I=-5,5
31124 IF(I.EQ.0) GOTO 340
31125 DO 330 J=-5,5
31126 IF(J.EQ.0) GOTO 330
31127 NCHN=NCHN+1
31128 ISIG(NCHN,1)=I
31129 ISIG(NCHN,2)=J
31130 ISIG(NCHN,3)=111
31131 SIGH(NCHN)=FACQQ1
31132 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
31133 IF(I.EQ.J) THEN
31134 SIGH(NCHN)=0.5D0*FACQQ1*RATQQI
31135 NCHN=NCHN+1
31136 ISIG(NCHN,1)=I
31137 ISIG(NCHN,2)=J
31138 ISIG(NCHN,3)=112
31139 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
31140 ENDIF
31141 330 CONTINUE
31142 340 CONTINUE
31143
31144C...q + qbar -> q' + qbar' or g + g
31145 FACQQB=COMFAC*AS**2*4D0/9D0*(TH2+UH2)/SH2*
31146 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,3)+WDTE(0,4))
31147 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
31148 & UH2/SH2)
31149 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
31150 & TH2/SH2)
31151 DO 350 I=-5,5
31152 IF(I.EQ.0) GOTO 350
31153 NCHN=NCHN+1
31154 ISIG(NCHN,1)=I
31155 ISIG(NCHN,2)=-I
31156 ISIG(NCHN,3)=121
31157 SIGH(NCHN)=FACQQB
31158 NCHN=NCHN+1
31159 ISIG(NCHN,1)=I
31160 ISIG(NCHN,2)=-I
31161 ISIG(NCHN,3)=131
31162 SIGH(NCHN)=0.5D0*FACGG1
31163 NCHN=NCHN+1
31164 ISIG(NCHN,1)=I
31165 ISIG(NCHN,2)=-I
31166 ISIG(NCHN,3)=132
31167 SIGH(NCHN)=0.5D0*FACGG2
31168 350 CONTINUE
31169
31170C...q + g -> q + g
31171 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
31172 & UH/SH)*FACA
31173 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
31174 & SH/UH)
31175 DO 370 I=-5,5
31176 IF(I.EQ.0) GOTO 370
31177 DO 360 ISDE=1,2
31178 NCHN=NCHN+1
31179 ISIG(NCHN,ISDE)=I
31180 ISIG(NCHN,3-ISDE)=21
31181 ISIG(NCHN,3)=281
31182 SIGH(NCHN)=FACQG1
31183 NCHN=NCHN+1
31184 ISIG(NCHN,ISDE)=I
31185 ISIG(NCHN,3-ISDE)=21
31186 ISIG(NCHN,3)=282
31187 SIGH(NCHN)=FACQG2
31188 360 CONTINUE
31189 370 CONTINUE
31190
31191C...g + g -> q + qbar (only d, u, s)
31192 IDC0=MDCY(21,2)-1
31193 FLAVWT=0D0
31194 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
31195 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
31196 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
31197 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
31198 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
31199 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
31200 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
31201 & UH2/SH2)*FLAVWT*FACA
31202 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
31203 & TH2/SH2)*FLAVWT*FACA
31204 NCHN=NCHN+1
31205 ISIG(NCHN,1)=21
31206 ISIG(NCHN,2)=21
31207 ISIG(NCHN,3)=531
31208 SIGH(NCHN)=FACQQ1
31209 NCHN=NCHN+1
31210 ISIG(NCHN,1)=21
31211 ISIG(NCHN,2)=21
31212 ISIG(NCHN,3)=532
31213 SIGH(NCHN)=FACQQ2
31214
31215C...g + g -> c + cbar, b + bbar: modified that/uhat for fixed
31216C...cos(theta-hat)
31217 DO 380 IFL=4,5
31218 SQMAVG=PMAS(IFL,1)**2
31219 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
31220 BE34=SQRT(1D0-4D0*SQMAVG/SH)
31221 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31222 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31223 THUHQ=THQ*UHQ-SQMAVG*SH
31224 IF(MSTP(34).EQ.0) THEN
31225 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
31226 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
31227 ELSE
31228 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31229 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
31230 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31231 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
31232 ENDIF
31233 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
31234 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
31235 NCHN=NCHN+1
31236 ISIG(NCHN,1)=21
31237 ISIG(NCHN,2)=21
31238 ISIG(NCHN,3)=531+2*(IFL-3)
31239 SIGH(NCHN)=FACQQ1
31240 NCHN=NCHN+1
31241 ISIG(NCHN,1)=21
31242 ISIG(NCHN,2)=21
31243 ISIG(NCHN,3)=532+2*(IFL-3)
31244 SIGH(NCHN)=FACQQ2
31245 ENDIF
31246 380 CONTINUE
31247
31248C...g + g -> g + g
31249 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
31250 & 2D0*TH/SH+TH2/SH2)*FACA
31251 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
31252 & 2D0*SH/UH+SH2/UH2)*FACA
31253 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3+
31254 & 2D0*UH/TH+UH2/TH2)
31255 NCHN=NCHN+1
31256 ISIG(NCHN,1)=21
31257 ISIG(NCHN,2)=21
31258 ISIG(NCHN,3)=681
31259 SIGH(NCHN)=0.5D0*FACGG1
31260 NCHN=NCHN+1
31261 ISIG(NCHN,1)=21
31262 ISIG(NCHN,2)=21
31263 ISIG(NCHN,3)=682
31264 SIGH(NCHN)=0.5D0*FACGG2
31265 NCHN=NCHN+1
31266 ISIG(NCHN,1)=21
31267 ISIG(NCHN,2)=21
31268 ISIG(NCHN,3)=683
31269 SIGH(NCHN)=0.5D0*FACGG3
31270
31271 ELSEIF(ISUB.EQ.99) THEN
31272C...f + gamma* -> f.
31273 IF(MINT(107).EQ.4) THEN
31274 Q2GA=VINT(307)
31275 P2GA=VINT(308)
31276 ISDE=2
31277 ELSE
31278 Q2GA=VINT(308)
31279 P2GA=VINT(307)
31280 ISDE=1
31281 ENDIF
31282 COMFAC=PARU(5)*4D0*PARU(1)**2*PARU(101)*VINT(315)*VINT(316)
31283 PM2RHO=PMAS(PYCOMP(113),1)**2
31284 IF(MSTP(19).EQ.0) THEN
31285 COMFAC=COMFAC/Q2GA
31286 ELSEIF(MSTP(19).EQ.1) THEN
31287 COMFAC=COMFAC/(Q2GA+PM2RHO)
31288 ELSEIF(MSTP(19).EQ.2) THEN
31289 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
31290 ELSE
31291 COMFAC=COMFAC*Q2GA/(Q2GA+PM2RHO)**2
31292 W2GA=VINT(2)
31293 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22) THEN
31294 RDRDS=4.1D-3*W2GA**2.167D0/((Q2GA+0.15D0*W2GA)**2*
31295 & Q2GA**0.75D0)*(1D0+0.11D0*Q2GA*P2GA/(1D0+0.02D0*P2GA**2))
31296 XGA=Q2GA/(W2GA+VINT(307)+VINT(308))
31297 ELSE
31298 RDRDS=1.5D-4*W2GA**2.167D0/((Q2GA+0.041D0*W2GA)**2*
31299 & Q2GA**0.57D0)
31300 XGA=Q2GA/(W2GA+Q2GA-PMAS(PYCOMP(MINT(10+ISDE)),1)**2)
31301 ENDIF
31302 COMFAC=COMFAC*EXP(-MAX(1D-10,RDRDS))
31303 IF(MSTP(19).EQ.4) COMFAC=COMFAC/MAX(1D-2,1D0-XGA)
31304 ENDIF
31305 DO 390 I=MMINA,MMAXA
31306 IF(I.EQ.0.OR.KFAC(ISDE,I).EQ.0) GOTO 390
31307 IF(IABS(I).LT.10.AND.IABS(I).GT.MSTP(58)) GOTO 390
31308 EI=KCHG(IABS(I),1)/3D0
31309 NCHN=NCHN+1
31310 ISIG(NCHN,ISDE)=I
31311 ISIG(NCHN,3-ISDE)=22
31312 ISIG(NCHN,3)=1
31313 SIGH(NCHN)=COMFAC*EI**2
31314 390 CONTINUE
31315 ENDIF
31316
31317 ELSE
31318 IF(ISUB.EQ.114.OR.ISUB.EQ.115) THEN
31319C...g + g -> gamma + gamma or g + g -> g + gamma
31320 A0STUR=0D0
31321 A0STUI=0D0
31322 A0TSUR=0D0
31323 A0TSUI=0D0
31324 A0UTSR=0D0
31325 A0UTSI=0D0
31326 A1STUR=0D0
31327 A1STUI=0D0
31328 A2STUR=0D0
31329 A2STUI=0D0
31330 ALST=LOG(-SH/TH)
31331 ALSU=LOG(-SH/UH)
31332 ALTU=LOG(TH/UH)
31333 IMAX=2*MSTP(1)
31334 IF(MSTP(38).GE.1.AND.MSTP(38).LE.8) IMAX=MSTP(38)
31335 DO 400 I=1,IMAX
31336 EI=KCHG(IABS(I),1)/3D0
31337 EIWT=EI**2
31338 IF(ISUB.EQ.115) EIWT=EI
31339 SQMQ=PMAS(I,1)**2
31340 EPSS=4D0*SQMQ/SH
31341 EPST=4D0*SQMQ/TH
31342 EPSU=4D0*SQMQ/UH
31343 IF((MSTP(38).GE.1.AND.MSTP(38).LE.8).OR.EPSS.LT.1D-4) THEN
31344 B0STUR=1D0+(TH-UH)/SH*ALTU+0.5D0*(TH2+UH2)/SH2*(ALTU**2+
31345 & PARU(1)**2)
31346 B0STUI=0D0
31347 B0TSUR=1D0+(SH-UH)/TH*ALSU+0.5D0*(SH2+UH2)/TH2*ALSU**2
31348 B0TSUI=-PARU(1)*((SH-UH)/TH+(SH2+UH2)/TH2*ALSU)
31349 B0UTSR=1D0+(SH-TH)/UH*ALST+0.5D0*(SH2+TH2)/UH2*ALST**2
31350 B0UTSI=-PARU(1)*((SH-TH)/UH+(SH2+TH2)/UH2*ALST)
31351 B1STUR=-1D0
31352 B1STUI=0D0
31353 B2STUR=-1D0
31354 B2STUI=0D0
31355 ELSE
31356 CALL PYWAUX(1,EPSS,W1SR,W1SI)
31357 CALL PYWAUX(1,EPST,W1TR,W1TI)
31358 CALL PYWAUX(1,EPSU,W1UR,W1UI)
31359 CALL PYWAUX(2,EPSS,W2SR,W2SI)
31360 CALL PYWAUX(2,EPST,W2TR,W2TI)
31361 CALL PYWAUX(2,EPSU,W2UR,W2UI)
31362 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
31363 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
31364 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
31365 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
31366 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
31367 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
31368 B0STUR=1D0+(1D0+2D0*TH/SH)*W1TR+(1D0+2D0*UH/SH)*W1UR+
31369 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TR+W2UR)-
31370 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTR+Y3TUSR)-
31371 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUR+Y3UTSR)+
31372 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
31373 & 0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
31374 B0STUI=(1D0+2D0*TH/SH)*W1TI+(1D0+2D0*UH/SH)*W1UI+
31375 & 0.5D0*((TH2+UH2)/SH2-EPSS)*(W2TI+W2UI)-
31376 & 0.25D0*EPST*(1D0-0.5D0*EPSS)*(Y3SUTI+Y3TUSI)-
31377 & 0.25D0*EPSU*(1D0-0.5D0*EPSS)*(Y3STUI+Y3UTSI)+
31378 & 0.25D0*(-2D0*(TH2+UH2)/SH2+4D0*EPSS+EPST+EPSU+
31379 & 0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
31380 B0TSUR=1D0+(1D0+2D0*SH/TH)*W1SR+(1D0+2D0*UH/TH)*W1UR+
31381 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SR+W2UR)-
31382 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSR+Y3SUTR)-
31383 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUR+Y3USTR)+
31384 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
31385 & 0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)
31386 B0TSUI=(1D0+2D0*SH/TH)*W1SI+(1D0+2D0*UH/TH)*W1UI+
31387 & 0.5D0*((SH2+UH2)/TH2-EPST)*(W2SI+W2UI)-
31388 & 0.25D0*EPSS*(1D0-0.5D0*EPST)*(Y3TUSI+Y3SUTI)-
31389 & 0.25D0*EPSU*(1D0-0.5D0*EPST)*(Y3TSUI+Y3USTI)+
31390 & 0.25D0*(-2D0*(SH2+UH2)/TH2+4D0*EPST+EPSS+EPSU+
31391 & 0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)
31392 B0UTSR=1D0+(1D0+2D0*TH/UH)*W1TR+(1D0+2D0*SH/UH)*W1SR+
31393 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TR+W2SR)-
31394 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTR+Y3TSUR)-
31395 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSR+Y3STUR)+
31396 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
31397 & 0.5D0*EPST*EPSS)*(Y3TUSR+Y3SUTR)
31398 B0UTSI=(1D0+2D0*TH/UH)*W1TI+(1D0+2D0*SH/UH)*W1SI+
31399 & 0.5D0*((TH2+SH2)/UH2-EPSU)*(W2TI+W2SI)-
31400 & 0.25D0*EPST*(1D0-0.5D0*EPSU)*(Y3USTI+Y3TSUI)-
31401 & 0.25D0*EPSS*(1D0-0.5D0*EPSU)*(Y3UTSI+Y3STUI)+
31402 & 0.25D0*(-2D0*(TH2+SH2)/UH2+4D0*EPSU+EPST+EPSS+
31403 & 0.5D0*EPST*EPSS)*(Y3TUSI+Y3SUTI)
31404 B1STUR=-1D0-0.25D0*(EPSS+EPST+EPSU)*(W2SR+W2TR+W2UR)+
31405 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTR+Y3TUSR)+
31406 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUR+Y3UTSR)+
31407 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUR+Y3USTR)
31408 B1STUI=-0.25D0*(EPSS+EPST+EPSU)*(W2SI+W2TI+W2UI)+
31409 & 0.25D0*(EPSU+0.5D0*EPSS*EPST)*(Y3SUTI+Y3TUSI)+
31410 & 0.25D0*(EPST+0.5D0*EPSS*EPSU)*(Y3STUI+Y3UTSI)+
31411 & 0.25D0*(EPSS+0.5D0*EPST*EPSU)*(Y3TSUI+Y3USTI)
31412 B2STUR=-1D0+0.125D0*EPSS*EPST*(Y3SUTR+Y3TUSR)+
31413 & 0.125D0*EPSS*EPSU*(Y3STUR+Y3UTSR)+
31414 & 0.125D0*EPST*EPSU*(Y3TSUR+Y3USTR)
31415 B2STUI=0.125D0*EPSS*EPST*(Y3SUTI+Y3TUSI)+
31416 & 0.125D0*EPSS*EPSU*(Y3STUI+Y3UTSI)+
31417 & 0.125D0*EPST*EPSU*(Y3TSUI+Y3USTI)
31418 ENDIF
31419 A0STUR=A0STUR+EIWT*B0STUR
31420 A0STUI=A0STUI+EIWT*B0STUI
31421 A0TSUR=A0TSUR+EIWT*B0TSUR
31422 A0TSUI=A0TSUI+EIWT*B0TSUI
31423 A0UTSR=A0UTSR+EIWT*B0UTSR
31424 A0UTSI=A0UTSI+EIWT*B0UTSI
31425 A1STUR=A1STUR+EIWT*B1STUR
31426 A1STUI=A1STUI+EIWT*B1STUI
31427 A2STUR=A2STUR+EIWT*B2STUR
31428 A2STUI=A2STUI+EIWT*B2STUI
31429 400 CONTINUE
31430 ASQSUM=A0STUR**2+A0STUI**2+A0TSUR**2+A0TSUI**2+A0UTSR**2+
31431 & A0UTSI**2+4D0*A1STUR**2+4D0*A1STUI**2+A2STUR**2+A2STUI**2
31432 FACGG=COMFAC*FACA/(16D0*PARU(1)**2)*AS**2*AEM**2*ASQSUM
31433 FACGP=COMFAC*FACA*5D0/(192D0*PARU(1)**2)*AS**3*AEM*ASQSUM
31434 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
31435 NCHN=NCHN+1
31436 ISIG(NCHN,1)=21
31437 ISIG(NCHN,2)=21
31438 ISIG(NCHN,3)=1
31439 IF(ISUB.EQ.114) SIGH(NCHN)=0.5D0*FACGG
31440 IF(ISUB.EQ.115) SIGH(NCHN)=FACGP
31441 410 CONTINUE
31442
31443 ELSEIF(ISUB.EQ.131.OR.ISUB.EQ.132) THEN
31444C...f + gamma*_(T,L) -> f + g (q + gamma*_(T,L) -> q + g only)
31445 PH=0D0
31446 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
31447 & PH=VINT(3)**2
31448 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
31449 & PH=VINT(4)**2
31450 IF(ISUB.EQ.131) THEN
31451 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**2*
31452 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
31453 ELSE
31454 FGQ=COMFAC*AS*AEM*8D0/3D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
31455 ENDIF
31456 DO 430 I=MMINA,MMAXA
31457 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
31458 EI=KCHG(IABS(I),1)/3D0
31459 FACGQ=FGQ*EI**2
31460 DO 420 ISDE=1,2
31461 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 420
31462 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 420
31463 NCHN=NCHN+1
31464 ISIG(NCHN,ISDE)=I
31465 ISIG(NCHN,3-ISDE)=22
31466 ISIG(NCHN,3)=1
31467 SIGH(NCHN)=FACGQ
31468 420 CONTINUE
31469 430 CONTINUE
31470
31471 ELSEIF(ISUB.EQ.133.OR.ISUB.EQ.134) THEN
31472C...f + gamma*_(T,L) -> f + gamma
31473 PH=0D0
31474 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
31475 & PH=VINT(3)**2
31476 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
31477 & PH=VINT(4)**2
31478 IF(ISUB.EQ.133) THEN
31479 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**2*
31480 & ((SH2+UH2-2D0*PH*TH)/(-SH*UH)-2D0*PH*TH/(SH+PH)**2)
31481 ELSE
31482 FGQ=COMFAC*AEM**2*2D0*SH**2/(SH+PH)**4*(-4D0*PH*TH)
31483 ENDIF
31484 DO 450 I=MMINA,MMAXA
31485 IF(I.EQ.0) GOTO 450
31486 EI=KCHG(IABS(I),1)/3D0
31487 FACGQ=FGQ*EI**4
31488 DO 440 ISDE=1,2
31489 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 440
31490 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 440
31491 NCHN=NCHN+1
31492 ISIG(NCHN,ISDE)=I
31493 ISIG(NCHN,3-ISDE)=22
31494 ISIG(NCHN,3)=1
31495 SIGH(NCHN)=FACGQ
31496 440 CONTINUE
31497 450 CONTINUE
31498
31499 ELSEIF(ISUB.EQ.135.OR.ISUB.EQ.136) THEN
31500C...g + gamma*_(T,L) -> f + fbar (g + gamma*_(T,L) -> q + qbar only)
31501 PH=0D0
31502 IF(MINT(15).EQ.22.AND.MINT(107).EQ.0.AND.VINT(3).LT.0D0)
31503 & PH=VINT(3)**2
31504 IF(MINT(16).EQ.22.AND.MINT(108).EQ.0.AND.VINT(4).LT.0D0)
31505 & PH=VINT(4)**2
31506 CALL PYWIDT(21,SH,WDTP,WDTE)
31507 WDTESU=0D0
31508 DO 460 I=1,MIN(8,MDCY(21,3))
31509 EF=KCHG(I,1)/3D0
31510 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
31511 & WDTE(I,4))
31512 460 CONTINUE
31513 IF(ISUB.EQ.135) THEN
31514 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**2*
31515 & ((TH2+UH2-2D0*PH*SH)/(TH*UH)+4D0*PH*SH/(SH+PH)**2)
31516 ELSE
31517 FACQQ=COMFAC*AEM*AS*WDTESU*SH**2/(SH+PH)**4*8D0*PH*SH
31518 ENDIF
31519 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31520 NCHN=NCHN+1
31521 ISIG(NCHN,1)=21
31522 ISIG(NCHN,2)=22
31523 ISIG(NCHN,3)=1
31524 SIGH(NCHN)=FACQQ
31525 ENDIF
31526 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31527 NCHN=NCHN+1
31528 ISIG(NCHN,1)=22
31529 ISIG(NCHN,2)=21
31530 ISIG(NCHN,3)=1
31531 SIGH(NCHN)=FACQQ
31532 ENDIF
31533
31534 ELSEIF(ISUB.GE.137.AND.ISUB.LE.140) THEN
31535C...gamma*_(T,L) + gamma*_(T,L) -> f + fbar
31536 PH1=0D0
31537 IF(VINT(3).LT.0D0) PH1=VINT(3)**2
31538 PH2=0D0
31539 IF(VINT(4).LT.0D0) PH2=VINT(4)**2
31540 CALL PYWIDT(22,SH,WDTP,WDTE)
31541 WDTESU=0D0
31542 DO 470 I=1,MIN(12,MDCY(22,3))
31543 IF(I.LE.8) EF= KCHG(I,1)/3D0
31544 IF(I.GE.9) EF= KCHG(9+2*(I-8),1)/3D0
31545 WDTESU=WDTESU+EF**2*(WDTE(I,1)+WDTE(I,2)+WDTE(I,3)+
31546 & WDTE(I,4))
31547 470 CONTINUE
31548 DLAMB2=(TH+UH)**2-4D0*PH1*PH2
31549 IF(ISUB.EQ.137) THEN
31550 FPARAM=-SH*(TH+UH)/DLAMB2
31551 FACFF=COMFAC*AEM**2*WDTESU*2D0*SH2/(DLAMB2*TH2*UH2)*
31552 & (TH*UH-PH1*PH2)*((TH2+UH2)*(1D0-2D0*FPARAM*(1D0-FPARAM))-
31553 & 2D0*PH1*PH2*FPARAM**2)
31554 ELSEIF(ISUB.EQ.138) THEN
31555 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
31556 & PH2*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH1*SH*(TH-UH)**2/DLAMB2)+
31557 & 2D0*PH1**2*(TH-UH)**2)
31558 ELSEIF(ISUB.EQ.139) THEN
31559 FACFF=COMFAC*AEM**2*WDTESU*4D0*SH2*SH/(DLAMB2**2*TH2*UH2)*
31560 & PH1*(4D0*(TH*UH-PH1*PH2)*(TH*UH+PH2*SH*(TH-UH)**2/DLAMB2)+
31561 & 2D0*PH2**2*(TH-UH)**2)
31562 ELSE
31563 FACFF=COMFAC*AEM**2*WDTESU*32D0*SH2**2/(DLAMB2**3*TH2*UH2)*
31564 & PH1*PH2*(TH*UH-PH1*PH2)*(TH-UH)**2
31565 ENDIF
31566 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31567 NCHN=NCHN+1
31568 ISIG(NCHN,1)=22
31569 ISIG(NCHN,2)=22
31570 ISIG(NCHN,3)=1
31571 SIGH(NCHN)=FACFF
31572 ENDIF
31573
31574 ENDIF
31575 ENDIF
31576
31577 RETURN
31578 END
31579
31580C*********************************************************************
31581
31582C...PYSGHF
31583C...Subprocess cross sections for heavy flavour production,
31584C...open and closed.
31585C...Auxiliary to PYSIGH.
31586
31587 SUBROUTINE PYSGHF(NCHN,SIGS)
31588
31589C...Double precision and integer declarations
31590 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
31591 IMPLICIT INTEGER(I-N)
31592 INTEGER PYK,PYCHGE,PYCOMP
31593C...Parameter statement to help give large particle numbers.
31594 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
31595 &KEXCIT=4000000,KDIMEN=5000000)
31596C...Commonblocks
31597 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
31598 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
31599 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
31600 COMMON/PYINT1/MINT(400),VINT(400)
31601 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
31602 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
31603 COMMON/PYINT4/MWID(500),WIDS(500,5)
31604 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
31605 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
31606 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
31607 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
31608 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
31609 &/PYINT4/,/PYSGCM/
31610C...Local arrays
31611 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
31612
31613C...Determine where are charmonium/bottomonium wave function parameters.
31614 IONIUM=140
31615 IF(ISUB.GE.461.AND.ISUB.LE.479) IONIUM=145
31616
31617C...Convert bottomonium process into equivalent charmonium ones.
31618 IF(ISUB.GE.461.AND.ISUB.LE.479) ISUB=ISUB-40
31619
31620C...Differential cross section expressions.
31621
31622 IF(ISUB.LE.100) THEN
31623 IF(ISUB.EQ.81) THEN
31624C...q + qbar -> Q + Qbar
31625 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31626 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31627 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31628 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
31629 & 2D0*SQMAVG/SH)
31630 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
31631 WID2=1D0
31632 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31633 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31634 FACQQB=FACQQB*WID2
31635 DO 100 I=MMINA,MMAXA
31636 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
31637 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
31638 NCHN=NCHN+1
31639 ISIG(NCHN,1)=I
31640 ISIG(NCHN,2)=-I
31641 ISIG(NCHN,3)=1
31642 SIGH(NCHN)=FACQQB
31643 100 CONTINUE
31644
31645 ELSEIF(ISUB.EQ.82) THEN
31646C...g + g -> Q + Qbar
31647 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31648 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31649 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31650 THUHQ=THQ*UHQ-SQMAVG*SH
31651 IF(MSTP(34).EQ.0) THEN
31652 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
31653 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
31654 ELSE
31655 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31656 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
31657 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
31658 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
31659 ENDIF
31660 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
31661 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
31662 IF(MSTP(35).GE.1) THEN
31663 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
31664 FACQQ1=FACQQ1*FATRE
31665 FACQQ2=FACQQ2*FATRE
31666 ENDIF
31667 WID2=1D0
31668 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31669 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31670 FACQQ1=FACQQ1*WID2
31671 FACQQ2=FACQQ2*WID2
31672 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 110
31673 NCHN=NCHN+1
31674 ISIG(NCHN,1)=21
31675 ISIG(NCHN,2)=21
31676 ISIG(NCHN,3)=1
31677 SIGH(NCHN)=FACQQ1
31678 NCHN=NCHN+1
31679 ISIG(NCHN,1)=21
31680 ISIG(NCHN,2)=21
31681 ISIG(NCHN,3)=2
31682 SIGH(NCHN)=FACQQ2
31683 110 CONTINUE
31684
31685 ELSEIF(ISUB.EQ.83) THEN
31686C...f + q -> f' + Q
31687 FACQQS=COMFAC*(0.5D0*AEM/XW)**2*SH*(SH-SQM3)/(SQMW-TH)**2
31688 FACQQU=COMFAC*(0.5D0*AEM/XW)**2*UH*(UH-SQM3)/(SQMW-TH)**2
31689 DO 130 I=MMIN1,MMAX1
31690 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 130
31691 DO 120 J=MMIN2,MMAX2
31692 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 120
31693 IF(I*J.GT.0.AND.MOD(IABS(I+J),2).EQ.0) GOTO 120
31694 IF(I*J.LT.0.AND.MOD(IABS(I+J),2).EQ.1) GOTO 120
31695 IF(IABS(I).LT.MINT(55).AND.MOD(IABS(I+MINT(55)),2).EQ.1)
31696 & THEN
31697 NCHN=NCHN+1
31698 ISIG(NCHN,1)=I
31699 ISIG(NCHN,2)=J
31700 ISIG(NCHN,3)=1
31701 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31702 & (IABS(I)+1)/2)*VINT(180+J)
31703 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(I)/2,
31704 & (MINT(55)+1)/2)*VINT(180+J)
31705 WID2=1D0
31706 IF(I.GT.0) THEN
31707 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31708 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31709 & WIDS(MINT(55),2)
31710 ELSE
31711 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31712 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31713 & WIDS(MINT(55),3)
31714 ENDIF
31715 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31716 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31717 ENDIF
31718 IF(IABS(J).LT.MINT(55).AND.MOD(IABS(J+MINT(55)),2).EQ.1)
31719 & THEN
31720 NCHN=NCHN+1
31721 ISIG(NCHN,1)=I
31722 ISIG(NCHN,2)=J
31723 ISIG(NCHN,3)=2
31724 IF(MOD(MINT(55),2).EQ.0) FACCKM=VCKM(MINT(55)/2,
31725 & (IABS(J)+1)/2)*VINT(180+I)
31726 IF(MOD(MINT(55),2).EQ.1) FACCKM=VCKM(IABS(J)/2,
31727 & (MINT(55)+1)/2)*VINT(180+I)
31728 WID2=1D0
31729 IF(J.GT.0) THEN
31730 IF(MINT(55).EQ.6) WID2=WIDS(6,2)
31731 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31732 & WIDS(MINT(55),2)
31733 ELSE
31734 IF(MINT(55).EQ.6) WID2=WIDS(6,3)
31735 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=
31736 & WIDS(MINT(55),3)
31737 ENDIF
31738 IF(I*J.GT.0) SIGH(NCHN)=FACQQS*FACCKM*WID2
31739 IF(I*J.LT.0) SIGH(NCHN)=FACQQU*FACCKM*WID2
31740 ENDIF
31741 120 CONTINUE
31742 130 CONTINUE
31743
31744 ELSEIF(ISUB.EQ.84) THEN
31745C...g + gamma -> Q + Qbar
31746 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31747 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31748 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31749 FACQQ=COMFAC*AS*AEM*(KCHG(IABS(MINT(55)),1)/3D0)**2*
31750 & (THQ**2+UHQ**2+4D0*SQMAVG*SH*(1D0-SQMAVG*SH/(THQ*UHQ)))/
31751 & (THQ*UHQ)
31752 IF(MSTP(35).GE.1) FACQQ=FACQQ*PYHFTH(SH,SQMAVG,0D0)
31753 WID2=1D0
31754 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
31755 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
31756 FACQQ=FACQQ*WID2
31757 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31758 NCHN=NCHN+1
31759 ISIG(NCHN,1)=21
31760 ISIG(NCHN,2)=22
31761 ISIG(NCHN,3)=1
31762 SIGH(NCHN)=FACQQ
31763 ENDIF
31764 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31765 NCHN=NCHN+1
31766 ISIG(NCHN,1)=22
31767 ISIG(NCHN,2)=21
31768 ISIG(NCHN,3)=1
31769 SIGH(NCHN)=FACQQ
31770 ENDIF
31771
31772 ELSEIF(ISUB.EQ.85) THEN
31773C...gamma + gamma -> F + Fbar (heavy fermion, quark or lepton)
31774 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
31775 THQ=-0.5D0*SH*(1D0-BE34*CTH)
31776 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
31777 FACFF=COMFAC*AEM**2*(KCHG(IABS(MINT(56)),1)/3D0)**4*2D0*
31778 & ((1D0-PARJ(131)*PARJ(132))*(THQ*UHQ-SQMAVG*SH)*
31779 & (UHQ**2+THQ**2+2D0*SQMAVG*SH)+(1D0+PARJ(131)*PARJ(132))*
31780 & SQMAVG*SH**2*(SH-2D0*SQMAVG))/(THQ*UHQ)**2
31781 IF(IABS(MINT(56)).LT.10) FACFF=3D0*FACFF
31782 IF(IABS(MINT(56)).LT.10.AND.MSTP(35).GE.1)
31783 & FACFF=FACFF*PYHFTH(SH,SQMAVG,1D0)
31784 WID2=1D0
31785 IF(MINT(56).EQ.6) WID2=WIDS(6,1)
31786 IF(MINT(56).EQ.7.OR.MINT(56).EQ.8) WID2=WIDS(MINT(56),1)
31787 IF(MINT(56).EQ.17) WID2=WIDS(17,1)
31788 FACFF=FACFF*WID2
31789 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31790 NCHN=NCHN+1
31791 ISIG(NCHN,1)=22
31792 ISIG(NCHN,2)=22
31793 ISIG(NCHN,3)=1
31794 SIGH(NCHN)=FACFF
31795 ENDIF
31796
31797 ELSEIF(ISUB.EQ.86) THEN
31798C...g + g -> J/Psi + g
31799 FACQQG=COMFAC*AS**3*(5D0/9D0)*PARP(38)*SQRT(SQM3)*
31800 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31801 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31802 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31803 NCHN=NCHN+1
31804 ISIG(NCHN,1)=21
31805 ISIG(NCHN,2)=21
31806 ISIG(NCHN,3)=1
31807 SIGH(NCHN)=FACQQG
31808 ENDIF
31809
31810 ELSEIF(ISUB.EQ.87) THEN
31811C...g + g -> chi_0c + g
31812 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31813 QGTW=(SH*TH*UH)/SH**3
31814 RGTW=SQM3/SH
31815 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31816 & (9D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31817 & 6D0*RGTW*PGTW**3*QGTW*(2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)-
31818 & PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)+
31819 & 2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)+6D0*RGTW**2*QGTW**4)/
31820 & (QGTW*(QGTW-RGTW*PGTW)**4)
31821 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31822 NCHN=NCHN+1
31823 ISIG(NCHN,1)=21
31824 ISIG(NCHN,2)=21
31825 ISIG(NCHN,3)=1
31826 SIGH(NCHN)=FACQQG
31827 ENDIF
31828
31829 ELSEIF(ISUB.EQ.88) THEN
31830C...g + g -> chi_1c + g
31831 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31832 QGTW=(SH*TH*UH)/SH**3
31833 RGTW=SQM3/SH
31834 FACQQG=COMFAC*AS**3*12D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31835 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)+2D0*QGTW*(-RGTW**4+
31836 & 5D0*RGTW**2*PGTW+PGTW**2)-15D0*RGTW*QGTW**2)/
31837 & (QGTW-RGTW*PGTW)**4
31838 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31839 NCHN=NCHN+1
31840 ISIG(NCHN,1)=21
31841 ISIG(NCHN,2)=21
31842 ISIG(NCHN,3)=1
31843 SIGH(NCHN)=FACQQG
31844 ENDIF
31845
31846 ELSEIF(ISUB.EQ.89) THEN
31847C...g + g -> chi_2c + g
31848 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
31849 QGTW=(SH*TH*UH)/SH**3
31850 RGTW=SQM3/SH
31851 FACQQG=COMFAC*AS**3*4D0*(PARP(39)/SQRT(SQM3))*(1D0/SH)*
31852 & (12D0*RGTW**2*PGTW**4*(RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)-
31853 & 3D0*RGTW*PGTW**3*QGTW*(8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)+
31854 & 2D0*PGTW**2*QGTW**2*(-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)+
31855 & RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)+12D0*RGTW**2*
31856 & QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
31857 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31858 NCHN=NCHN+1
31859 ISIG(NCHN,1)=21
31860 ISIG(NCHN,2)=21
31861 ISIG(NCHN,3)=1
31862 SIGH(NCHN)=FACQQG
31863 ENDIF
31864 ENDIF
31865
31866 ELSEIF(ISUB.LE.200) THEN
31867 IF(ISUB.EQ.104) THEN
31868C...g + g -> chi_c0.
31869 KC=PYCOMP(10441)
31870 FACBW=COMFAC*12D0*AS**2*PARP(39)*PMAS(KC,2)/
31871 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31872 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31873 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31874 NCHN=NCHN+1
31875 ISIG(NCHN,1)=21
31876 ISIG(NCHN,2)=21
31877 ISIG(NCHN,3)=1
31878 SIGH(NCHN)=FACBW
31879 ENDIF
31880
31881 ELSEIF(ISUB.EQ.105) THEN
31882C...g + g -> chi_c2.
31883 KC=PYCOMP(445)
31884 FACBW=COMFAC*16D0*AS**2*PARP(39)*PMAS(KC,2)/
31885 & ((SH-PMAS(KC,1)**2)**2+(PMAS(KC,1)*PMAS(KC,2))**2)
31886 IF(ABS(SQRT(SH)-PMAS(KC,1)).GT.50D0*PMAS(KC,2)) FACBW=0D0
31887 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31888 NCHN=NCHN+1
31889 ISIG(NCHN,1)=21
31890 ISIG(NCHN,2)=21
31891 ISIG(NCHN,3)=1
31892 SIGH(NCHN)=FACBW
31893 ENDIF
31894
31895 ELSEIF(ISUB.EQ.106) THEN
31896C...g + g -> J/Psi + gamma.
31897 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31898 FACQQG=COMFAC*AEM*EQ**2*AS**2*(4D0/3D0)*PARP(38)*SQRT(SQM3)*
31899 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31900 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31901 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
31902 NCHN=NCHN+1
31903 ISIG(NCHN,1)=21
31904 ISIG(NCHN,2)=21
31905 ISIG(NCHN,3)=1
31906 SIGH(NCHN)=FACQQG
31907 ENDIF
31908
31909 ELSEIF(ISUB.EQ.107) THEN
31910C...g + gamma -> J/Psi + g.
31911 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31912 FACQQG=COMFAC*AEM*EQ**2*AS**2*(32D0/3D0)*PARP(38)*SQRT(SQM3)*
31913 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31914 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31915 IF(KFAC(1,21)*KFAC(2,22).NE.0) THEN
31916 NCHN=NCHN+1
31917 ISIG(NCHN,1)=21
31918 ISIG(NCHN,2)=22
31919 ISIG(NCHN,3)=1
31920 SIGH(NCHN)=FACQQG
31921 ENDIF
31922 IF(KFAC(1,22)*KFAC(2,21).NE.0) THEN
31923 NCHN=NCHN+1
31924 ISIG(NCHN,1)=22
31925 ISIG(NCHN,2)=21
31926 ISIG(NCHN,3)=1
31927 SIGH(NCHN)=FACQQG
31928 ENDIF
31929
31930 ELSEIF(ISUB.EQ.108) THEN
31931C...gamma + gamma -> J/Psi + gamma.
31932 EQ=KCHG(MOD(KFPR(ISUB,1)/10,10),1)/3D0
31933 FACQQG=COMFAC*AEM**3*EQ**6*384D0*PARP(38)*SQRT(SQM3)*
31934 & (((SH*(SH-SQM3))**2+(TH*(TH-SQM3))**2+(UH*(UH-SQM3))**2)/
31935 & ((TH-SQM3)*(UH-SQM3))**2)/(SH-SQM3)**2
31936 IF(KFAC(1,22)*KFAC(2,22).NE.0) THEN
31937 NCHN=NCHN+1
31938 ISIG(NCHN,1)=22
31939 ISIG(NCHN,2)=22
31940 ISIG(NCHN,3)=1
31941 SIGH(NCHN)=FACQQG
31942 ENDIF
31943 ENDIF
31944
31945C...QUARKONIA+++
31946C...Additional code by Stefan Wolf
31947 ELSE
31948
31949C...Common code for quarkonium production.
31950 SHTH=SH+TH
31951 THUH=TH+UH
31952 UHSH=UH+SH
31953 SHTH2=SHTH**2
31954 THUH2=THUH**2
31955 UHSH2=UHSH**2
31956 IF ( (ISUB.GE.421.AND.ISUB.LE.424).OR.
31957 & (ISUB.GE.431.AND.ISUB.LE.433)) THEN
31958 SQMQQ=SQM3
31959 ELSEIF((ISUB.GE.425.AND.ISUB.LE.430).OR.
31960 & (ISUB.GE.434.AND.ISUB.LE.439)) THEN
31961 SQMQQ=SQM4
31962 ENDIF
31963 SQMQQR=SQRT(SQMQQ)
31964 IF(MSTP(145).EQ.1) THEN
31965 IF ( (ISUB.GE.421.AND.ISUB.LE.427).OR.
31966 & (ISUB.GE.431.AND.ISUB.LE.436)) THEN
31967 AQ=UHSH/(2D0*X(1)) + SHTH/(2D0*X(2))
31968 BQ=UHSH/(2D0*X(1)) - SHTH/(2D0*X(2))
31969 ATILK1=X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31970 ATILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31971 BTILK1=-X(1)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31972 BTILK2=X(2)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31973 ELSEIF( (ISUB.GE.428.AND.ISUB.LE.430).OR.
31974 & ISUB.GE.437) THEN
31975 AQ=SHTH/(2D0*X(1)) + UHSH/(2D0*X(2))
31976 BQ=SHTH/(2D0*X(1)) - UHSH/(2D0*X(2))
31977 ATILK1=X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*AQ
31978 ATILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*AQ
31979 BTILK1=-X(1)*VINT(2)/2D0-SHTH/(2D0*SQMQQ)*BQ
31980 BTILK2=X(2)*VINT(2)/2D0-UHSH/(2D0*SQMQQ)*BQ
31981 ENDIF
31982 AQ2=AQ**2
31983 BQ2=BQ**2
31984 SMQQ2=SQMQQ*VINT(2)
31985C...Polarisation frames
31986 IF(MSTP(146).EQ.1) THEN
31987C...Recoil frame
31988 POLH1=SQRT(AQ2-SMQQ2)
31989 POLH2=SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31990 AZ=-SQMQQR/POLH1
31991 BZ=0D0
31992 AX=AQ*BQ/(POLH1*POLH2)
31993 BX=-POLH1/POLH2
31994 ELSEIF(MSTP(146).EQ.2) THEN
31995C...Gottfried Jackson frame
31996 POLH1=AQ+BQ
31997 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
31998 AZ=SQMQQR/POLH1
31999 BZ=AZ
32000 AX=-(BQ2+AQ*BQ+SMQQ2)/POLH2
32001 BX=(AQ2+AQ*BQ-SMQQ2)/POLH2
32002 ELSEIF(MSTP(146).EQ.3) THEN
32003C...Target frame
32004 POLH1=AQ-BQ
32005 POLH2=POLH1*SQRT(VINT(2)*(AQ2-BQ2-SMQQ2))
32006 AZ=-SQMQQR/POLH1
32007 BZ=-AZ
32008 AX=-(BQ2-AQ*BQ+SMQQ2)/POLH2
32009 BX=-(AQ2-AQ*BQ-SMQQ2)/POLH2
32010 ELSEIF(MSTP(146).EQ.4) THEN
32011C...Collins Soper frame
32012 POLH1=AQ2-BQ2
32013 POLH2=SQRT(VINT(2)*POLH1)
32014 AZ=-BQ/POLH2
32015 BZ=AQ/POLH2
32016 AX=-SQMQQR*AQ/SQRT(POLH1*(POLH1-SMQQ2))
32017 BX=SQMQQR*BQ/SQRT(POLH1*(POLH1-SMQQ2))
32018 ENDIF
32019C...Contract EL1(lam) EL2(lam') with K1 and K2 (initial parton momenta)
32020 EL1K10=AZ*ATILK1+BZ*BTILK1
32021 EL1K20=AZ*ATILK2+BZ*BTILK2
32022 EL2K10=EL1K10
32023 EL2K20=EL1K20
32024 EL1K11=1D0/SQRT(2D0)*(AX*ATILK1+BX*BTILK1)
32025 EL1K21=1D0/SQRT(2D0)*(AX*ATILK2+BX*BTILK2)
32026 EL2K11=EL1K11
32027 EL2K21=EL1K21
32028 ENDIF
32029
32030 IF(ISUB.EQ.421) THEN
32031C...g + g -> QQ~[3S11] + g
32032 IF(MSTP(145).EQ.0) THEN
32033* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
32034* & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/(SHTH2*THUH2*UHSH2)
32035 FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
32036 & (SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2
32037* FACQQG=COMFAC*PARU(1)*AS**3*(10D0/81D0)*SQMQQR*
32038* & (SH2/(SHTH2*UHSH2)+TH2/(SHTH2*THUH2)+UH2/(THUH2*UHSH2))
32039 ELSE
32040 FF=-PARU(1)*AS**3*(10D0/81D0)*SQMQQR/THUH2/SHTH2/UHSH2
32041 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
32042 BB=2D0*(SH2+TH2)
32043 CC=2D0*(SH2+UH2)
32044 DD=2D0*SH2
32045 IF(MSTP(147).EQ.0) THEN
32046 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32047 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32048 ELSEIF(MSTP(147).EQ.1) THEN
32049 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32050 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32051 ELSEIF(MSTP(147).EQ.3) THEN
32052 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32053 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32054 ELSEIF(MSTP(147).EQ.4) THEN
32055 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32056 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32057 ELSEIF(MSTP(147).EQ.5) THEN
32058 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32059 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32060 ELSEIF(MSTP(147).EQ.6) THEN
32061 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32062 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32063 ENDIF
32064 FACQQG=COMFAC*FF*FACQQG
32065 ENDIF
32066 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32067 NCHN=NCHN+1
32068 ISIG(NCHN,1)=21
32069 ISIG(NCHN,2)=21
32070 ISIG(NCHN,3)=1
32071 SIGH(NCHN)=FACQQG*PARP(IONIUM+1)
32072 ENDIF
32073
32074 ELSEIF(ISUB.EQ.422) THEN
32075C...g + g -> QQ~[3S18] + g
32076 IF(MSTP(145).EQ.0) THEN
32077 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/72D0)*
32078 & (16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
32079 & (SQMQQ*SQMQQR)*
32080 & ((SH2*THUH2+TH2*UHSH2+UH2*SHTH2)/SHTH2/THUH2/UHSH2)
32081 ELSE
32082 FF=PARU(1)*AS**3*(16D0*SQMQQ**2-27D0*(SHTH2+THUH2+UHSH2))/
32083 & (72D0*SQMQQ*SQMQQR*SHTH2*THUH2*UHSH2)
32084 AA=(SHTH2*UH2+UHSH2*TH2+THUH2*SH2)/2D0
32085 BB=2D0*(SH2+TH2)
32086 CC=2D0*(SH2+UH2)
32087 DD=2D0*SH2
32088 IF(MSTP(147).EQ.0) THEN
32089 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32090 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32091 ELSEIF(MSTP(147).EQ.1) THEN
32092 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32093 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32094 ELSEIF(MSTP(147).EQ.3) THEN
32095 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32096 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32097 ELSEIF(MSTP(147).EQ.4) THEN
32098 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32099 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32100 ELSEIF(MSTP(147).EQ.5) THEN
32101 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32102 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32103 ELSEIF(MSTP(147).EQ.6) THEN
32104 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32105 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32106 ENDIF
32107 FACQQG=COMFAC*FF*FACQQG
32108 ENDIF
32109C...Split total contribution into different colour flows just like
32110C...in g g -> g g (recalculate kinematics for massless partons).
32111 THP=-0.5D0*SH*(1D0-CTH)
32112 UHP=-0.5D0*SH*(1D0+CTH)
32113 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
32114 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
32115 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
32116 FACGGS=FACGG1+FACGG2+FACGG3
32117 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32118 NCHN=NCHN+1
32119 ISIG(NCHN,1)=21
32120 ISIG(NCHN,2)=21
32121 ISIG(NCHN,3)=1
32122 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
32123 NCHN=NCHN+1
32124 ISIG(NCHN,1)=21
32125 ISIG(NCHN,2)=21
32126 ISIG(NCHN,3)=2
32127 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
32128 NCHN=NCHN+1
32129 ISIG(NCHN,1)=21
32130 ISIG(NCHN,2)=21
32131 ISIG(NCHN,3)=3
32132 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG3/FACGGS
32133 ENDIF
32134
32135 ELSEIF(ISUB.EQ.423) THEN
32136C...g + g -> QQ~[1S08] + g
32137 IF(MSTP(145).EQ.0) THEN
32138* FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*
32139* & (SHTH2*UH2+THUH2*SH2+UHSH2*TH2)/(SQMQQR*SH*TH*UH)*
32140* & (12D0*SQMQQ*SH*TH*UH+SHTH2**2+THUH2**2+UHSH2**2)/
32141* & (SHTH2*THUH2*UHSH2)
32142 FACQQG=COMFAC*PARU(1)*AS**3*(5D0/16D0)*SQMQQR*
32143 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
32144 & TH2/(SHTH2*THUH2))*
32145 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
32146 ELSE
32147 FA=PARU(1)*AS**3*(5D0/48D0)*SQMQQR*
32148 & (UH2/(THUH2*UHSH2)+SH2/(SHTH2*UHSH2)+
32149 & TH2/(SHTH2*THUH2))*
32150 & (12D0+(SHTH2**2+THUH2**2+UHSH2**2)/(SQMQQ*SH*TH*UH))
32151 IF(MSTP(147).EQ.0) THEN
32152 FACQQG=COMFAC*FA
32153 ELSEIF(MSTP(147).EQ.1) THEN
32154 FACQQG=COMFAC*2D0*FA
32155 ELSEIF(MSTP(147).EQ.3) THEN
32156 FACQQG=COMFAC*FA
32157 ELSEIF(MSTP(147).EQ.4) THEN
32158 FACQQG=COMFAC*FA
32159 ELSEIF(MSTP(147).EQ.5) THEN
32160 FACQQG=0D0
32161 ELSEIF(MSTP(147).EQ.6) THEN
32162 FACQQG=0D0
32163 ENDIF
32164 ENDIF
32165C...Split total contribution into different colour flows just like
32166C...in g g -> g g (recalculate kinematics for massless partons).
32167 THP=-0.5D0*SH*(1D0-CTH)
32168 UHP=-0.5D0*SH*(1D0+CTH)
32169 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
32170 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
32171 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
32172 FACGGS=FACGG1+FACGG2+FACGG3
32173 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32174 NCHN=NCHN+1
32175 ISIG(NCHN,1)=21
32176 ISIG(NCHN,2)=21
32177 ISIG(NCHN,3)=1
32178 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
32179 NCHN=NCHN+1
32180 ISIG(NCHN,1)=21
32181 ISIG(NCHN,2)=21
32182 ISIG(NCHN,3)=2
32183 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
32184 NCHN=NCHN+1
32185 ISIG(NCHN,1)=21
32186 ISIG(NCHN,2)=21
32187 ISIG(NCHN,3)=3
32188 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG3/FACGGS
32189 ENDIF
32190
32191 ELSEIF(ISUB.EQ.424) THEN
32192C...g + g -> QQ~[3PJ8] + g
32193 POLY=SH2+SH*TH+TH2
32194 IF(MSTP(145).EQ.0) THEN
32195 FACQQG=COMFAC*5D0*PARU(1)*AS**3*(3D0*SH*TH*SHTH*POLY**4
32196 & -SQMQQ*POLY**2*(7D0*SH**6+36D0*SH**5*TH+45D0*SH**4*TH2
32197 & +28D0*SH**3*TH**3+45D0*SH2*TH**4+36D0*SH*TH**5
32198 & +7D0*TH**6)
32199 & +SQMQQ**2*SHTH*(35D0*SH**8+169D0*SH**7*TH
32200 & +299D0*SH**6*TH2+401D0*SH**5*TH**3+418D0*SH**4*TH**4
32201 & +401D0*SH**3*TH**5+299D0*SH2*TH**6+169D0*SH*TH**7
32202 & +35D0*TH**8)
32203 & -SQMQQ**3*(84D0*SH**8+432D0*SH**7*TH+905D0*SH**6*TH2
32204 & +1287D0*SH**5*TH**3+1436D0*SH**4*TH**4
32205 & +1287D0*SH**3*TH**5+905D0*SH2*TH**6+432D0*SH*TH**7
32206 & +84D0*TH**8)
32207 & +SQMQQ**4*SHTH*(126D0*SH**6+451D0*SH**5*TH
32208 & +677D0*SH**4*TH2+836D0*SH**3*TH**3+677D0*SH2*TH**4
32209 & +451D0*SH*TH**5+126D0*TH**6)
32210 & -3D0*SQMQQ**5*(42D0*SH**6+171D0*SH**5*TH
32211 & +304D0*SH**4*TH2+362D0*SH**3*TH**3+304D0*SH2*TH**4
32212 & +171D0*SH*TH**5+42D0*TH**6)
32213 & +2D0*SQMQQ**6*SHTH*(42D0*SH**4+106D0*SH**3*TH
32214 & +119D0*SH2*TH2+106D0*SH*TH**3+42D0*TH**4)
32215 & -SQMQQ**7*(35D0*SH**4+99D0*SH**3*TH+120D0*SH2*TH2
32216 & +99D0*SH*TH**3+35D0*TH**4)
32217 & +7D0*SQMQQ**8*SHTH*POLY)/
32218 & (SH*TH*UH*SQMQQR*SQMQQ*
32219 & SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
32220 ELSE
32221 FF=-5D0*PARU(1)*AS**3/(SH2*TH2*UH2
32222 & *SQMQQR*SQMQQ*SHTH*SHTH2*THUH*THUH2*UHSH*UHSH2)
32223 AA=SH*TH*UH*(SH*TH*SHTH*POLY**4
32224 & -SQMQQ*SHTH2*POLY**2*
32225 & (SH**4+6D0*SH**3*TH-6D0*SH2*TH2+6D0*SH*TH**3+TH**4)
32226 & +SQMQQ**2*SHTH*(5D0*SH**8+35D0*SH**7*TH+49D0*SH**6*TH2
32227 & +57D0*SH**5*TH**3+46D0*SH**4*TH**4+57D0*SH**3*TH**5
32228 & +49D0*SH2*TH**6+35D0*SH*TH**7+5D0*TH**8)
32229 & -SQMQQ**3*(16D0*SH**8+104D0*SH**7*TH+215D0*SH**6*TH2
32230 & +291D0*SH**5*TH**3+316D0*SH**4*TH**4+291D0*SH**3*TH**5
32231 & +215D0*SH2*TH**6+104D0*SH*TH**7+16D0*TH**8)
32232 & +SQMQQ**4*SHTH*(34D0*SH**6+145D0*SH**5*TH
32233 & +211D0*SH**4*TH2+262D0*SH**3*TH**3+211D0*SH2*TH**4
32234 & +145D0*SH*TH**5+34D0*TH**6)
32235 & -SQMQQ**5*(44D0*SH**6+193D0*SH**5*TH+346D0*SH**4*TH2
32236 & +410D0*SH**3*TH**3+346D0*SH2*TH**4+193D0*SH*TH**5
32237 & +44D0*TH**6)
32238 & +2D0*SQMQQ**6*SHTH*(17D0*SH**4+45D0*SH**3*TH
32239 & +49D0*SH2*TH2+45D0*SH*TH**3+17D0*TH**4)
32240 & -SQMQQ**7*(3D0*SH2+2D0*SH*TH+3D0*TH2)
32241 & *(5D0*SH2+11D0*SH*TH+5D0*TH2)
32242 & +3D0*SQMQQ**8*SHTH*POLY)
32243 BB=4D0*SHTH2*POLY**3
32244 & *(SH**4+SH**3*TH-SH2*TH2+SH*TH**3+TH**4)
32245 & -SQMQQ*SHTH*(20D0*SH**10+84D0*SH**9*TH+166D0*SH**8*TH2
32246 & +231D0*SH**7*TH**3+250D0*SH**6*TH**4+250D0*SH**5*TH**5
32247 & +250D0*SH**4*TH**6+231D0*SH**3*TH**7+166D0*SH2*TH**8
32248 & +84D0*SH*TH**9+20D0*TH**10)
32249 & +SQMQQ**2*SHTH2*(40D0*SH**8+86D0*SH**7*TH
32250 & +66D0*SH**6*TH2+67D0*SH**5*TH**3+6D0*SH**4*TH**4
32251 & +67D0*SH**3*TH**5+66D0*SH2*TH**6+86D0*SH*TH**7
32252 & +40D0*TH**8)
32253 & -SQMQQ**3*SHTH*(40D0*SH**8+57D0*SH**7*TH
32254 & -110D0*SH**6*TH2-263D0*SH**5*TH**3-384D0*SH**4*TH**4
32255 & -263D0*SH**3*TH**5-110D0*SH2*TH**6+57D0*SH*TH**7
32256 & +40D0*TH**8)
32257 & +SQMQQ**4*(20D0*SH**8-33D0*SH**7*TH-368D0*SH**6*TH2
32258 & -751D0*SH**5*TH**3-920D0*SH**4*TH**4-751D0*SH**3*TH**5
32259 & -368D0*SH2*TH**6-33D0*SH*TH**7+20D0*TH**8)
32260 & -SQMQQ**5*SHTH*(4D0*SH**6-81D0*SH**5*TH-242D0*SH**4*TH2
32261 & -250D0*SH**3*TH**3-242D0*SH2*TH**4-81D0*SH*TH**5
32262 & +4D0*TH**6)
32263 & -SQMQQ**6*SH*TH*(41D0*SH**4+120D0*SH**3*TH
32264 & +142D0*SH2*TH2+120D0*SH*TH**3+41D0*TH**4)
32265 & +8D0*SQMQQ**7*SH*TH*SHTH*POLY
32266 CC=4D0*TH2*POLY**3
32267 & *(-SH**4-2D0*SH**3*TH+2D0*SH2*TH2+3D0*SH*TH**3+TH**4)
32268 & -SQMQQ*TH2*(-20D0*SH**9-56D0*SH**8*TH-24D0*SH**7*TH2
32269 & +147D0*SH**6*TH**3+409D0*SH**5*TH**4+599D0*SH**4*TH**5
32270 & +571D0*SH**3*TH**6+370D0*SH2*TH**7+148D0*SH*TH**8
32271 & +28D0*TH**9)
32272 & +SQMQQ**2*(4D0*SH**10+20D0*SH**9*TH-16D0*SH**8*TH2
32273 & -48D0*SH**7*TH**3+150D0*SH**6*TH**4+611D0*SH**5*TH**5
32274 & +1060D0*SH**4*TH**6+1155D0*SH**3*TH**7+854D0*SH2*TH**8
32275 & +394D0*SH*TH**9+84D0*TH**10)
32276 & -SQMQQ**3*SHTH*(20D0*SH**8+68D0*SH**7*TH-20D0*SH**6*TH2
32277 & +32D0*SH**5*TH**3+286D0*SH**4*TH**4+577D0*SH**3*TH**5
32278 & +618D0*SH2*TH**6+443D0*SH*TH**7+140D0*TH**8)
32279 & +SQMQQ**4*(40D0*SH**8+152D0*SH**7*TH+94D0*SH**6*TH2
32280 & +38D0*SH**5*TH**3+290D0*SH**4*TH**4+631D0*SH**3*TH**5
32281 & +738D0*SH2*TH**6+513D0*SH*TH**7+140D0*TH**8)
32282 & -SQMQQ**5*(40D0*SH**7+129D0*SH**6*TH+53D0*SH**5*TH2
32283 & +7D0*SH**4*TH**3+129D0*SH**3*TH**4+264D0*SH2*TH**5
32284 & +266D0*SH*TH**6+84D0*TH**7)
32285 & +SQMQQ**6*(20D0*SH**6+55D0*SH**5*TH+2D0*SH**4*TH2
32286 & -15D0*SH**3*TH**3+30D0*SH2*TH**4+76D0*SH*TH**5
32287 & +28D0*TH**6)
32288 & -SQMQQ**7*SHTH*(4D0*SH**4+7D0*SH**3*TH-14D0*SH2*TH2
32289 & +7D0*SH*TH**3+4*TH**4)
32290 & +SQMQQ**8*SH*(SH-TH)**2*TH
32291 DD=2D0*TH2*SHTH2*POLY**3
32292 & *(-SH2+2*SH*TH+2*TH2)
32293 & +SQMQQ*(4D0*SH**11+22D0*SH**10*TH+70D0*SH**9*TH2
32294 & +115D0*SH**8*TH**3+71D0*SH**7*TH**4-119D0*SH**6*TH**5
32295 & -381D0*SH**5*TH**6-552D0*SH**4*TH**7-512D0*SH**3*TH**8
32296 & -320D0*SH2*TH**9-126D0*SH*TH**10-24D0*TH**11)
32297 & -SQMQQ**2*SHTH*(20D0*SH**9+84D0*SH**8*TH
32298 & +212D0*SH**7*TH2+247D0*SH**6*TH**3+105D0*SH**5*TH**4
32299 & -178D0*SH**4*TH**5-380D0*SH**3*TH**6-364D0*SH2*TH**7
32300 & -210D0*SH*TH**8-60D0*TH**9)
32301 & +SQMQQ**3*SHTH*(40D0*SH**8+159D0*SH**7*TH
32302 & +374D0*SH**6*TH2+404D0*SH**5*TH**3+192D0*SH**4*TH**4
32303 & -141D0*SH**3*TH**5-264D0*SH2*TH**6-216D0*SH*TH**7
32304 & -80D0*TH**8)
32305 & -SQMQQ**4*(40D0*SH**8+197D0*SH**7*TH+506D0*SH**6*TH2
32306 & +672D0*SH**5*TH**3+460D0*SH**4*TH**4+79D0*SH**3*TH**5
32307 & -138D0*SH2*TH**6-164D0*SH*TH**7-60D0*TH**8)
32308 & +SQMQQ**5*(20D0*SH**7+107D0*SH**6*TH+267D0*SH**5*TH2
32309 & +307D0*SH**4*TH**3+185D0*SH**3*TH**4+56D0*SH2*TH**5
32310 & -30D0*SH*TH**6-24D0*TH**7)
32311 & -SQMQQ**6*(4D0*SH**6+31D0*SH**5*TH+74D0*SH**4*TH2
32312 & +71D0*SH**3*TH**3+46D0*SH2*TH**4+10D0*SH*TH**5
32313 & -4D0*TH**6)
32314 & +4D0*SQMQQ**7*SH*TH*SHTH*POLY
32315 IF(MSTP(147).EQ.0) THEN
32316 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32317 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32318 ELSEIF(MSTP(147).EQ.1) THEN
32319 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32320 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32321 ELSEIF(MSTP(147).EQ.3) THEN
32322 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32323 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32324 ELSEIF(MSTP(147).EQ.4) THEN
32325 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32326 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32327 ELSEIF(MSTP(147).EQ.5) THEN
32328 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32329 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32330 ELSEIF(MSTP(147).EQ.6) THEN
32331 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32332 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32333 ENDIF
32334 FACQQG=COMFAC*FF*FACQQG
32335 ENDIF
32336C...Split total contribution into different colour flows just like
32337C...in g g -> g g (recalculate kinematics for massless partons).
32338 THP=-0.5D0*SH*(1D0-CTH)
32339 UHP=-0.5D0*SH*(1D0+CTH)
32340 FACGG1=(SH/THP)**2+2D0*SH/THP+3D0+2D0*THP/SH+(THP/SH)**2
32341 FACGG2=(UHP/SH)**2+2D0*UHP/SH+3D0+2D0*SH/UHP+(SH/UHP)**2
32342 FACGG3=(THP/UHP)**2+2D0*THP/UHP+3D0+2D0*UHP/THP+(UHP/THP)**2
32343 FACGGS=FACGG1+FACGG2+FACGG3
32344 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32345 NCHN=NCHN+1
32346 ISIG(NCHN,1)=21
32347 ISIG(NCHN,2)=21
32348 ISIG(NCHN,3)=1
32349 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
32350 NCHN=NCHN+1
32351 ISIG(NCHN,1)=21
32352 ISIG(NCHN,2)=21
32353 ISIG(NCHN,3)=2
32354 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
32355 NCHN=NCHN+1
32356 ISIG(NCHN,1)=21
32357 ISIG(NCHN,2)=21
32358 ISIG(NCHN,3)=3
32359 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG3/FACGGS
32360 ENDIF
32361
32362 ELSEIF(ISUB.EQ.425) THEN
32363C...q + g -> q + QQ~[3S18]
32364 IF(MSTP(145).EQ.0) THEN
32365 FACQQG=-COMFAC*PARU(1)*AS**3*(1D0/27D0)*
32366 & (4D0*(SH2+UH2)-SH*UH)*(SHTH2+THUH2)/
32367 & (SQMQQ*SQMQQR*SH*UH*UHSH2)
32368 ELSE
32369 FF=PARU(1)*AS**3*(4D0*(SH2+UH2)-SH*UH)/
32370 & (54D0*SQMQQ*SQMQQR*SH*UH*UHSH2)
32371 AA=SHTH2+THUH2
32372 BB=4D0
32373 CC=8D0
32374 DD=4D0
32375 IF(MSTP(147).EQ.0) THEN
32376 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32377 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32378 ELSEIF(MSTP(147).EQ.1) THEN
32379 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32380 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32381 ELSEIF(MSTP(147).EQ.3) THEN
32382 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32383 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32384 ELSEIF(MSTP(147).EQ.4) THEN
32385 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32386 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32387 ELSEIF(MSTP(147).EQ.5) THEN
32388 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32389 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32390 ELSEIF(MSTP(147).EQ.6) THEN
32391 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32392 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32393 ENDIF
32394 FACQQG=COMFAC*FF*FACQQG
32395 ENDIF
32396C...Split total contribution into different colour flows just like
32397C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
32398C...(recalculate kinematics for massless partons).
32399 THP=-0.5D0*SH*(1D0-CTH)
32400 UHP=-0.5D0*SH*(1D0+CTH)
32401 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
32402 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
32403 FACQGS=FACQG1+FACQG2
32404 DO 2442 I=MMINA,MMAXA
32405 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2442
32406 DO 2441 ISDE=1,2
32407 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2441
32408 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2441
32409 NCHN=NCHN+1
32410 ISIG(NCHN,ISDE)=I
32411 ISIG(NCHN,3-ISDE)=21
32412 ISIG(NCHN,3)=1
32413 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG1/FACQGS
32414 NCHN=NCHN+1
32415 ISIG(NCHN,ISDE)=I
32416 ISIG(NCHN,3-ISDE)=21
32417 ISIG(NCHN,3)=2
32418 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACQG2/FACQGS
32419 2441 CONTINUE
32420 2442 CONTINUE
32421
32422 ELSEIF(ISUB.EQ.426) THEN
32423C...q + g -> q + QQ~[1S08]
32424 IF(MSTP(145).EQ.0) THEN
32425 FACQQG=-COMFAC*PARU(1)*AS**3*(5D0/18D0)*
32426 & (SH2+UH2)/(SQMQQR*TH*UHSH2)
32427 ELSE
32428 FA=-PARU(1)*AS**3*(5D0/54D0)*(SH2+UH2)/(SQMQQR*TH*UHSH2)
32429 IF(MSTP(147).EQ.0) THEN
32430 FACQQG=COMFAC*FA
32431 ELSEIF(MSTP(147).EQ.1) THEN
32432 FACQQG=COMFAC*2D0*FA
32433 ELSEIF(MSTP(147).EQ.3) THEN
32434 FACQQG=COMFAC*FA
32435 ELSEIF(MSTP(147).EQ.4) THEN
32436 FACQQG=COMFAC*FA
32437 ELSEIF(MSTP(147).EQ.5) THEN
32438 FACQQG=0D0
32439 ELSEIF(MSTP(147).EQ.6) THEN
32440 FACQQG=0D0
32441 ENDIF
32442 ENDIF
32443C...Split total contribution into different colour flows just like
32444C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
32445C...(recalculate kinematics for massless partons).
32446 THP=-0.5D0*SH*(1D0-CTH)
32447 UHP=-0.5D0*SH*(1D0+CTH)
32448 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
32449 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
32450 FACQGS=FACQG1+FACQG2
32451 DO 2444 I=MMINA,MMAXA
32452 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2444
32453 DO 2443 ISDE=1,2
32454 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2443
32455 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2443
32456 NCHN=NCHN+1
32457 ISIG(NCHN,ISDE)=I
32458 ISIG(NCHN,3-ISDE)=21
32459 ISIG(NCHN,3)=1
32460 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG1/FACQGS
32461 NCHN=NCHN+1
32462 ISIG(NCHN,ISDE)=I
32463 ISIG(NCHN,3-ISDE)=21
32464 ISIG(NCHN,3)=2
32465 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACQG2/FACQGS
32466 2443 CONTINUE
32467 2444 CONTINUE
32468
32469 ELSEIF(ISUB.EQ.427) THEN
32470C...q + g -> q + QQ~[3PJ8]
32471 IF(MSTP(145).EQ.0) THEN
32472 FACQQG=-COMFAC*PARU(1)*AS**3*(10D0/9D0)*
32473 & ((7D0*UHSH+8D0*TH)*(SH2+UH2)
32474 & +4D0*TH*(2D0*SQMQQ**2-SHTH2-THUH2))/
32475 & (SQMQQ*SQMQQR*TH*UHSH2*UHSH)
32476 ELSE
32477 FF=10D0*PARU(1)*AS**3/
32478 & (9D0*SQMQQ*SQMQQR*TH2*UHSH2*UHSH)
32479 AA=TH*UHSH*(2D0*SQMQQ**2+SHTH2+THUH2)
32480 BB=8D0*(SHTH2+TH*UH)
32481 CC=8D0*UHSH*(SHTH+THUH)
32482 DD=4D0*(2D0*SQMQQ*SH+TH*UHSH)
32483 IF(MSTP(147).EQ.0) THEN
32484 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32485 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32486 ELSEIF(MSTP(147).EQ.1) THEN
32487 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32488 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32489 ELSEIF(MSTP(147).EQ.3) THEN
32490 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32491 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32492 ELSEIF(MSTP(147).EQ.4) THEN
32493 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32494 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32495 ELSEIF(MSTP(147).EQ.5) THEN
32496 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32497 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32498 ELSEIF(MSTP(147).EQ.6) THEN
32499 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32500 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32501 ENDIF
32502 FACQQG=COMFAC*FF*FACQQG
32503 ENDIF
32504C...Split total contribution into different colour flows just like
32505C...in ISUB.EQ.28 [f + g -> f + g (q + g -> q + g only)]
32506C...(recalculate kinematics for massless partons).
32507 THP=-0.5D0*SH*(1D0-CTH)
32508 UHP=-0.5D0*SH*(1D0+CTH)
32509 FACQG1=9D0/4D0*(UHP/THP)**2-UHP/SH
32510 FACQG2=9D0/4D0*(SH/THP)**2-SH/UHP
32511 FACQGS=FACQG1+FACQG2
32512 DO 2446 I=MMINA,MMAXA
32513 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2446
32514 DO 2445 ISDE=1,2
32515 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2445
32516 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2445
32517 NCHN=NCHN+1
32518 ISIG(NCHN,ISDE)=I
32519 ISIG(NCHN,3-ISDE)=21
32520 ISIG(NCHN,3)=1
32521 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG1/FACQGS
32522 NCHN=NCHN+1
32523 ISIG(NCHN,ISDE)=I
32524 ISIG(NCHN,3-ISDE)=21
32525 ISIG(NCHN,3)=2
32526 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACQG2/FACQGS
32527 2445 CONTINUE
32528 2446 CONTINUE
32529
32530 ELSEIF(ISUB.EQ.428) THEN
32531C...q + q~ -> g + QQ~[3S18]
32532 IF(MSTP(145).EQ.0) THEN
32533 FACQQG=COMFAC*PARU(1)*AS**3*(8D0/81D0)*
32534 & (4D0*(TH2+UH2)-TH*UH)*(SHTH2+UHSH2)/
32535 & (SQMQQ*SQMQQR*TH*UH*THUH2)
32536 ELSE
32537 FF=-4D0*PARU(1)*AS**3*(4D0*(TH2+UH2)-TH*UH)/
32538 & (81D0*SQMQQ*SQMQQR*TH*UH*THUH2)
32539 AA=SHTH2+UHSH2
32540 BB=4D0
32541 CC=4D0
32542 DD=0D0
32543 IF(MSTP(147).EQ.0) THEN
32544 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32545 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32546 ELSEIF(MSTP(147).EQ.1) THEN
32547 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32548 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32549 ELSEIF(MSTP(147).EQ.3) THEN
32550 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32551 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32552 ELSEIF(MSTP(147).EQ.4) THEN
32553 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32554 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32555 ELSEIF(MSTP(147).EQ.5) THEN
32556 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32557 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32558 ELSEIF(MSTP(147).EQ.6) THEN
32559 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32560 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32561 ENDIF
32562 FACQQG=COMFAC*FF*FACQQG
32563 ENDIF
32564C...Split total contribution into different colour flows just like
32565C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32566C...(recalculate kinematics for massless partons).
32567 THP=-0.5D0*SH*(1D0-CTH)
32568 UHP=-0.5D0*SH*(1D0+CTH)
32569 FACGG1=UH/TH-9D0/4D0*UH2/SH2
32570 FACGG2=TH/UH-9D0/4D0*TH2/SH2
32571 FACGGS=FACGG1+FACGG2
32572 DO 2447 I=MMINA,MMAXA
32573 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32574 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2447
32575 NCHN=NCHN+1
32576 ISIG(NCHN,1)=I
32577 ISIG(NCHN,2)=-I
32578 ISIG(NCHN,3)=1
32579 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG1/FACGGS
32580 NCHN=NCHN+1
32581 ISIG(NCHN,1)=I
32582 ISIG(NCHN,2)=-I
32583 ISIG(NCHN,3)=2
32584 SIGH(NCHN)=FACQQG*PARP(IONIUM+2)*FACGG2/FACGGS
32585 2447 CONTINUE
32586
32587 ELSEIF(ISUB.EQ.429) THEN
32588C...q + q~ -> g + QQ~[1S08]
32589 IF(MSTP(145).EQ.0) THEN
32590 FACQQG=COMFAC*PARU(1)*AS**3*(20D0/27D0)*
32591 & (TH2+UH2)/(SQMQQR*SH*THUH2)
32592 ELSE
32593 FA=PARU(1)*AS**3*(20D0/81D0)*(TH2+UH2)/(SQMQQR*SH*THUH2)
32594 IF(MSTP(147).EQ.0) THEN
32595 FACQQG=COMFAC*FA
32596 ELSEIF(MSTP(147).EQ.1) THEN
32597 FACQQG=COMFAC*2D0*FA
32598 ELSEIF(MSTP(147).EQ.3) THEN
32599 FACQQG=COMFAC*FA
32600 ELSEIF(MSTP(147).EQ.4) THEN
32601 FACQQG=COMFAC*FA
32602 ELSEIF(MSTP(147).EQ.5) THEN
32603 FACQQG=0D0
32604 ELSEIF(MSTP(147).EQ.6) THEN
32605 FACQQG=0D0
32606 ENDIF
32607 ENDIF
32608C...Split total contribution into different colour flows just like
32609C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32610C...(recalculate kinematics for massless partons).
32611 THP=-0.5D0*SH*(1D0-CTH)
32612 UHP=-0.5D0*SH*(1D0+CTH)
32613 FACGG1=UH/TH-9D0/4D0*UH2/SH2
32614 FACGG2=TH/UH-9D0/4D0*TH2/SH2
32615 FACGGS=FACGG1+FACGG2
32616 DO 2448 I=MMINA,MMAXA
32617 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32618 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2448
32619 NCHN=NCHN+1
32620 ISIG(NCHN,1)=I
32621 ISIG(NCHN,2)=-I
32622 ISIG(NCHN,3)=1
32623 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG1/FACGGS
32624 NCHN=NCHN+1
32625 ISIG(NCHN,1)=I
32626 ISIG(NCHN,2)=-I
32627 ISIG(NCHN,3)=2
32628 SIGH(NCHN)=FACQQG*PARP(IONIUM+3)*FACGG2/FACGGS
32629 2448 CONTINUE
32630
32631 ELSEIF(ISUB.EQ.430) THEN
32632C...q + q~ -> g + QQ~[3PJ8]
32633 IF(MSTP(145).EQ.0) THEN
32634 FACQQG=COMFAC*PARU(1)*AS**3*(80D0/27D0)*
32635 & ((7D0*THUH+8D0*SH)*(TH2+UH2)
32636 & +4D0*SH*(2D0*SQMQQ**2-SHTH2-UHSH2))/
32637 & (SQMQQ*SQMQQR*SH*THUH2*THUH)
32638 ELSE
32639 FF=-80D0*PARU(1)*AS**3/(27D0*SQMQQ*SQMQQR*SH2*THUH2*THUH)
32640 AA=SH*THUH*(2D0*SQMQQ**2+SHTH2+UHSH2)
32641 BB=8D0*(UHSH2+SH*TH)
32642 CC=8D0*(SHTH2+SH*UH)
32643 DD=4D0*(SHTH2+UHSH2+SH*SQMQQ-SQMQQ**2)
32644 IF(MSTP(147).EQ.0) THEN
32645 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32646 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32647 ELSEIF(MSTP(147).EQ.1) THEN
32648 FACQQG=2D0*(-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32649 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11)))
32650 ELSEIF(MSTP(147).EQ.3) THEN
32651 FACQQG=-AA+SQMQQ*(BB*EL1K10*EL2K10+CC*EL1K20*EL2K20
32652 & +DD*(EL1K10*EL2K20+EL1K20*EL2K10))
32653 ELSEIF(MSTP(147).EQ.4) THEN
32654 FACQQG=-AA+SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32655 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32656 ELSEIF(MSTP(147).EQ.5) THEN
32657 FACQQG=SQMQQ*(BB*EL1K11*EL2K10+CC*EL1K21*EL2K20
32658 & +DD*(EL1K11*EL2K20+EL1K21*EL2K10))
32659 ELSEIF(MSTP(147).EQ.6) THEN
32660 FACQQG=SQMQQ*(BB*EL1K11*EL2K11+CC*EL1K21*EL2K21
32661 & +DD*(EL1K11*EL2K21+EL1K21*EL2K11))
32662 ENDIF
32663 FACQQG=COMFAC*FF*FACQQG
32664 ENDIF
32665C...Split total contribution into different colour flows just like
32666C...in ISUB.EQ.13 [f + fbar -> g + g (q + qbar -> g + g only)]
32667C...(recalculate kinematics for massless partons).
32668 THP=-0.5D0*SH*(1D0-CTH)
32669 UHP=-0.5D0*SH*(1D0+CTH)
32670 FACGG1=UH/TH-9D0/4D0*UH2/SH2
32671 FACGG2=TH/UH-9D0/4D0*TH2/SH2
32672 FACGGS=FACGG1+FACGG2
32673 DO 2449 I=MMINA,MMAXA
32674 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
32675 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2449
32676 NCHN=NCHN+1
32677 ISIG(NCHN,1)=I
32678 ISIG(NCHN,2)=-I
32679 ISIG(NCHN,3)=1
32680 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG1/FACGGS
32681 NCHN=NCHN+1
32682 ISIG(NCHN,1)=I
32683 ISIG(NCHN,2)=-I
32684 ISIG(NCHN,3)=2
32685 SIGH(NCHN)=FACQQG*PARP(IONIUM+4)*FACGG2/FACGGS
32686 2449 CONTINUE
32687
32688 ELSEIF(ISUB.EQ.431) THEN
32689C...g + g -> QQ~[3P01] + g
32690 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32691 QGTW=(SH*TH*UH)/SH**3
32692 RGTW=SQMQQ/SH
32693 IF(MSTP(145).EQ.0) THEN
32694 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32695 & (9D0*RGTW**2*PGTW**4*
32696 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32697 & -6D0*RGTW*PGTW**3*QGTW*
32698 & (2D0*RGTW**4-5D0*RGTW**2*PGTW+PGTW**2)
32699 & -PGTW**2*QGTW**2*(RGTW**4+2D0*RGTW**2*PGTW-PGTW**2)
32700 & +2D0*RGTW*PGTW*QGTW**3*(RGTW**2-PGTW)
32701 & +6D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32702 ELSE
32703 FC1=PARU(1)*AS**3*8D0/(27D0*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 IF(MSTP(147).EQ.0) THEN
32712 FACQQG=COMFAC*FC1
32713 ELSEIF(MSTP(147).EQ.1) THEN
32714 FACQQG=COMFAC*2D0*FC1
32715 ELSEIF(MSTP(147).EQ.3) THEN
32716 FACQQG=COMFAC*FC1
32717 ELSEIF(MSTP(147).EQ.4) THEN
32718 FACQQG=COMFAC*FC1
32719 ELSEIF(MSTP(147).EQ.5) THEN
32720 FACQQG=0D0
32721 ELSEIF(MSTP(147).EQ.6) THEN
32722 FACQQG=0D0
32723 ENDIF
32724 ENDIF
32725 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32726 NCHN=NCHN+1
32727 ISIG(NCHN,1)=21
32728 ISIG(NCHN,2)=21
32729 ISIG(NCHN,3)=1
32730 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32731 ENDIF
32732
32733 ELSEIF(ISUB.EQ.432) THEN
32734C...g + g -> QQ~[3P11] + g
32735 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32736 QGTW=(SH*TH*UH)/SH**3
32737 RGTW=SQMQQ/SH
32738 IF(MSTP(145).EQ.0) THEN
32739 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(3D0*SQMQQR*SH)*
32740 & PGTW**2*(RGTW*PGTW**2*(RGTW**2-4D0*PGTW)
32741 & +2D0*QGTW*(-RGTW**4+5D0*RGTW**2*PGTW+PGTW**2)
32742 & -15D0*RGTW*QGTW**2)/(QGTW-RGTW*PGTW)**4
32743 ELSE
32744 FF=4D0/3D0*PARU(1)*AS**3*SQMQQR/SHTH2**2/THUH2**2/UHSH2**2
32745 C1=(4D0*PGTW**5+23D0*PGTW**2*QGTW**2
32746 & +(-14D0*PGTW**3*QGTW+3D0*QGTW**3)*RGTW
32747 & -(PGTW**4+2D0*PGTW*QGTW**2)*RGTW**2
32748 & +3D0*PGTW**2*QGTW*RGTW**3)*SH2**5
32749 C2=2D0*SHTH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32750 & -TH*UH*(TH-UH)**2)+SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32751 & *(PGTW**2-QGTW*(SH+2D0*UH)/SH))
32752 C3=2D0*UHSH2*(SH2*THUH*(SH*THUH*(SH-TH)*(SH-UH)
32753 & -TH*UH*(TH-UH)**2)-SH2**2*(TH-UH)*(TH2+UH2-SH*THUH)
32754 & *(PGTW**2-QGTW*(SH+2D0*TH)/SH))
32755 C4=-4D0*THUH*(TH-UH)**2*
32756 & (TH**3*UH**3+SH2**2*(2D0*TH+UH)*(TH+2D0*UH)
32757 & -SH2*TH*UH*(TH2+UH2))
32758 & +4D0*THUH2*(SH**3*(SH2**2+TH2**2+UH2**2)
32759 & -SH*TH*UH*(SH2**2+TH*UH*(TH2-3D0*TH*UH+UH2)
32760 & +SH2*(5D0*THUH2-17D0*TH*UH)))
32761 IF(MSTP(147).EQ.0) THEN
32762 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32763 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32764 ELSEIF(MSTP(147).EQ.1) THEN
32765 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32766 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32767 ELSEIF(MSTP(147).EQ.3) THEN
32768 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32769 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32770 ELSEIF(MSTP(147).EQ.4) THEN
32771 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32772 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32773 ELSEIF(MSTP(147).EQ.5) THEN
32774 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32775 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32776 ELSEIF(MSTP(147).EQ.6) THEN
32777 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32778 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32779 ENDIF
32780 FACQQG=COMFAC*FF*FACQQG
32781 ENDIF
32782 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32783 NCHN=NCHN+1
32784 ISIG(NCHN,1)=21
32785 ISIG(NCHN,2)=21
32786 ISIG(NCHN,3)=1
32787 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32788 ENDIF
32789
32790 ELSEIF(ISUB.EQ.433) THEN
32791C...g + g -> QQ~[3P21] + g
32792 PGTW=(SH*TH+TH*UH+UH*SH)/SH2
32793 QGTW=(SH*TH*UH)/SH**3
32794 RGTW=SQMQQ/SH
32795 IF(MSTP(145).EQ.0) THEN
32796 FACQQG=COMFAC*PARU(1)*AS**3*8D0/(9D0*SQMQQR*SH)*
32797 & (12D0*RGTW**2*PGTW**4*
32798 & (RGTW**4-2D0*RGTW**2*PGTW+PGTW**2)
32799 & -3D0*RGTW*PGTW**3*QGTW*
32800 & (8D0*RGTW**4-RGTW**2*PGTW+4D0*PGTW**2)
32801 & +2D0*PGTW**2*QGTW**2*
32802 & (-7D0*RGTW**4+43D0*RGTW**2*PGTW+PGTW**2)
32803 & +RGTW*PGTW*QGTW**3*(16D0*RGTW**2-61D0*PGTW)
32804 & +12D0*RGTW**2*QGTW**4)/(QGTW*(QGTW-RGTW*PGTW)**4)
32805 ELSE
32806 FF=(16D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/
32807 & (3D0*SH2*TH2*UH2*SHTH2**2*THUH2**2*UHSH2**2)
32808 C1=PGTW**2*QGTW*(PGTW*RGTW-QGTW)**2*(RGTW**2-2D0*PGTW)
32809 & *SH*SH2**7
32810 C2=2D0*SHTH2*(-SH2**3*TH2**3-SH**5*TH**5*UH*SHTH
32811 & +SH2**2*TH2**2*UH2*(8D0*SHTH2-5D0*SH*TH)
32812 & +SH**3*TH**3*UH**3*SHTH*(17D0*SHTH2-2D0*SH*TH)
32813 & +SH2*TH2*UH2**2*(105D0*SH2*TH2+64D0*SH*TH*(SH2+TH2)
32814 & +10D0*(SH2**2+TH2**2))
32815 & +SH2*TH2*UH**5*SHTH*(32D0*SHTH2+7D0*SH*TH)
32816 & -UH2**3*(SH2**3-87D0*SH**3*TH**3+TH2**3
32817 & -45D0*SH2*TH2*(SH2+TH2)-5D0*SH*TH*(SH2**2+TH2**2))
32818 & +SH*TH*UH**7*SHTH*(7D0*SHTH2+12D0*SH*TH)
32819 & +4D0*SH*TH*UH2**4*SHTH2)
32820 C3=2D0*UHSH2*(-SH2**3*UH2**3-SH**5*UH**5*TH*UHSH
32821 & +SH2**2*UH2**2*TH2*(8D0*UHSH2-5D0*SH*UH)
32822 & +SH**3*UH**3*TH**3*UHSH*(17D0*UHSH2-2D0*SH*UH)
32823 & +SH2*UH2*TH2**2*(105D0*SH2*UH2+64D0*SH*UH*(SH2+UH2)
32824 & +10D0*(SH2**2+UH2**2))
32825 & +SH2*UH2*TH**5*UHSH*(32D0*UHSH2+7D0*SH*UH)
32826 & -TH2**3*(SH2**3-87D0*SH**3*UH**3+UH2**3
32827 & -45D0*SH2*UH2*(SH2+UH2)-5D0*SH*UH*(SH2**2+UH2**2))
32828 & +SH*UH*TH**7*UHSH*(7D0*UHSH2+12D0*SH*UH)
32829 & +4D0*SH*UH*TH2**4*UHSH2)
32830 C4=-2D0*SHTH*UHSH*(-2D0*TH2**3*UH2**3
32831 & -SH**5*TH2*UH2*THUH*(5D0*TH+3D0*UH)*(3D0*TH+5D0*UH)
32832 & +SH2**3*(2D0*TH+UH)*(TH+2D0*UH)*(TH2-UH2)**2
32833 & -SH*TH2**2*UH2**2*THUH*(5D0*THUH2-4D0*TH*UH)
32834 & -SH2*TH**3*UH**3*THUH2*(13D0*THUH2-16D0*TH*UH)
32835 & -SH**3*TH2*UH2*(92D0*TH2*UH2*THUH
32836 & +53D0*TH*UH*(TH**3+UH**3)+11D0*(TH**5+UH**5))
32837 & -SH2**2*TH*UH*(114D0*TH**3*UH**3
32838 & +83D0*TH2*UH2*(TH2+UH2)+28D0*TH*UH*(TH2**2+UH2**2)
32839 & +3D0*(TH2**3+UH2**3)))
32840 C5=4D0*SH*TH*UH2*SHTH2*(2D0*SH*TH+SH*UH+TH*UH)**2
32841 & *(2D0*UH*SQMQQ**2+SHTH*(SH*TH-UH2))
32842 C6=4D0*SH*UH*TH2*UHSH2*(2D0*SH*UH+SH*TH+TH*UH)**2
32843 & *(2D0*TH*SQMQQ**2+UHSH*(SH*UH-TH2))
32844 C7=4D0*SH*TH*UH2*SHTH*(SH2**2*TH**3*(11D0*SH+16D0*TH)
32845 & +SH**3*TH2*UH*(31D0*SH2+83D0*SH*TH+61D0*TH2)
32846 & +SH2*TH*UH2*(19D0*SH**3+110D0*SH2*TH+156D0*SH*TH2+
32847 & 82D0*TH**3)
32848 & +SH*TH*UH**3*(43D0*SH**3+132D0*SH2*TH+124D0*SH*TH2
32849 & +45D0*TH**3)
32850 & +TH*UH2**2*(37D0*SH**3+68D0*SH2*TH+43D0*SH*TH2+
32851 & 8D0*TH**3)
32852 & +TH*UH**5*(11D0*SH2+13D0*SH*TH+5D0*TH2)
32853 & +SH**3*UH**3*(3D0*UHSH2-2D0*SH*UH)
32854 & +TH**5*UHSH*(5D0*UHSH2+2D0*SH*UH))
32855 C8=4D0*SH*UH*TH2*UHSH*(SH2**2*UH**3*(11D0*SH+16D0*UH)
32856 & +SH**3*UH2*TH*(31D0*SH2+83D0*SH*UH+61D0*UH2)
32857 & +SH2*UH*TH2*(19D0*SH**3+110D0*SH2*UH+156D0*SH*UH2+
32858 & 82D0*UH**3)
32859 & +SH*UH*TH**3*(43D0*SH**3+132D0*SH2*UH+124D0*SH*UH2
32860 & +45D0*UH**3)
32861 & +UH*TH2**2*(37D0*SH**3+68D0*SH2*UH+43D0*SH*UH2+
32862 & 8D0*UH**3)
32863 & +UH*TH**5*(11D0*SH2+13D0*SH*UH+5D0*UH2)
32864 & +SH**3*TH**3*(3D0*SHTH2-2D0*SH*TH)
32865 & +UH**5*SHTH*(5D0*SHTH2+2D0*SH*TH))
32866 C9=4D0*SHTH*UHSH*(2D0*TH**5*UH**5*THUH
32867 & +4D0*SH*TH2**2*UH2**2*THUH2
32868 & -SH2*TH**3*UH**3*THUH*(TH2+UH2)
32869 & -2D0*SH**3*TH2*UH2*(THUH2**2+2D0*TH*UH*THUH2-TH2*UH2)
32870 & +SH2**2*TH*UH*THUH*(-TH*UH*THUH2+3D0*(TH2**2+UH2**2))
32871 & +SH**5*(4D0*TH2*UH2*(THUH2-TH*UH)
32872 & +5D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32873 C0=-4D0*(2D0*TH2**3*UH2**3*SQMQQ
32874 & -SH2*TH2**2*UH2**2*THUH*(19D0*THUH2-4D0*TH*UH)
32875 & -SH**3*TH**3*UH**3*THUH2*(32D0*THUH2+29D0*TH*UH)
32876 & -SH2**2*TH2*UH2*THUH*(264D0*TH2*UH2
32877 & +136D0*TH*UH*(TH2+UH2)+15D0*(TH2**2+UH2**2))
32878 & +SH**5*TH*UH*(-428D0*TH**3*UH**3
32879 & -256D0*TH2*UH2*(TH2+UH2)-43D0*TH*UH*(TH2**2+UH2**2)
32880 & +2D0*(TH2**3+UH2**3))
32881 & +SH**7*(-46D0*TH**3*UH**3-21D0*TH2*UH2*(TH2+UH2)
32882 & +2D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3))
32883 & +SH2**3*THUH*(-134*TH**3*UH**3-53D0*TH2*UH2*(TH2+UH2)
32884 & +4D0*TH*UH*(TH2**2+UH2**2)+2D0*(TH2**3+UH2**3)))
32885 IF(MSTP(147).EQ.0) THEN
32886 FACQQG=1D0/3D0*(C1*3D0
32887 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
32888 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
32889 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
32890 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
32891 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
32892 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32893 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32894 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
32895 & *(EL1K10*EL2K20-EL1K11*EL2K21)
32896 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
32897 & *(EL1K20*EL2K20-EL1K21*EL2K21)
32898 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
32899 ELSEIF(MSTP(147).EQ.1) THEN
32900 FACQQG=C1*2D0
32901 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
32902 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
32903 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
32904 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
32905 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
32906 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
32907 & +EL1K10*EL2K20*EL1K11*EL2K11)
32908 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
32909 & +EL1K10*EL2K20*EL1K21*EL2K21)
32910 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
32911 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
32912 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
32913 & +EL1K20*EL2K20*EL1K11*EL2K11)
32914 ELSEIF(MSTP(147).EQ.2) THEN
32915 FACQQG=2D0*(C1
32916 & -C2*EL1K11*EL2K11
32917 & -C3*EL1K21*EL2K21
32918 & -C4*EL1K11*EL2K21
32919 & +C5*(EL1K11*EL2K11)**2
32920 & +C6*(EL1K21*EL2K21)**2
32921 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
32922 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
32923 & +(C9+C0)*(EL1K11*EL2K21)**2)
32924 ENDIF
32925 FACQQG=COMFAC*FF*FACQQG
32926 ENDIF
32927 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
32928 NCHN=NCHN+1
32929 ISIG(NCHN,1)=21
32930 ISIG(NCHN,2)=21
32931 ISIG(NCHN,3)=1
32932 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32933 ENDIF
32934
32935 ELSEIF(ISUB.EQ.434) THEN
32936C...q + g -> q + QQ~[3P01]
32937 IF(MSTP(145).EQ.0) THEN
32938 FACQQG=-COMFAC*PARU(1)*AS**3*(16D0/81D0)*
32939 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32940 ELSE
32941 FA=-PARU(1)*AS**3*(16D0/243D0)*
32942 & (TH-3D0*SQMQQ)**2*(SH2+UH2)/(SQMQQR*TH*UHSH2**2)
32943 IF(MSTP(147).EQ.0) THEN
32944 FACQQG=COMFAC*FA
32945 ELSEIF(MSTP(147).EQ.1) THEN
32946 FACQQG=COMFAC*2D0*FA
32947 ELSEIF(MSTP(147).EQ.3) THEN
32948 FACQQG=COMFAC*FA
32949 ELSEIF(MSTP(147).EQ.4) THEN
32950 FACQQG=COMFAC*FA
32951 ELSEIF(MSTP(147).EQ.5) THEN
32952 FACQQG=0D0
32953 ELSEIF(MSTP(147).EQ.6) THEN
32954 FACQQG=0D0
32955 ENDIF
32956 ENDIF
32957 DO 2452 I=MMINA,MMAXA
32958 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2452
32959 DO 2451 ISDE=1,2
32960 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2451
32961 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2451
32962 NCHN=NCHN+1
32963 ISIG(NCHN,ISDE)=I
32964 ISIG(NCHN,3-ISDE)=21
32965 ISIG(NCHN,3)=1
32966 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
32967 2451 CONTINUE
32968 2452 CONTINUE
32969
32970 ELSEIF(ISUB.EQ.435) THEN
32971C...q + g -> q + QQ~[3P11]
32972 IF(MSTP(145).EQ.0) THEN
32973 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/27D0)*
32974 & (4D0*SQMQQ*SH*UH+TH*(SH2+UH2))/(SQMQQR*UHSH2**2)
32975 ELSE
32976 FF=(64D0*PARU(1)*AS**3*SQMQQR)/(27D0*UHSH2**2)
32977 C1=SH*UH
32978 C2=2D0*SH
32979 C3=0D0
32980 C4=2D0*(SH-UH)
32981 IF(MSTP(147).EQ.0) THEN
32982 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32983 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32984 ELSEIF(MSTP(147).EQ.1) THEN
32985 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32986 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
32987 ELSEIF(MSTP(147).EQ.3) THEN
32988 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
32989 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
32990 ELSEIF(MSTP(147).EQ.4) THEN
32991 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32992 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32993 ELSEIF(MSTP(147).EQ.5) THEN
32994 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
32995 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
32996 ELSEIF(MSTP(147).EQ.6) THEN
32997 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
32998 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
32999 ENDIF
33000 FACQQG=COMFAC*FF*FACQQG
33001 ENDIF
33002 DO 2454 I=MMINA,MMAXA
33003 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2454
33004 DO 2453 ISDE=1,2
33005 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2453
33006 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2453
33007 NCHN=NCHN+1
33008 ISIG(NCHN,ISDE)=I
33009 ISIG(NCHN,3-ISDE)=21
33010 ISIG(NCHN,3)=1
33011 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33012 2453 CONTINUE
33013 2454 CONTINUE
33014
33015 ELSEIF(ISUB.EQ.436) THEN
33016C...q + g -> q + QQ~[3P21]
33017 IF(MSTP(145).EQ.0) THEN
33018 FACQQG=-COMFAC*PARU(1)*AS**3*(32D0/81D0)*
33019 & ((6D0*SQMQQ**2+TH2)*UHSH2
33020 & -2D0*SH*UH*(TH2+6D0*SQMQQ*UHSH))/
33021 & (SQMQQR*TH*UHSH2**2)
33022 ELSE
33023 FF=-(32D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(27D0*TH2*UHSH2**2)
33024 C1=TH*UHSH2
33025 C2=4D0*(SH2+TH2+2D0*TH*UHSH)
33026 C3=4D0*UHSH2
33027 C4=8D0*SH*UHSH
33028 C5=8D0*TH
33029 C6=0D0
33030 C7=16D0*TH
33031 C8=0D0
33032 C9=-16D0*UHSH
33033 C0=16D0*SQMQQ
33034 IF(MSTP(147).EQ.0) THEN
33035 FACQQG=1D0/3D0*(C1*3D0
33036 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
33037 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
33038 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
33039 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
33040 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
33041 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33042 & *(EL1K10*EL2K20-EL1K11*EL2K21)
33043 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
33044 & *(EL1K10*EL2K20-EL1K11*EL2K21)
33045 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33046 & *(EL1K20*EL2K20-EL1K21*EL2K21)
33047 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
33048 ELSEIF(MSTP(147).EQ.1) THEN
33049 FACQQG=C1*2D0
33050 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
33051 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
33052 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
33053 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
33054 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
33055 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
33056 & +EL1K10*EL2K20*EL1K11*EL2K11)
33057 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
33058 & +EL1K10*EL2K20*EL1K21*EL2K21)
33059 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
33060 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
33061 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
33062 & +EL1K20*EL2K20*EL1K11*EL2K11)
33063 ELSEIF(MSTP(147).EQ.2) THEN
33064 FACQQG=2D0*(C1
33065 & -C2*EL1K11*EL2K11
33066 & -C3*EL1K21*EL2K21
33067 & -C4*EL1K11*EL2K21
33068 & +C5*(EL1K11*EL2K11)**2
33069 & +C6*(EL1K21*EL2K21)**2
33070 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
33071 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
33072 & +(C9+C0)*(EL1K11*EL2K21)**2)
33073 ENDIF
33074 FACQQG=COMFAC*FF*FACQQG
33075 ENDIF
33076 DO 2456 I=MMINA,MMAXA
33077 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 2456
33078 DO 2455 ISDE=1,2
33079 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 2455
33080 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 2455
33081 NCHN=NCHN+1
33082 ISIG(NCHN,ISDE)=I
33083 ISIG(NCHN,3-ISDE)=21
33084 ISIG(NCHN,3)=1
33085 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33086 2455 CONTINUE
33087 2456 CONTINUE
33088
33089 ELSEIF(ISUB.EQ.437) THEN
33090C...q + q~ -> g + QQ~[3P01]
33091 IF(MSTP(145).EQ.0) THEN
33092 FACQQG=COMFAC*PARU(1)*AS**3*(128D0/243D0)*
33093 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
33094 ELSE
33095 FA=PARU(1)*AS**3*(128D0/729D0)*
33096 & (SH-3D0*SQMQQ)**2*(TH2+UH2)/(SQMQQR*SH*THUH2**2)
33097 IF(MSTP(147).EQ.0) THEN
33098 FACQQG=COMFAC*FA
33099 ELSEIF(MSTP(147).EQ.1) THEN
33100 FACQQG=COMFAC*2D0*FA
33101 ELSEIF(MSTP(147).EQ.3) THEN
33102 FACQQG=COMFAC*FA
33103 ELSEIF(MSTP(147).EQ.4) THEN
33104 FACQQG=COMFAC*FA
33105 ELSEIF(MSTP(147).EQ.5) THEN
33106 FACQQG=0D0
33107 ELSEIF(MSTP(147).EQ.6) THEN
33108 FACQQG=0D0
33109 ENDIF
33110 ENDIF
33111 DO 2457 I=MMINA,MMAXA
33112 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33113 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2457
33114 NCHN=NCHN+1
33115 ISIG(NCHN,1)=I
33116 ISIG(NCHN,2)=-I
33117 ISIG(NCHN,3)=1
33118 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33119 2457 CONTINUE
33120
33121 ELSEIF(ISUB.EQ.438) THEN
33122C...q + q~ -> g + QQ~[3P11]
33123 IF(MSTP(145).EQ.0) THEN
33124 FACQQG=COMFAC*PARU(1)*AS**3*256D0/81D0*
33125 & (4D0*SQMQQ*TH*UH+SH*(TH2+UH2))/(SQMQQR*THUH2**2)
33126 ELSE
33127 FF=-(512D0*PARU(1)*AS**3*SQMQQR)/(81D0*THUH2**2)
33128 C1=TH*UH
33129 C2=2D0*UH
33130 C3=2D0*TH
33131 C4=2D0*THUH
33132 IF(MSTP(147).EQ.0) THEN
33133 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
33134 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
33135 ELSEIF(MSTP(147).EQ.1) THEN
33136 FACQQG=2D0*(-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
33137 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0)
33138 ELSEIF(MSTP(147).EQ.3) THEN
33139 FACQQG=-C1+C2*EL1K10*EL2K10+C3*EL1K20*EL2K20
33140 & +C4*(EL1K10*EL2K20+EL1K20*EL2K10)/2D0
33141 ELSEIF(MSTP(147).EQ.4) THEN
33142 FACQQG=-C1+C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
33143 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
33144 ELSEIF(MSTP(147).EQ.5) THEN
33145 FACQQG=C2*EL1K11*EL2K10+C3*EL1K21*EL2K20
33146 & +C4*(EL1K11*EL2K20+EL1K21*EL2K10)/2D0
33147 ELSEIF(MSTP(147).EQ.6) THEN
33148 FACQQG=C2*EL1K11*EL2K11+C3*EL1K21*EL2K21
33149 & +C4*(EL1K11*EL2K21+EL1K21*EL2K11)/2D0
33150 ENDIF
33151 FACQQG=COMFAC*FF*FACQQG
33152 ENDIF
33153 DO 2458 I=MMINA,MMAXA
33154 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33155 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2458
33156 NCHN=NCHN+1
33157 ISIG(NCHN,1)=I
33158 ISIG(NCHN,2)=-I
33159 ISIG(NCHN,3)=1
33160 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33161 2458 CONTINUE
33162
33163 ELSEIF(ISUB.EQ.439) THEN
33164C...q + q~ -> g + QQ~[3P21]
33165 IF(MSTP(145).EQ.0) THEN
33166 FACQQG=COMFAC*PARU(1)*AS**3*(256D0/243D0)*
33167 & ((6D0*SQMQQ**2+SH2)*THUH2
33168 & -2D0*TH*UH*(SH2+6D0*SQMQQ*THUH))/
33169 & (SQMQQR*SH*THUH2**2)
33170 ELSE
33171 FF=(256D0*PARU(1)*AS**3*SQMQQ*SQMQQR)/(81D0*SH2*THUH2**2)
33172 C1=SH*THUH2
33173 C2=4D0*(SH2+UH2+2D0*SH*THUH)
33174 C3=4D0*(SH2+TH2+2D0*SH*THUH)
33175 C4=8D0*(SH2-TH*UH+2D0*SH*THUH)
33176 C5=8D0*SH
33177 C6=C5
33178 C7=16D0*SH
33179 C8=C7
33180 C9=-16D0*THUH
33181 C0=16D0*SQMQQ
33182 IF(MSTP(147).EQ.0) THEN
33183 FACQQG=1D0/3D0*(C1*3D0
33184 & -C2*(2D0*EL1K10*EL2K10+EL1K11*EL2K11)
33185 & -C3*(2D0*EL1K20*EL2K20+EL1K21*EL2K21)
33186 & -C4*(2D0*EL1K10*EL2K20+EL1K11*EL2K21)
33187 & +C5*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)**2
33188 & +C6*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)**2
33189 & +C7*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33190 & *(EL1K10*EL2K20-EL1K11*EL2K21)
33191 & +C8*2D0*(EL1K20*EL2K20-EL1K21*EL2K21)
33192 & *(EL1K10*EL2K20-EL1K11*EL2K21)
33193 & +C9*2D0*(EL1K10*EL2K10-EL1K11*EL2K11)
33194 & *(EL1K20*EL2K20-EL1K21*EL2K21)
33195 & +C0*2D0*(EL1K10*EL2K20-EL1K11*EL2K21)**2)
33196 ELSEIF(MSTP(147).EQ.1) THEN
33197 FACQQG=C1*2D0
33198 & -C2*(EL1K10*EL2K10+EL1K11*EL2K11)
33199 & -C3*(EL1K20*EL2K20+EL1K21*EL2K21)
33200 & -C4*(EL1K10*EL2K20+EL1K11*EL2K21)
33201 & +C5*4D0*EL1K10*EL2K10*EL1K11*EL2K11
33202 & +C6*4D0*EL1K20*EL2K20*EL1K21*EL2K21
33203 & +C7*2D0*(EL1K10*EL2K10*EL1K11*EL2K21
33204 & +EL1K10*EL2K20*EL1K11*EL2K11)
33205 & +C8*2D0*(EL1K20*EL2K20*EL1K11*EL2K21
33206 & +EL1K10*EL2K20*EL1K21*EL2K21)
33207 & +C9*4D0*EL1K10*EL2K20*EL1K11*EL2K21
33208 & +C0*(EL1K10*EL2K10*EL1K21*EL2K21
33209 & +2D0*EL1K10*EL2K20*EL1K11*EL2K21
33210 & +EL1K20*EL2K20*EL1K11*EL2K11)
33211 ELSEIF(MSTP(147).EQ.2) THEN
33212 FACQQG=2D0*(C1
33213 & -C2*EL1K11*EL2K11
33214 & -C3*EL1K21*EL2K21
33215 & -C4*EL1K11*EL2K21
33216 & +C5*(EL1K11*EL2K11)**2
33217 & +C6*(EL1K21*EL2K21)**2
33218 & +C7*EL1K11*EL2K11*EL1K11*EL2K21
33219 & +C8*EL1K21*EL2K21*EL1K11*EL2K21
33220 & +(C9+C0)*(EL1K11*EL2K21)**2)
33221 ENDIF
33222 FACQQG=COMFAC*FF*FACQQG
33223 ENDIF
33224 DO 2459 I=MMINA,MMAXA
33225 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33226 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 2459
33227 NCHN=NCHN+1
33228 ISIG(NCHN,1)=I
33229 ISIG(NCHN,2)=-I
33230 ISIG(NCHN,3)=1
33231 SIGH(NCHN)=FACQQG*PARP(IONIUM+5)
33232 2459 CONTINUE
33233 ENDIF
33234C...QUARKONIA---
33235
33236 ENDIF
33237
33238 RETURN
33239 END
33240
33241C*********************************************************************
33242
33243C...PYSGWZ
33244C...Subprocess cross sections for W/Z processes,
33245C...except that longitudinal WW scattering is in Higgs sector.
33246C...Auxiliary to PYSIGH.
33247
33248 SUBROUTINE PYSGWZ(NCHN,SIGS)
33249
33250C...Double precision and integer declarations
33251 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
33252 IMPLICIT INTEGER(I-N)
33253 INTEGER PYK,PYCHGE,PYCOMP
33254C...Parameter statement to help give large particle numbers.
33255 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
33256 &KEXCIT=4000000,KDIMEN=5000000)
33257C...Commonblocks
33258 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
33259 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
33260 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
33261 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
33262 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
33263 COMMON/PYINT1/MINT(400),VINT(400)
33264 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
33265 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
33266 COMMON/PYINT4/MWID(500),WIDS(500,5)
33267 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
33268 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
33269 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
33270 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
33271 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
33272 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
33273 &/PYINT2/,/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
33274C...Local arrays and complex numbers
33275 DIMENSION WDTP(0:400),WDTE(0:400,0:5),HGZ(6,3),HL3(3),HR3(3),
33276 &HL4(3),HR4(3)
33277 COMPLEX*16 COULCK,COULCP,COULCD,COULCR,COULCS
33278
33279C...Differential cross section expressions.
33280
33281 IF(ISUB.LE.20) THEN
33282 IF(ISUB.EQ.1) THEN
33283C...f + fbar -> gamma*/Z0
33284 MINT(61)=2
33285 CALL PYWIDT(23,SH,WDTP,WDTE)
33286 HS=SHR*WDTP(0)
33287 FACZ=4D0*COMFAC*3D0
33288 HP0=AEM/3D0*SH
33289 HP1=AEM/3D0*XWC*SH
33290 DO 100 I=MMINA,MMAXA
33291 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
33292 EI=KCHG(IABS(I),1)/3D0
33293 AI=SIGN(1D0,EI)
33294 VI=AI-4D0*EI*XWV
33295 HI0=HP0
33296 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
33297 HI1=HP1
33298 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
33299 NCHN=NCHN+1
33300 ISIG(NCHN,1)=I
33301 ISIG(NCHN,2)=-I
33302 ISIG(NCHN,3)=1
33303 SIGH(NCHN)=FACZ*(EI**2/SH2*HI0*HP0*VINT(111)+
33304 & EI*VI*(1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*
33305 & (HI0*HP1+HI1*HP0)*VINT(112)+(VI**2+AI**2)/
33306 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114))
33307 100 CONTINUE
33308
33309 ELSEIF(ISUB.EQ.2) THEN
33310C...f + fbar' -> W+/-
33311 CALL PYWIDT(24,SH,WDTP,WDTE)
33312 HS=SHR*WDTP(0)
33313 FACBW=4D0*COMFAC/((SH-SQMW)**2+HS**2)*3D0
33314 HP=AEM/(24D0*XW)*SH
33315 DO 120 I=MMIN1,MMAX1
33316 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
33317 IA=IABS(I)
33318 DO 110 J=MMIN2,MMAX2
33319 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
33320 JA=IABS(J)
33321 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
33322 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33323 & GOTO 110
33324 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33325 HI=HP*2D0
33326 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
33327 NCHN=NCHN+1
33328 ISIG(NCHN,1)=I
33329 ISIG(NCHN,2)=J
33330 ISIG(NCHN,3)=1
33331 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
33332 SIGH(NCHN)=HI*FACBW*HF
33333 110 CONTINUE
33334 120 CONTINUE
33335
33336 ELSEIF(ISUB.EQ.15) THEN
33337C...f + fbar -> g + (gamma*/Z0) (q + qbar -> g + (gamma*/Z0) only)
33338 FACZG=COMFAC*AS*AEM*(8D0/9D0)*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33339C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33340 HFGG=0D0
33341 HFGZ=0D0
33342 HFZZ=0D0
33343 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33344 DO 130 I=1,MIN(16,MDCY(23,3))
33345 IDC=I+MDCY(23,2)-1
33346 IF(MDME(IDC,1).LT.0) GOTO 130
33347 IMDM=0
33348 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33349 & IMDM=1
33350 IF(I.LE.8) THEN
33351 EF=KCHG(I,1)/3D0
33352 AF=SIGN(1D0,EF+0.1D0)
33353 VF=AF-4D0*EF*XWV
33354 ELSEIF(I.LE.16) THEN
33355 EF=KCHG(I+2,1)/3D0
33356 AF=SIGN(1D0,EF+0.1D0)
33357 VF=AF-4D0*EF*XWV
33358 ENDIF
33359 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33360 IF(4D0*RM1.LT.1D0) THEN
33361 FCOF=1D0
33362 IF(I.LE.8) FCOF=3D0*RADC4
33363 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33364 IF(IMDM.EQ.1) THEN
33365 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33366 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33367 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33368 & AF**2*(1D0-4D0*RM1))*BE34
33369 ENDIF
33370 ENDIF
33371 130 CONTINUE
33372C...Propagators: as simulated in PYOFSH and as desired
33373 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33374 MINT15=MINT(15)
33375 MINT(15)=1
33376 MINT(61)=1
33377 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33378 MINT(15)=MINT15
33379 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33380 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33381 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33382 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33383C...Loop over flavours; consider full gamma/Z structure
33384 DO 140 I=MMINA,MMAXA
33385 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
33386 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 140
33387 EI=KCHG(IABS(I),1)/3D0
33388 AI=SIGN(1D0,EI)
33389 VI=AI-4D0*EI*XWV
33390 NCHN=NCHN+1
33391 ISIG(NCHN,1)=I
33392 ISIG(NCHN,2)=-I
33393 ISIG(NCHN,3)=1
33394 SIGH(NCHN)=FACZG*(EI**2*HFGG+EI*VI*HFGZ+
33395 & (VI**2+AI**2)*HFZZ)/HBW4
33396 140 CONTINUE
33397
33398 ELSEIF(ISUB.EQ.16) THEN
33399C...f + fbar' -> g + W+/- (q + qbar' -> g + W+/- only)
33400 FACWG=COMFAC*AS*AEM/XW*2D0/9D0*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33401C...Propagators: as simulated in PYOFSH and as desired
33402 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33403 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33404 GMMWC=SQRT(SQM4)*WDTP(0)
33405 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33406 FACWG=FACWG*HBW4C/HBW4
33407 DO 160 I=MMIN1,MMAX1
33408 IA=IABS(I)
33409 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 160
33410 DO 150 J=MMIN2,MMAX2
33411 JA=IABS(J)
33412 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 150
33413 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 150
33414 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33415 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33416 FCKM=VCKM((IA+1)/2,(JA+1)/2)
33417 NCHN=NCHN+1
33418 ISIG(NCHN,1)=I
33419 ISIG(NCHN,2)=J
33420 ISIG(NCHN,3)=1
33421 SIGH(NCHN)=FACWG*FCKM*WIDSC
33422 150 CONTINUE
33423 160 CONTINUE
33424
33425 ELSEIF(ISUB.EQ.19) THEN
33426C...f + fbar -> gamma + (gamma*/Z0)
33427 FACGZ=COMFAC*2D0*AEM**2*(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33428C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33429 HFGG=0D0
33430 HFGZ=0D0
33431 HFZZ=0D0
33432 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33433 DO 170 I=1,MIN(16,MDCY(23,3))
33434 IDC=I+MDCY(23,2)-1
33435 IF(MDME(IDC,1).LT.0) GOTO 170
33436 IMDM=0
33437 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33438 & IMDM=1
33439 IF(I.LE.8) THEN
33440 EF=KCHG(I,1)/3D0
33441 AF=SIGN(1D0,EF+0.1D0)
33442 VF=AF-4D0*EF*XWV
33443 ELSEIF(I.LE.16) THEN
33444 EF=KCHG(I+2,1)/3D0
33445 AF=SIGN(1D0,EF+0.1D0)
33446 VF=AF-4D0*EF*XWV
33447 ENDIF
33448 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33449 IF(4D0*RM1.LT.1D0) THEN
33450 FCOF=1D0
33451 IF(I.LE.8) FCOF=3D0*RADC4
33452 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33453 IF(IMDM.EQ.1) THEN
33454 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33455 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33456 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33457 & AF**2*(1D0-4D0*RM1))*BE34
33458 ENDIF
33459 ENDIF
33460 170 CONTINUE
33461C...Propagators: as simulated in PYOFSH and as desired
33462 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33463 MINT15=MINT(15)
33464 MINT(15)=1
33465 MINT(61)=1
33466 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33467 MINT(15)=MINT15
33468 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33469 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33470 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33471 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33472C...Loop over flavours; consider full gamma/Z structure
33473 DO 180 I=MMINA,MMAXA
33474 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 180
33475 EI=KCHG(IABS(I),1)/3D0
33476 AI=SIGN(1D0,EI)
33477 VI=AI-4D0*EI*XWV
33478 FCOI=1D0
33479 IF(IABS(I).LE.10) FCOI=FACA/3D0
33480 NCHN=NCHN+1
33481 ISIG(NCHN,1)=I
33482 ISIG(NCHN,2)=-I
33483 ISIG(NCHN,3)=1
33484 SIGH(NCHN)=FACGZ*FCOI*EI**2*(EI**2*HFGG+EI*VI*HFGZ+
33485 & (VI**2+AI**2)*HFZZ)/HBW4
33486 180 CONTINUE
33487
33488 ELSEIF(ISUB.EQ.20) THEN
33489C...f + fbar' -> gamma + W+/-
33490 FACGW=COMFAC*0.5D0*AEM**2/XW
33491C...Propagators: as simulated in PYOFSH and as desired
33492 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33493 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33494 GMMWC=SQRT(SQM4)*WDTP(0)
33495 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33496 FACGW=FACGW*HBW4C/HBW4
33497C...Anomalous couplings
33498 TERM1=(TH2+UH2+2D0*SQM4*SH)/(TH*UH)
33499 TERM2=0D0
33500 TERM3=0D0
33501 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
33502 TERM2=RTCM(46)*(TH-UH)/(TH+UH)
33503 TERM3=0.5D0*RTCM(46)**2*(TH*UH+(TH2+UH2)*SH/
33504 & (4D0*SQMW))/(TH+UH)**2
33505 ENDIF
33506 DO 200 I=MMIN1,MMAX1
33507 IA=IABS(I)
33508 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 200
33509 DO 190 J=MMIN2,MMAX2
33510 JA=IABS(J)
33511 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 190
33512 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 190
33513 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33514 & GOTO 190
33515 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33516 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33517 IF(IA.LE.10) THEN
33518 FACWR=UH/(TH+UH)-1D0/3D0
33519 FCKM=VCKM((IA+1)/2,(JA+1)/2)
33520 FCOI=FACA/3D0
33521 ELSE
33522 FACWR=-TH/(TH+UH)
33523 FCKM=1D0
33524 FCOI=1D0
33525 ENDIF
33526 FACWK=TERM1*FACWR**2+TERM2*FACWR+TERM3
33527 NCHN=NCHN+1
33528 ISIG(NCHN,1)=I
33529 ISIG(NCHN,2)=J
33530 ISIG(NCHN,3)=1
33531 SIGH(NCHN)=FACGW*FACWK*FCOI*FCKM*WIDSC
33532 190 CONTINUE
33533 200 CONTINUE
33534 ENDIF
33535
33536 ELSEIF(ISUB.LE.40) THEN
33537 IF(ISUB.EQ.22) THEN
33538C...f + fbar -> (gamma*/Z0) + (gamma*/Z0)
33539C...Kinematics dependence
33540 FACZZ=COMFAC*AEM**2*((TH2+UH2+2D0*(SQM3+SQM4)*SH)/(TH*UH)-
33541 & SQM3*SQM4*(1D0/TH2+1D0/UH2))
33542C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33543 DO 220 I=1,6
33544 DO 210 J=1,3
33545 HGZ(I,J)=0D0
33546 210 CONTINUE
33547 220 CONTINUE
33548 RADC3=1D0+PYALPS(SQM3)/PARU(1)
33549 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33550 DO 230 I=1,MIN(16,MDCY(23,3))
33551 IDC=I+MDCY(23,2)-1
33552 IF(MDME(IDC,1).LT.0) GOTO 230
33553 IMDM=0
33554 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2) IMDM=1
33555 IF(MDME(IDC,1).EQ.4.OR.MDME(IDC,1).EQ.5) IMDM=MDME(IDC,1)-2
33556 IF(I.LE.8) THEN
33557 EF=KCHG(I,1)/3D0
33558 AF=SIGN(1D0,EF+0.1D0)
33559 VF=AF-4D0*EF*XWV
33560 ELSEIF(I.LE.16) THEN
33561 EF=KCHG(I+2,1)/3D0
33562 AF=SIGN(1D0,EF+0.1D0)
33563 VF=AF-4D0*EF*XWV
33564 ENDIF
33565 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM3
33566 IF(4D0*RM1.LT.1D0) THEN
33567 FCOF=1D0
33568 IF(I.LE.8) FCOF=3D0*RADC3
33569 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33570 IF(IMDM.GE.1) THEN
33571 HGZ(1,IMDM)=HGZ(1,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33572 HGZ(2,IMDM)=HGZ(2,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33573 HGZ(3,IMDM)=HGZ(3,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
33574 & AF**2*(1D0-4D0*RM1))*BE34
33575 ENDIF
33576 ENDIF
33577 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33578 IF(4D0*RM1.LT.1D0) THEN
33579 FCOF=1D0
33580 IF(I.LE.8) FCOF=3D0*RADC4
33581 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33582 IF(IMDM.GE.1) THEN
33583 HGZ(4,IMDM)=HGZ(4,IMDM)+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33584 HGZ(5,IMDM)=HGZ(5,IMDM)+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33585 HGZ(6,IMDM)=HGZ(6,IMDM)+FCOF*(VF**2*(1D0+2D0*RM1)+
33586 & AF**2*(1D0-4D0*RM1))*BE34
33587 ENDIF
33588 ENDIF
33589 230 CONTINUE
33590C...Propagators: as simulated in PYOFSH and as desired
33591 HBW3=(1D0/PARU(1))*GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
33592 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33593 MINT15=MINT(15)
33594 MINT(15)=1
33595 MINT(61)=1
33596 CALL PYWIDT(23,SQM3,WDTP,WDTE)
33597 MINT(15)=MINT15
33598 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33599 DO 240 J=1,3
33600 HGZ(1,J)=HGZ(1,J)*HFAEM*VINT(111)/SQM3
33601 HGZ(2,J)=HGZ(2,J)*HFAEM*VINT(112)/SQM3
33602 HGZ(3,J)=HGZ(3,J)*HFAEM*VINT(114)/SQM3
33603 240 CONTINUE
33604 MINT15=MINT(15)
33605 MINT(15)=1
33606 MINT(61)=1
33607 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33608 MINT(15)=MINT15
33609 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33610 DO 250 J=1,3
33611 HGZ(4,J)=HGZ(4,J)*HFAEM*VINT(111)/SQM4
33612 HGZ(5,J)=HGZ(5,J)*HFAEM*VINT(112)/SQM4
33613 HGZ(6,J)=HGZ(6,J)*HFAEM*VINT(114)/SQM4
33614 250 CONTINUE
33615C...Loop over flavours; separate left- and right-handed couplings
33616 DO 270 I=MMINA,MMAXA
33617 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 270
33618 EI=KCHG(IABS(I),1)/3D0
33619 AI=SIGN(1D0,EI)
33620 VI=AI-4D0*EI*XWV
33621 VALI=VI-AI
33622 VARI=VI+AI
33623 FCOI=1D0
33624 IF(IABS(I).LE.10) FCOI=FACA/3D0
33625 DO 260 J=1,3
33626 HL3(J)=EI**2*HGZ(1,J)+EI*VALI*HGZ(2,J)+VALI**2*HGZ(3,J)
33627 HR3(J)=EI**2*HGZ(1,J)+EI*VARI*HGZ(2,J)+VARI**2*HGZ(3,J)
33628 HL4(J)=EI**2*HGZ(4,J)+EI*VALI*HGZ(5,J)+VALI**2*HGZ(6,J)
33629 HR4(J)=EI**2*HGZ(4,J)+EI*VARI*HGZ(5,J)+VARI**2*HGZ(6,J)
33630 260 CONTINUE
33631 FACLR=HL3(1)*HL4(1)+HL3(1)*(HL4(2)+HL4(3))+
33632 & HL4(1)*(HL3(2)+HL3(3))+HL3(2)*HL4(3)+HL4(2)*HL3(3)+
33633 & HR3(1)*HR4(1)+HR3(1)*(HR4(2)+HR4(3))+
33634 & HR4(1)*(HR3(2)+HR3(3))+HR3(2)*HR4(3)+HR4(2)*HR3(3)
33635 NCHN=NCHN+1
33636 ISIG(NCHN,1)=I
33637 ISIG(NCHN,2)=-I
33638 ISIG(NCHN,3)=1
33639 SIGH(NCHN)=0.5D0*FACZZ*FCOI*FACLR/(HBW3*HBW4)
33640 270 CONTINUE
33641
33642 ELSEIF(ISUB.EQ.23) THEN
33643C...f + fbar' -> Z0 + W+/- (Z0 only, i.e. no gamma* admixture.)
33644 FACZW=COMFAC*0.5D0*(AEM/XW)**2
33645 FACZW=FACZW*WIDS(23,2)
33646 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33647 FACBW=1D0/((SH-SQMW)**2+GMMW**2)
33648 DO 290 I=MMIN1,MMAX1
33649 IA=IABS(I)
33650 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 290
33651 DO 280 J=MMIN2,MMAX2
33652 JA=IABS(J)
33653 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 280
33654 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 280
33655 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
33656 & GOTO 280
33657 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
33658 EI=KCHG(IA,1)/3D0
33659 AI=SIGN(1D0,EI+0.1D0)
33660 VI=AI-4D0*EI*XWV
33661 EJ=KCHG(JA,1)/3D0
33662 AJ=SIGN(1D0,EJ+0.1D0)
33663 VJ=AJ-4D0*EJ*XWV
33664 IF(VI+AI.GT.0) THEN
33665 VISAV=VI
33666 AISAV=AI
33667 VI=VJ
33668 AI=AJ
33669 VJ=VISAV
33670 AJ=AISAV
33671 ENDIF
33672 FCKM=1D0
33673 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
33674 FCOI=1D0
33675 IF(IA.LE.10) FCOI=FACA/3D0
33676 NCHN=NCHN+1
33677 ISIG(NCHN,1)=I
33678 ISIG(NCHN,2)=J
33679 ISIG(NCHN,3)=1
33680 SIGH(NCHN)=FACZW*FCOI*FCKM*(FACBW*((9D0-8D0*XW)/4D0*THUH+
33681 & (8D0*XW-6D0)/4D0*SH*(SQM3+SQM4))+(THUH-SH*(SQM3+SQM4))*
33682 & (SH-SQMW)*FACBW*0.5D0*((VJ+AJ)/TH-(VI+AI)/UH)+
33683 & THUH/(16D0*XW1)*((VJ+AJ)**2/TH2+(VI+AI)**2/UH2)+
33684 & SH*(SQM3+SQM4)/(8D0*XW1)*(VI+AI)*(VJ+AJ)/(TH*UH))*
33685 & WIDS(24,(5-KCHW)/2)
33686C***Protect against slightly negative cross sections. (Reason yet to be
33687C***sorted out. One possibility: addition of width to the W propagator.)
33688 SIGH(NCHN)=MAX(0D0,SIGH(NCHN))
33689 280 CONTINUE
33690 290 CONTINUE
33691
33692 ELSEIF(ISUB.EQ.25) THEN
33693C...f + fbar -> W+ + W-
33694C...Propagators: Z0, W+- as simulated in PYOFSH and as desired
33695 GMMZC=GMMZ
33696 HBWZC=SH**2/((SH-SQMZ)**2+GMMZC**2)
33697 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
33698 CALL PYWIDT(24,SQM3,WDTP,WDTE)
33699 GMMW3=SQRT(SQM3)*WDTP(0)
33700 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
33701 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33702 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33703 GMMW4=SQRT(SQM4)*WDTP(0)
33704 HBW4C=GMMW4/((SQM4-SQMW)**2+GMMW4**2)
33705C...Kinematical functions
33706 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
33707 THUH34=(2D0*SH*(SQM3+SQM4)+THUH)/(SQM3*SQM4)
33708 GS=(((SH-SQM3-SQM4)**2-4D0*SQM3*SQM4)*THUH34+12D0*THUH)/SH2
33709 GT=THUH34+4D0*THUH/TH2
33710 GST=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/TH)/SH
33711 GU=THUH34+4D0*THUH/UH2
33712 GSU=((SH-SQM3-SQM4)*THUH34+4D0*(SH*(SQM3+SQM4)-THUH)/UH)/SH
33713C...Common factors and couplings
33714 FACWW=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)
33715 FACWW=FACWW*WIDS(24,1)
33716 CGG=AEM**2/2D0
33717 CGZ=AEM**2/(4D0*XW)*HBWZC*(1D0-SQMZ/SH)
33718 CZZ=AEM**2/(32D0*XW**2)*HBWZC
33719 CNG=AEM**2/(4D0*XW)
33720 CNZ=AEM**2/(16D0*XW**2)*HBWZC*(1D0-SQMZ/SH)
33721 CNN=AEM**2/(16D0*XW**2)
33722C...Coulomb factor for W+W- pair
33723 IF(MSTP(40).GE.1.AND.MSTP(40).LE.3) THEN
33724 COULE=(SH-4D0*SQMW)/(4D0*PMAS(24,1))
33725 COULP=MAX(1D-10,0.5D0*BE34*SQRT(SH))
33726 IF(COULE.LT.100D0*PMAS(24,2)) THEN
33727 COULP1=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33728 & PMAS(24,2)**2)-COULE))
33729 ELSE
33730 COULP1=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/COULE))
33731 ENDIF
33732 IF(COULE.GT.-100D0*PMAS(24,2)) THEN
33733 COULP2=SQRT(0.5D0*PMAS(24,1)*(SQRT(COULE**2+
33734 & PMAS(24,2)**2)+COULE))
33735 ELSE
33736 COULP2=SQRT(0.5D0*PMAS(24,1)*(0.5D0*PMAS(24,2)**2/
33737 & ABS(COULE)))
33738 ENDIF
33739 IF(MSTP(40).EQ.1) THEN
33740 COULDC=PARU(1)-2D0*ATAN((COULP1**2+COULP2**2-COULP**2)/
33741 & MAX(1D-10,2D0*COULP*COULP1))
33742 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33743 ELSEIF(MSTP(40).EQ.2) THEN
33744 COULCK=DCMPLX(DBLE(COULP1),DBLE(COULP2))
33745 COULCP=DCMPLX(0D0,DBLE(COULP))
33746 COULCD=(COULCK+COULCP)/(COULCK-COULCP)
33747 COULCR=1D0+DBLE(PARU(101)*SQRT(SH))/
33748 & (4D0*COULCP)*LOG(COULCD)
33749 COULCS=DCMPLX(0D0,0D0)
33750 NSTP=100
33751 DO 300 ISTP=1,NSTP
33752 COULXX=(ISTP-0.5)/NSTP
33753 COULCS=COULCS+(1D0/COULXX)*LOG((1D0+COULXX*COULCD)/
33754 & (1D0+COULXX/COULCD))
33755 300 CONTINUE
33756 COULCR=COULCR+DBLE(PARU(101)**2*SH)/(16D0*COULCP*COULCK)*
33757 & (COULCS/NSTP)
33758 FACCOU=ABS(COULCR)**2
33759 ELSEIF(MSTP(40).EQ.3) THEN
33760 COULDC=PARU(1)-2D0*(1D0-BE34)**2*ATAN((COULP1**2+
33761 & COULP2**2-COULP**2)/MAX(1D-10,2D0*COULP*COULP1))
33762 FACCOU=1D0+0.5D0*PARU(101)*COULDC/MAX(1D-5,BE34)
33763 ENDIF
33764 ELSEIF(MSTP(40).EQ.4) THEN
33765 FACCOU=1D0+0.5D0*PARU(101)*PARU(1)/MAX(1D-5,BE34)
33766 ELSE
33767 FACCOU=1D0
33768 ENDIF
33769 VINT(95)=FACCOU
33770 FACWW=FACWW*FACCOU
33771C...Loop over allowed flavours
33772 DO 310 I=MMINA,MMAXA
33773 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
33774 EI=KCHG(IABS(I),1)/3D0
33775 AI=SIGN(1D0,EI+0.1D0)
33776 VI=AI-4D0*EI*XWV
33777 FCOI=1D0
33778 IF(IABS(I).LE.10) FCOI=FACA/3D0
33779 IF(MSTP(50).LE.0.OR.IABS(I).LE.10) THEN
33780 IF(AI.LT.0D0) THEN
33781 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS+
33782 & (CNG*EI+CNZ*(VI+AI))*GST+CNN*GT
33783 ELSE
33784 DSIGWW=(CGG*EI**2+CGZ*VI*EI+CZZ*(VI**2+AI**2))*GS-
33785 & (CNG*EI+CNZ*(VI+AI))*GSU+CNN*GU
33786 ENDIF
33787 ELSE
33788 XMW02=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
33789 BET=SQRT(1D0-4D0*XMW02/SH)
33790 GAT=1D0/SQRT(1D0-BET**2)
33791 STHE2=1D0-CTH**2
33792 AMPZG=BET**3*(16D0+(4D0*BET**2*GAT**2+3D0/GAT**2)*STHE2)
33793 AMPNU=BET*(2D0+BET**2*GAT**2*STHE2/2D0+
33794 & 2D0*BET**2*(1D0-BET**2)*STHE2/(1D0-2D0*BET*CTH+BET**2)**2)
33795 AMPNG=BET*((1D0+BET**2)*(4D0+BET**2*GAT**2*STHE2)+
33796 & 2D0*(1D0-BET**2)*(BET**2*STHE2-2D0*(1D0-BET**2))/
33797 & (1D0-2D0*BET*CTH+BET**2))
33798 PROPI1=(0.25D0*SQMZ/XMW02)*HBWZC*(1D0-SQMZ/SH)
33799 PROPI2=(0.25D0*SQMZ/XMW02)**2*HBWZC
33800 A0=(2D0*(XMW02/SQMZ)-(1D0-BET**2)*XW)*POLL
33801 A1=(2D0*(XMW02/SQMZ)**2-2*XMW02/SQMZ*(1D0-BET**2)*XW)*POLL
33802 A2=(1D0-BET**2)**2*XW**2*(POLR+POLL)/2D0
33803 ATOT=AMPNU*POLL+(A1+A2)*PROPI2*AMPZG-A0*PROPI1*AMPNG
33804 ATOT=ATOT*CNN/SQMW*SH/BET*2D0
33805 DSIGWW=ATOT
33806 ENDIF
33807 NCHN=NCHN+1
33808 ISIG(NCHN,1)=I
33809 ISIG(NCHN,2)=-I
33810 ISIG(NCHN,3)=1
33811 SIGH(NCHN)=FACWW*FCOI*DSIGWW
33812 310 CONTINUE
33813
33814 ELSEIF(ISUB.EQ.30) THEN
33815C...f + g -> f + (gamma*/Z0) (q + g -> q + (gamma*/Z0) only)
33816 FZQ=COMFAC*FACA*AS*AEM*(1D0/3D0)*(SH2+UH2+2D0*SQM4*TH)/
33817 & (-SH*UH)
33818C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33819 HFGG=0D0
33820 HFGZ=0D0
33821 HFZZ=0D0
33822 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33823 DO 320 I=1,MIN(16,MDCY(23,3))
33824 IDC=I+MDCY(23,2)-1
33825 IF(MDME(IDC,1).LT.0) GOTO 320
33826 IMDM=0
33827 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33828 & IMDM=1
33829 IF(I.LE.8) THEN
33830 EF=KCHG(I,1)/3D0
33831 AF=SIGN(1D0,EF+0.1D0)
33832 VF=AF-4D0*EF*XWV
33833 ELSEIF(I.LE.16) THEN
33834 EF=KCHG(I+2,1)/3D0
33835 AF=SIGN(1D0,EF+0.1D0)
33836 VF=AF-4D0*EF*XWV
33837 ENDIF
33838 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33839 IF(4D0*RM1.LT.1D0) THEN
33840 FCOF=1D0
33841 IF(I.LE.8) FCOF=3D0*RADC4
33842 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33843 IF(IMDM.EQ.1) THEN
33844 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33845 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33846 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33847 & AF**2*(1D0-4D0*RM1))*BE34
33848 ENDIF
33849 ENDIF
33850 320 CONTINUE
33851C...Propagators: as simulated in PYOFSH and as desired
33852 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33853 MINT15=MINT(15)
33854 MINT(15)=1
33855 MINT(61)=1
33856 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33857 MINT(15)=MINT15
33858 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33859 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33860 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33861 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33862C...Loop over flavours; consider full gamma/Z structure
33863 DO 340 I=MMINA,MMAXA
33864 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
33865 EI=KCHG(IABS(I),1)/3D0
33866 AI=SIGN(1D0,EI)
33867 VI=AI-4D0*EI*XWV
33868 FACZQ=FZQ*(EI**2*HFGG+EI*VI*HFGZ+
33869 & (VI**2+AI**2)*HFZZ)/HBW4
33870 DO 330 ISDE=1,2
33871 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
33872 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
33873 NCHN=NCHN+1
33874 ISIG(NCHN,ISDE)=I
33875 ISIG(NCHN,3-ISDE)=21
33876 ISIG(NCHN,3)=1
33877 SIGH(NCHN)=FACZQ
33878 330 CONTINUE
33879 340 CONTINUE
33880
33881 ELSEIF(ISUB.EQ.31) THEN
33882C...f + g -> f' + W+/- (q + g -> q' + W+/- only)
33883 FACWQ=COMFAC*FACA*AS*AEM/XW*1D0/12D0*
33884 & (SH2+UH2+2D0*SQM4*TH)/(-SH*UH)
33885C...Propagators: as simulated in PYOFSH and as desired
33886 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33887 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33888 GMMWC=SQRT(SQM4)*WDTP(0)
33889 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33890 FACWQ=FACWQ*HBW4C/HBW4
33891 DO 360 I=MMINA,MMAXA
33892 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
33893 IA=IABS(I)
33894 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
33895 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
33896 DO 350 ISDE=1,2
33897 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
33898 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
33899 NCHN=NCHN+1
33900 ISIG(NCHN,ISDE)=I
33901 ISIG(NCHN,3-ISDE)=21
33902 ISIG(NCHN,3)=1
33903 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
33904 350 CONTINUE
33905 360 CONTINUE
33906
33907 ELSEIF(ISUB.EQ.35) THEN
33908C...f + gamma -> f + (gamma*/Z0)
33909 IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) THEN
33910 FZQN=SH2+UH2+2D0*(SQM4-VINT(3)**2)*TH
33911 FZQDTM=VINT(3)**2*SQM4-SH*(UH-VINT(4)**2)
33912 ELSEIF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) THEN
33913 FZQN=SH2+UH2+2D0*(SQM4-VINT(4)**2)*TH
33914 FZQDTM=VINT(4)**2*SQM4-SH*(UH-VINT(3)**2)
33915 ELSE
33916 FZQN=SH2+UH2+2D0*SQM4*TH
33917 FZQDTM=-SH*UH
33918 ENDIF
33919 FZQN=COMFAC*2D0*AEM**2*MAX(0D0,FZQN)
33920C...gamma, gamma/Z interference and Z couplings to final fermion pairs
33921 HFGG=0D0
33922 HFGZ=0D0
33923 HFZZ=0D0
33924 RADC4=1D0+PYALPS(SQM4)/PARU(1)
33925 DO 370 I=1,MIN(16,MDCY(23,3))
33926 IDC=I+MDCY(23,2)-1
33927 IF(MDME(IDC,1).LT.0) GOTO 370
33928 IMDM=0
33929 IF(MDME(IDC,1).EQ.1.OR.MDME(IDC,1).EQ.2.OR.MDME(IDC,1).EQ.4)
33930 & IMDM=1
33931 IF(I.LE.8) THEN
33932 EF=KCHG(I,1)/3D0
33933 AF=SIGN(1D0,EF+0.1D0)
33934 VF=AF-4D0*EF*XWV
33935 ELSEIF(I.LE.16) THEN
33936 EF=KCHG(I+2,1)/3D0
33937 AF=SIGN(1D0,EF+0.1D0)
33938 VF=AF-4D0*EF*XWV
33939 ENDIF
33940 RM1=PMAS(IABS(KFDP(IDC,1)),1)**2/SQM4
33941 IF(4D0*RM1.LT.1D0) THEN
33942 FCOF=1D0
33943 IF(I.LE.8) FCOF=3D0*RADC4
33944 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
33945 IF(IMDM.EQ.1) THEN
33946 HFGG=HFGG+FCOF*EF**2*(1D0+2D0*RM1)*BE34
33947 HFGZ=HFGZ+FCOF*EF*VF*(1D0+2D0*RM1)*BE34
33948 HFZZ=HFZZ+FCOF*(VF**2*(1D0+2D0*RM1)+
33949 & AF**2*(1D0-4D0*RM1))*BE34
33950 ENDIF
33951 ENDIF
33952 370 CONTINUE
33953C...Propagators: as simulated in PYOFSH and as desired
33954 HBW4=(1D0/PARU(1))*GMMZ/((SQM4-SQMZ)**2+GMMZ**2)
33955 MINT15=MINT(15)
33956 MINT(15)=1
33957 MINT(61)=1
33958 CALL PYWIDT(23,SQM4,WDTP,WDTE)
33959 MINT(15)=MINT15
33960 HFAEM=(PARU(108)/PARU(2))*(2D0/3D0)
33961 HFGG=HFGG*HFAEM*VINT(111)/SQM4
33962 HFGZ=HFGZ*HFAEM*VINT(112)/SQM4
33963 HFZZ=HFZZ*HFAEM*VINT(114)/SQM4
33964C...Loop over flavours; consider full gamma/Z structure
33965 DO 390 I=MMINA,MMAXA
33966 IF(I.EQ.0) GOTO 390
33967 EI=KCHG(IABS(I),1)/3D0
33968 AI=SIGN(1D0,EI)
33969 VI=AI-4D0*EI*XWV
33970 FACZQ=EI**2*(EI**2*HFGG+EI*VI*HFGZ+
33971 & (VI**2+AI**2)*HFZZ)/HBW4
33972 FZQD=MAX(PMAS(IABS(I),1)**2*SQM4,FZQDTM)
33973 DO 380 ISDE=1,2
33974 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 380
33975 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 380
33976 NCHN=NCHN+1
33977 ISIG(NCHN,ISDE)=I
33978 ISIG(NCHN,3-ISDE)=22
33979 ISIG(NCHN,3)=1
33980 SIGH(NCHN)=FACZQ*FZQN/FZQD
33981 380 CONTINUE
33982 390 CONTINUE
33983
33984 ELSEIF(ISUB.EQ.36) THEN
33985C...f + gamma -> f' + W+/-
33986 FWQ=COMFAC*AEM**2/(2D0*XW)*
33987 & (SH2+UH2+2D0*SQM4*TH)/(SQPTH*SQM4-SH*UH)
33988C...Propagators: as simulated in PYOFSH and as desired
33989 HBW4=GMMW/((SQM4-SQMW)**2+GMMW**2)
33990 CALL PYWIDT(24,SQM4,WDTP,WDTE)
33991 GMMWC=SQRT(SQM4)*WDTP(0)
33992 HBW4C=GMMWC/((SQM4-SQMW)**2+GMMWC**2)
33993 FWQ=FWQ*HBW4C/HBW4
33994 DO 410 I=MMINA,MMAXA
33995 IF(I.EQ.0) GOTO 410
33996 IA=IABS(I)
33997 EIA=ABS(KCHG(IABS(I),1)/3D0)
33998 FACWQ=FWQ*(EIA-SH/(SH+UH))**2
33999 KCHW=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
34000 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))/WDTP(0)
34001 DO 400 ISDE=1,2
34002 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 400
34003 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 400
34004 NCHN=NCHN+1
34005 ISIG(NCHN,ISDE)=I
34006 ISIG(NCHN,3-ISDE)=22
34007 ISIG(NCHN,3)=1
34008 SIGH(NCHN)=FACWQ*VINT(180+I)*WIDSC
34009 400 CONTINUE
34010 410 CONTINUE
34011 ENDIF
34012
34013 ELSEIF(ISUB.LE.100) THEN
34014 IF(ISUB.EQ.69) THEN
34015C...gamma + gamma -> W+ + W-
34016 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
34017 FPROP=SH2/((SQMWE-TH)*(SQMWE-UH))
34018 FACWW=COMFAC*6D0*AEM**2*(1D0-FPROP*(4D0/3D0+2D0*SQMWE/SH)+
34019 & FPROP**2*(2D0/3D0+2D0*(SQMWE/SH)**2))*WIDS(24,1)
34020 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 420
34021 NCHN=NCHN+1
34022 ISIG(NCHN,1)=22
34023 ISIG(NCHN,2)=22
34024 ISIG(NCHN,3)=1
34025 SIGH(NCHN)=FACWW
34026 420 CONTINUE
34027
34028 ELSEIF(ISUB.EQ.70) THEN
34029C...gamma + W+/- -> Z0 + W+/-
34030 SQMWE=MAX(0.5D0*SQMW,SQRT(SQM3*SQM4))
34031 FPROP=(TH-SQMWE)**2/(-SH*(SQMWE-UH))
34032 FACZW=COMFAC*6D0*AEM**2*(XW1/XW)*
34033 & (1D0-FPROP*(4D0/3D0+2D0*SQMWE/(TH-SQMWE))+
34034 & FPROP**2*(2D0/3D0+2D0*(SQMWE/(TH-SQMWE))**2))*WIDS(23,2)
34035 DO 440 KCHW=1,-1,-2
34036 DO 430 ISDE=1,2
34037 IF(KFAC(ISDE,22)*KFAC(3-ISDE,24*KCHW).EQ.0) GOTO 430
34038 NCHN=NCHN+1
34039 ISIG(NCHN,ISDE)=22
34040 ISIG(NCHN,3-ISDE)=24*KCHW
34041 ISIG(NCHN,3)=1
34042 SIGH(NCHN)=FACZW*WIDS(24,(5-KCHW)/2)
34043 430 CONTINUE
34044 440 CONTINUE
34045 ENDIF
34046 ENDIF
34047
34048 RETURN
34049 END
34050
34051C*********************************************************************
34052
34053C...PYSGHG
34054C...Subprocess cross sections for Higgs processes,
34055C...except Higgs pairs in PYSGSU, but including WW scattering.
34056C...Auxiliary to PYSIGH.
34057
34058 SUBROUTINE PYSGHG(NCHN,SIGS)
34059
34060C...Double precision and integer declarations
34061 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
34062 IMPLICIT INTEGER(I-N)
34063 INTEGER PYK,PYCHGE,PYCOMP
34064C...Parameter statement to help give large particle numbers.
34065 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
34066 &KEXCIT=4000000,KDIMEN=5000000)
34067C...Commonblocks
34068 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
34069 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
34070 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
34071 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
34072 COMMON/PYINT1/MINT(400),VINT(400)
34073 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
34074 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
34075 COMMON/PYINT4/MWID(500),WIDS(500,5)
34076 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
34077 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
34078 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
34079 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
34080 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
34081 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
34082 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
34083 &/PYINT3/,/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/
34084C...Local arrays and complex variables
34085 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
34086 COMPLEX*16 A004,A204,A114,A00U,A20U,A11U
34087 COMPLEX*16 CIGTOT,CIZTOT,F0ALP,F1ALP,F2ALP,F0BET,F1BET,F2BET,FIF
34088
34089C...Convert H or A process into equivalent h one
34090 IHIGG=1
34091 KFHIGG=25
34092 IF(ISUB.EQ.401.OR.ISUB.EQ.402) THEN
34093 KFHIGG=KFPR(ISUB,1)
34094 END IF
34095 IF((ISUB.GE.151.AND.ISUB.LE.160).OR.(ISUB.GE.171.AND.
34096 &ISUB.LE.190)) THEN
34097 IHIGG=2
34098 IF(MOD(ISUB-1,10).GE.5) IHIGG=3
34099 KFHIGG=33+IHIGG
34100 IF(ISUB.EQ.151.OR.ISUB.EQ.156) ISUB=3
34101 IF(ISUB.EQ.152.OR.ISUB.EQ.157) ISUB=102
34102 IF(ISUB.EQ.153.OR.ISUB.EQ.158) ISUB=103
34103 IF(ISUB.EQ.171.OR.ISUB.EQ.176) ISUB=24
34104 IF(ISUB.EQ.172.OR.ISUB.EQ.177) ISUB=26
34105 IF(ISUB.EQ.173.OR.ISUB.EQ.178) ISUB=123
34106 IF(ISUB.EQ.174.OR.ISUB.EQ.179) ISUB=124
34107 IF(ISUB.EQ.181.OR.ISUB.EQ.186) ISUB=121
34108 IF(ISUB.EQ.182.OR.ISUB.EQ.187) ISUB=122
34109 IF(ISUB.EQ.183.OR.ISUB.EQ.188) ISUB=111
34110 IF(ISUB.EQ.184.OR.ISUB.EQ.189) ISUB=112
34111 IF(ISUB.EQ.185.OR.ISUB.EQ.190) ISUB=113
34112 ENDIF
34113 SQMH=PMAS(KFHIGG,1)**2
34114 GMMH=PMAS(KFHIGG,1)*PMAS(KFHIGG,2)
34115
34116C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34117 IF((MSTP(46).GE.3.AND.MSTP(46).LE.6).AND.(ISUB.EQ.71.OR.ISUB.EQ.
34118 &72.OR.ISUB.EQ.73.OR.ISUB.EQ.76.OR.ISUB.EQ.77)) THEN
34119C...Calculate M_R and N_R functions for Higgs-like and QCD-like models
34120 IF(MSTP(46).LE.4) THEN
34121 HDTLH=LOG(PMAS(25,1)/PARP(44))
34122 HDTMR=(4.5D0*PARU(1)/SQRT(3D0)-74D0/9D0)/8D0+HDTLH/12D0
34123 HDTNR=-1D0/18D0+HDTLH/6D0
34124 ELSE
34125 HDTNM=0.125D0*(1D0/(288D0*PARU(1)**2)+(PARP(47)/PARP(45))**2)
34126 HDTLQ=LOG(PARP(45)/PARP(44))
34127 HDTMR=-(4D0*PARU(1))**2*0.5D0*HDTNM+HDTLQ/12D0
34128 HDTNR=(4D0*PARU(1))**2*HDTNM+HDTLQ/6D0
34129 ENDIF
34130
34131C...Calculate lowest and next-to-lowest order partial wave amplitudes
34132 HDTV=1D0/(16D0*PARU(1)*PARP(47)**2)
34133 A00L=DBLE(HDTV*SH)
34134 A20L=-0.5D0*A00L
34135 A11L=A00L/6D0
34136 HDTLS=LOG(SH/PARP(44)**2)
34137 A004=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
34138 & CMPLX(DBLE((176D0*HDTMR+112D0*HDTNR)/3D0+11D0/27D0-
34139 & (50D0/9D0)*HDTLS),DBLE(4D0*PARU(1)))
34140 A204=DBLE((HDTV*SH)**2/(4D0*PARU(1)))*
34141 & CMPLX(DBLE(32D0*(HDTMR+2D0*HDTNR)/3D0+25D0/54D0-
34142 & (20D0/9D0)*HDTLS),DBLE(PARU(1)))
34143 A114=DBLE((HDTV*SH)**2/(6D0*PARU(1)))*
34144 & CMPLX(DBLE(4D0*(-2D0*HDTMR+HDTNR)-1D0/18D0),DBLE(PARU(1)/6D0))
34145
34146C...Unitarize partial wave amplitudes with Pade or K-matrix method
34147 IF(MSTP(46).EQ.3.OR.MSTP(46).EQ.5) THEN
34148 A00U=A00L/(1D0-A004/A00L)
34149 A20U=A20L/(1D0-A204/A20L)
34150 A11U=A11L/(1D0-A114/A11L)
34151 ELSE
34152 A00U=(A00L+DBLE(A004))/(1D0-DCMPLX(0.D0,A00L+DBLE(A004)))
34153 A20U=(A20L+DBLE(A204))/(1D0-DCMPLX(0.D0,A20L+DBLE(A204)))
34154 A11U=(A11L+DBLE(A114))/(1D0-DCMPLX(0.D0,A11L+DBLE(A114)))
34155 ENDIF
34156 ENDIF
34157
34158C...Differential cross section expressions.
34159
34160 IF(ISUB.LE.60) THEN
34161 IF(ISUB.EQ.3) THEN
34162C...f + fbar -> h0 (or H0, or A0)
34163 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34164 HS=SHR*WDTP(0)
34165 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34166 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34167 & FACBW=0D0
34168 HP=AEM/(8D0*XW)*SH/SQMW*SH
34169 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34170 DO 100 I=MMINA,MMAXA
34171 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
34172 IA=IABS(I)
34173 RMQ=PYMRUN(IA,SH)**2/SH
34174 HI=HP*RMQ
34175 IF(IA.LE.10) HI=HP*RMQ*FACA/3D0
34176 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
34177 IKFI=1
34178 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
34179 IF(IA.GT.10) IKFI=3
34180 HI=HI*PARU(150+10*IHIGG+IKFI)**2
34181 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
34182 HI=HI/(1D0+RMSS(41))**2
34183 IF(IHIGG.NE.3) THEN
34184 HI=HI*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
34185 & PARU(151+10*IHIGG))**2
34186 ENDIF
34187 ENDIF
34188 ENDIF
34189 NCHN=NCHN+1
34190 ISIG(NCHN,1)=I
34191 ISIG(NCHN,2)=-I
34192 ISIG(NCHN,3)=1
34193 SIGH(NCHN)=HI*FACBW*HF
34194 100 CONTINUE
34195
34196 ELSEIF(ISUB.EQ.5) THEN
34197C...Z0 + Z0 -> h0
34198 CALL PYWIDT(25,SH,WDTP,WDTE)
34199 HS=SHR*WDTP(0)
34200 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34201 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
34202 HP=AEM/(8D0*XW)*SH/SQMW*SH
34203 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34204 HI=HP/4D0
34205 FACI=8D0/(PARU(1)**2*XW1)*(AEM*XWC)**2
34206 DO 120 I=MMIN1,MMAX1
34207 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
34208 DO 110 J=MMIN2,MMAX2
34209 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
34210 EI=KCHG(IABS(I),1)/3D0
34211 AI=SIGN(1D0,EI)
34212 VI=AI-4D0*EI*XWV
34213 EJ=KCHG(IABS(J),1)/3D0
34214 AJ=SIGN(1D0,EJ)
34215 VJ=AJ-4D0*EJ*XWV
34216 NCHN=NCHN+1
34217 ISIG(NCHN,1)=I
34218 ISIG(NCHN,2)=J
34219 ISIG(NCHN,3)=1
34220 SIGH(NCHN)=FACI*(VI**2+AI**2)*(VJ**2+AJ**2)*HI*FACBW*HF
34221 110 CONTINUE
34222 120 CONTINUE
34223
34224 ELSEIF(ISUB.EQ.8) THEN
34225C...W+ + W- -> h0
34226 CALL PYWIDT(25,SH,WDTP,WDTE)
34227 HS=SHR*WDTP(0)
34228 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34229 IF(ABS(SHR-PMAS(25,1)).GT.PARP(48)*PMAS(25,2)) FACBW=0D0
34230 HP=AEM/(8D0*XW)*SH/SQMW*SH
34231 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34232 HI=HP/2D0
34233 FACI=1D0/(4D0*PARU(1)**2)*(AEM/XW)**2
34234 DO 140 I=MMIN1,MMAX1
34235 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
34236 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34237 DO 130 J=MMIN2,MMAX2
34238 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
34239 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34240 IF(EI*EJ.GT.0D0) GOTO 130
34241 NCHN=NCHN+1
34242 ISIG(NCHN,1)=I
34243 ISIG(NCHN,2)=J
34244 ISIG(NCHN,3)=1
34245 SIGH(NCHN)=FACI*VINT(180+I)*VINT(180+J)*HI*FACBW*HF
34246 130 CONTINUE
34247 140 CONTINUE
34248
34249 ELSEIF(ISUB.EQ.24) THEN
34250C...f + fbar -> Z0 + h0 (or H0, or A0)
34251C...Propagators: Z0, h0 as simulated in PYOFSH and as desired
34252 HBW3=GMMZ/((SQM3-SQMZ)**2+GMMZ**2)
34253 CALL PYWIDT(23,SQM3,WDTP,WDTE)
34254 GMMZ3=SQRT(SQM3)*WDTP(0)
34255 HBW3C=GMMZ3/((SQM3-SQMZ)**2+GMMZ3**2)
34256 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34257 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34258 GMMH4=SQRT(SQM4)*WDTP(0)
34259 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
34260 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
34261 FACHZ=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*8D0*(AEM*XWC)**2*
34262 & (THUH+2D0*SH*SQM3)/((SH-SQMZ)**2+GMMZ**2)
34263 FACHZ=FACHZ*WIDS(23,2)*WIDS(KFHIGG,2)
34264 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHZ=FACHZ*
34265 & PARU(154+10*IHIGG)**2
34266 DO 150 I=MMINA,MMAXA
34267 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 150
34268 EI=KCHG(IABS(I),1)/3D0
34269 AI=SIGN(1D0,EI)
34270 VI=AI-4D0*EI*XWV
34271 FCOI=1D0
34272 IF(IABS(I).LE.10) FCOI=FACA/3D0
34273 NCHN=NCHN+1
34274 ISIG(NCHN,1)=I
34275 ISIG(NCHN,2)=-I
34276 ISIG(NCHN,3)=1
34277 SIGH(NCHN)=FACHZ*FCOI*(VI**2+AI**2)
34278 150 CONTINUE
34279
34280 ELSEIF(ISUB.EQ.26) THEN
34281C...f + fbar' -> W+/- + h0 (or H0, or A0)
34282C...Propagators: W+-, h0 as simulated in PYOFSH and as desired
34283 HBW3=GMMW/((SQM3-SQMW)**2+GMMW**2)
34284 CALL PYWIDT(24,SQM3,WDTP,WDTE)
34285 GMMW3=SQRT(SQM3)*WDTP(0)
34286 HBW3C=GMMW3/((SQM3-SQMW)**2+GMMW3**2)
34287 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34288 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34289 GMMH4=SQRT(SQM4)*WDTP(0)
34290 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
34291 THUH=MAX(TH*UH-SQM3*SQM4,SH*CKIN(3)**2)
34292 FACHW=COMFAC*0.125D0*(AEM/XW)**2*(THUH+2D0*SH*SQM3)/
34293 & ((SH-SQMW)**2+GMMW**2)*(HBW3C/HBW3)*(HBW4C/HBW4)
34294 FACHW=FACHW*WIDS(KFHIGG,2)
34295 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACHW=FACHW*
34296 & PARU(155+10*IHIGG)**2
34297 DO 170 I=MMIN1,MMAX1
34298 IA=IABS(I)
34299 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 170
34300 DO 160 J=MMIN2,MMAX2
34301 JA=IABS(J)
34302 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(1,J).EQ.0) GOTO 160
34303 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 160
34304 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
34305 & GOTO 160
34306 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
34307 FCKM=1D0
34308 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
34309 FCOI=1D0
34310 IF(IA.LE.10) FCOI=FACA/3D0
34311 NCHN=NCHN+1
34312 ISIG(NCHN,1)=I
34313 ISIG(NCHN,2)=J
34314 ISIG(NCHN,3)=1
34315 SIGH(NCHN)=FACHW*FCOI*FCKM*WIDS(24,(5-KCHW)/2)
34316 160 CONTINUE
34317 170 CONTINUE
34318
34319 ELSEIF(ISUB.EQ.32) THEN
34320C...f + g -> f + h0 (q + g -> q + h0 only)
34321 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24D0
34322C...H propagator: as simulated in PYOFSH and as desired
34323 SQMHC=PMAS(25,1)**2
34324 GMMHC=PMAS(25,1)*PMAS(25,2)
34325 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
34326 CALL PYWIDT(25,SQM4,WDTP,WDTE)
34327 GMMHCC=SQRT(SQM4)*WDTP(0)
34328 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
34329 FHCQ=FHCQ*HBW4C/HBW4
34330 DO 190 I=MMINA,MMAXA
34331 IA=IABS(I)
34332 IF(IA.NE.5) GOTO 190
34333 SQML=PYMRUN(IA,SH)**2
34334 SQMQ=PMAS(IA,1)**2
34335 FACHCQ=FHCQ*SQML/SQMW*
34336 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQM4-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
34337 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQM4-UH)/(SQMQ-UH)*
34338 & (SQM4-SQMQ-SH)/SH)
34339 DO 180 ISDE=1,2
34340 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
34341 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
34342 NCHN=NCHN+1
34343 ISIG(NCHN,ISDE)=I
34344 ISIG(NCHN,3-ISDE)=21
34345 ISIG(NCHN,3)=1
34346 SIGH(NCHN)=FACHCQ*WIDS(25,2)
34347 180 CONTINUE
34348 190 CONTINUE
34349 ENDIF
34350
34351 ELSEIF(ISUB.LE.80) THEN
34352 IF(ISUB.EQ.71) THEN
34353C...Z0 + Z0 -> Z0 + Z0
34354 IF(SH.LE.4.01D0*SQMZ) GOTO 220
34355
34356 IF(MSTP(46).LE.2) THEN
34357C...Exact scattering ME:s for on-mass-shell gauge bosons
34358 BE2=1D0-4D0*SQMZ/SH
34359 TH=-0.5D0*SH*BE2*(1D0-CTH)
34360 UH=-0.5D0*SH*BE2*(1D0+CTH)
34361 IF(MAX(TH,UH).GT.-1D0) GOTO 220
34362 SHANG=1D0/XW1*SQMW/SQMZ*(1D0+BE2)**2
34363 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34364 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34365 THANG=1D0/XW1*SQMW/SQMZ*(BE2-CTH)**2
34366 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
34367 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
34368 UHANG=1D0/XW1*SQMW/SQMZ*(BE2+CTH)**2
34369 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
34370 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
34371 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
34372 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
34373 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
34374 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATHRE+AUHRE)**2+
34375 & (ASHIM+ATHIM+AUHIM)**2)
34376 IF(MSTP(46).EQ.2) FACZZ=0D0
34377
34378 ELSE
34379C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34380 FACZZ=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
34381 & ABS(A00U+2D0*A20U)**2
34382 ENDIF
34383 FACZZ=FACZZ*WIDS(23,1)
34384
34385 DO 210 I=MMIN1,MMAX1
34386 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 210
34387 EI=KCHG(IABS(I),1)/3D0
34388 AI=SIGN(1D0,EI)
34389 VI=AI-4D0*EI*XWV
34390 AVI=AI**2+VI**2
34391 DO 200 J=MMIN2,MMAX2
34392 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 200
34393 EJ=KCHG(IABS(J),1)/3D0
34394 AJ=SIGN(1D0,EJ)
34395 VJ=AJ-4D0*EJ*XWV
34396 AVJ=AJ**2+VJ**2
34397 NCHN=NCHN+1
34398 ISIG(NCHN,1)=I
34399 ISIG(NCHN,2)=J
34400 ISIG(NCHN,3)=1
34401 SIGH(NCHN)=0.5D0*FACZZ*AVI*AVJ
34402 200 CONTINUE
34403 210 CONTINUE
34404 220 CONTINUE
34405
34406 ELSEIF(ISUB.EQ.72) THEN
34407C...Z0 + Z0 -> W+ + W-
34408 IF(SH.LE.4.01D0*SQMZ) GOTO 250
34409
34410 IF(MSTP(46).LE.2) THEN
34411C...Exact scattering ME:s for on-mass-shell gauge bosons
34412 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
34413 CTH2=CTH**2
34414 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
34415 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
34416 IF(MAX(TH,UH).GT.-1D0) GOTO 250
34417 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
34418 & (1D0-2D0*SQMZ/SH)
34419 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34420 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34421 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
34422 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34423 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34424 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
34425 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34426 ATWIM=0D0
34427 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
34428 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34429 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34430 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
34431 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34432 AUWIM=0D0
34433 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
34434 A4IM=0D0
34435 FACWW=COMFAC*1D0/(4096D0*PARU(1)**2*16D0*XW1**2)*
34436 & (AEM/XW)**4*(SH/SQMW)**2*(SQMZ/SQMW)*SH2
34437 IF(MSTP(46).LE.0) FACWW=FACWW*(ASHRE**2+ASHIM**2)
34438 IF(MSTP(46).EQ.1) FACWW=FACWW*((ASHRE+ATWRE+AUWRE+A4RE)**2+
34439 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
34440 IF(MSTP(46).EQ.2) FACWW=FACWW*((ATWRE+AUWRE+A4RE)**2+
34441 & (ATWIM+AUWIM+A4IM)**2)
34442
34443 ELSE
34444C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34445 FACWW=COMFAC*(AEM/(16D0*PARU(1)*XW*XW1))**2*(64D0/9D0)*
34446 & ABS(A00U-A20U)**2
34447 ENDIF
34448 FACWW=FACWW*WIDS(24,1)
34449
34450 DO 240 I=MMIN1,MMAX1
34451 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 240
34452 EI=KCHG(IABS(I),1)/3D0
34453 AI=SIGN(1D0,EI)
34454 VI=AI-4D0*EI*XWV
34455 AVI=AI**2+VI**2
34456 DO 230 J=MMIN2,MMAX2
34457 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 230
34458 EJ=KCHG(IABS(J),1)/3D0
34459 AJ=SIGN(1D0,EJ)
34460 VJ=AJ-4D0*EJ*XWV
34461 AVJ=AJ**2+VJ**2
34462 NCHN=NCHN+1
34463 ISIG(NCHN,1)=I
34464 ISIG(NCHN,2)=J
34465 ISIG(NCHN,3)=1
34466 SIGH(NCHN)=FACWW*AVI*AVJ
34467 230 CONTINUE
34468 240 CONTINUE
34469 250 CONTINUE
34470
34471 ELSEIF(ISUB.EQ.73) THEN
34472C...Z0 + W+/- -> Z0 + W+/-
34473 IF(SH.LE.2D0*SQMZ+2D0*SQMW) GOTO 280
34474
34475 IF(MSTP(46).LE.2) THEN
34476C...Exact scattering ME:s for on-mass-shell gauge bosons
34477 BE2=1D0-2D0*(SQMZ+SQMW)/SH+((SQMZ-SQMW)/SH)**2
34478 EP1=1D0-(SQMZ-SQMW)/SH
34479 EP2=1D0+(SQMZ-SQMW)/SH
34480 TH=-0.5D0*SH*BE2*(1D0-CTH)
34481 UH=(SQMZ-SQMW)**2/SH-0.5D0*SH*BE2*(1D0+CTH)
34482 IF(MAX(TH,UH).GT.-1D0) GOTO 280
34483 THANG=(BE2-EP1*CTH)*(BE2-EP2*CTH)
34484 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
34485 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
34486 ASWRE=-XW1/SQMZ*SH/(SH-SQMW)*(-BE2*(EP1+EP2)**4*CTH+
34487 & 1D0/4D0*(BE2+EP1*EP2)**2*((EP1-EP2)**2-4D0*BE2*CTH)+
34488 & 2D0*BE2*(BE2+EP1*EP2)*(EP1+EP2)**2*CTH-
34489 & 1D0/16D0*SH/SQMW*(EP1**2-EP2**2)**2*(BE2+EP1*EP2)**2)
34490 ASWIM=0D0
34491 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*(-BE2*(EP2+EP1*CTH)*
34492 & (EP1+EP2*CTH)*(BE2+EP1*EP2)+BE2*(EP2+EP1*CTH)*
34493 & (BE2+EP1*EP2*CTH)*(2D0*EP2-EP2*CTH+EP1)-
34494 & BE2*(EP2+EP1*CTH)**2*(BE2-EP2**2*CTH)-1D0/8D0*
34495 & (BE2+EP1*EP2*CTH)**2*((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+
34496 & 1D0/32D0*SH/SQMW*(BE2+EP1*EP2*CTH)**2*
34497 & (EP1**2-EP2**2)**2-BE2*(EP1+EP2*CTH)*(EP2+EP1*CTH)*
34498 & (BE2+EP1*EP2)+BE2*(EP1+EP2*CTH)*(BE2+EP1*EP2*CTH)*
34499 & (2D0*EP1-EP1*CTH+EP2)-BE2*(EP1+EP2*CTH)**2*
34500 & (BE2-EP1**2*CTH)-1D0/8D0*(BE2+EP1*EP2*CTH)**2*
34501 & ((EP1+EP2)**2+2D0*BE2*(1D0-CTH))+1D0/32D0*SH/SQMW*
34502 & (BE2+EP1*EP2*CTH)**2*(EP1**2-EP2**2)**2)
34503 AUWIM=0D0
34504 A4RE=XW1/SQMZ*(EP1**2*EP2**2*(CTH**2-1D0)-
34505 & 2D0*BE2*(EP1**2+EP2**2+EP1*EP2)*CTH-2D0*BE2*EP1*EP2)
34506 A4IM=0D0
34507 FACZW=COMFAC*1D0/(4096D0*PARU(1)**2*4D0*XW1)*(AEM/XW)**4*
34508 & (SH/SQMW)**2*SQRT(SQMZ/SQMW)*SH2
34509 IF(MSTP(46).LE.0) FACZW=0D0
34510 IF(MSTP(46).EQ.1) FACZW=FACZW*((ATHRE+ASWRE+AUWRE+A4RE)**2+
34511 & (ATHIM+ASWIM+AUWIM+A4IM)**2)
34512 IF(MSTP(46).EQ.2) FACZW=FACZW*((ASWRE+AUWRE+A4RE)**2+
34513 & (ASWIM+AUWIM+A4IM)**2)
34514
34515 ELSE
34516C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34517 FACZW=COMFAC*AEM**2/(64D0*PARU(1)**2*XW**2*XW1)*16D0*
34518 & ABS(A20U+3D0*A11U*DBLE(CTH))**2
34519 ENDIF
34520 FACZW=FACZW*WIDS(23,2)
34521
34522 DO 270 I=MMIN1,MMAX1
34523 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 270
34524 EI=KCHG(IABS(I),1)/3D0
34525 AI=SIGN(1D0,EI)
34526 VI=AI-4D0*EI*XWV
34527 AVI=AI**2+VI**2
34528 KCHWI=ISIGN(1,KCHG(IABS(I),1)*ISIGN(1,I))
34529 DO 260 J=MMIN2,MMAX2
34530 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 260
34531 EJ=KCHG(IABS(J),1)/3D0
34532 AJ=SIGN(1D0,EJ)
34533 VJ=AI-4D0*EJ*XWV
34534 AVJ=AJ**2+VJ**2
34535 KCHWJ=ISIGN(1,KCHG(IABS(J),1)*ISIGN(1,J))
34536 NCHN=NCHN+1
34537 ISIG(NCHN,1)=I
34538 ISIG(NCHN,2)=J
34539 ISIG(NCHN,3)=1
34540 SIGH(NCHN)=FACZW*AVI*VINT(180+J)*WIDS(24,(5-KCHWJ)/2)
34541 NCHN=NCHN+1
34542 ISIG(NCHN,1)=I
34543 ISIG(NCHN,2)=J
34544 ISIG(NCHN,3)=2
34545 SIGH(NCHN)=FACZW*VINT(180+I)*WIDS(24,(5-KCHWI)/2)*AVJ
34546 260 CONTINUE
34547 270 CONTINUE
34548 280 CONTINUE
34549
34550 ELSEIF(ISUB.EQ.75) THEN
34551C...W+ + W- -> gamma + gamma
34552
34553 ELSEIF(ISUB.EQ.76) THEN
34554C...W+ + W- -> Z0 + Z0
34555 IF(SH.LE.4.01D0*SQMZ) GOTO 310
34556
34557 IF(MSTP(46).LE.2) THEN
34558C...Exact scattering ME:s for on-mass-shell gauge bosons
34559 BE2=SQRT((1D0-4D0*SQMW/SH)*(1D0-4D0*SQMZ/SH))
34560 CTH2=CTH**2
34561 TH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH-BE2*CTH)
34562 UH=-0.5D0*SH*(1D0-2D0*(SQMW+SQMZ)/SH+BE2*CTH)
34563 IF(MAX(TH,UH).GT.-1D0) GOTO 310
34564 SHANG=4D0*SQRT(SQMW/(SQMZ*XW1))*(1D0-2D0*SQMW/SH)*
34565 & (1D0-2D0*SQMZ/SH)
34566 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34567 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34568 ATWRE=XW1/SQMZ*SH/(TH-SQMW)*((CTH-BE2)**2*(3D0/2D0+BE2/2D0*
34569 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34570 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34571 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2+
34572 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34573 ATWIM=0D0
34574 AUWRE=XW1/SQMZ*SH/(UH-SQMW)*((CTH+BE2)**2*(3D0/2D0-BE2/2D0*
34575 & CTH-(SQMW+SQMZ)/SH+(SQMW-SQMZ)**2/(SH*SQMW))+4D0*
34576 & ((SQMW+SQMZ)/SH*(1D0-3D0*CTH2)+8D0*SQMW*SQMZ/SH2*
34577 & (2D0*CTH2-1D0)+4D0*(SQMW**2+SQMZ**2)/SH2*CTH2-
34578 & 2D0*(SQMW+SQMZ)/SH*BE2*CTH))
34579 AUWIM=0D0
34580 A4RE=2D0*XW1/SQMZ*(3D0-CTH2-4D0*(SQMW+SQMZ)/SH)
34581 A4IM=0D0
34582 FACZZ=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
34583 & (SH/SQMW)**2*SH2
34584 IF(MSTP(46).LE.0) FACZZ=FACZZ*(ASHRE**2+ASHIM**2)
34585 IF(MSTP(46).EQ.1) FACZZ=FACZZ*((ASHRE+ATWRE+AUWRE+A4RE)**2+
34586 & (ASHIM+ATWIM+AUWIM+A4IM)**2)
34587 IF(MSTP(46).EQ.2) FACZZ=FACZZ*((ATWRE+AUWRE+A4RE)**2+
34588 & (ATWIM+AUWIM+A4IM)**2)
34589
34590 ELSE
34591C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34592 FACZZ=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
34593 & ABS(A00U-A20U)**2
34594 ENDIF
34595 FACZZ=FACZZ*WIDS(23,1)
34596
34597 DO 300 I=MMIN1,MMAX1
34598 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 300
34599 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34600 DO 290 J=MMIN2,MMAX2
34601 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 290
34602 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34603 IF(EI*EJ.GT.0D0) GOTO 290
34604 NCHN=NCHN+1
34605 ISIG(NCHN,1)=I
34606 ISIG(NCHN,2)=J
34607 ISIG(NCHN,3)=1
34608 SIGH(NCHN)=0.5D0*FACZZ*VINT(180+I)*VINT(180+J)
34609 290 CONTINUE
34610 300 CONTINUE
34611 310 CONTINUE
34612
34613 ELSEIF(ISUB.EQ.77) THEN
34614C...W+/- + W+/- -> W+/- + W+/-
34615 IF(SH.LE.4.01D0*SQMW) GOTO 340
34616
34617 IF(MSTP(46).LE.2) THEN
34618C...Exact scattering ME:s for on-mass-shell gauge bosons
34619 BE2=1D0-4D0*SQMW/SH
34620 BE4=BE2**2
34621 CTH2=CTH**2
34622 CTH3=CTH**3
34623 TH=-0.5D0*SH*BE2*(1D0-CTH)
34624 UH=-0.5D0*SH*BE2*(1D0+CTH)
34625 IF(MAX(TH,UH).GT.-1D0) GOTO 340
34626 SHANG=(1D0+BE2)**2
34627 ASHRE=(SH-SQMH)/((SH-SQMH)**2+GMMH**2)*SHANG
34628 ASHIM=-GMMH/((SH-SQMH)**2+GMMH**2)*SHANG
34629 THANG=(BE2-CTH)**2
34630 ATHRE=(TH-SQMH)/((TH-SQMH)**2+GMMH**2)*THANG
34631 ATHIM=-GMMH/((TH-SQMH)**2+GMMH**2)*THANG
34632 UHANG=(BE2+CTH)**2
34633 AUHRE=(UH-SQMH)/((UH-SQMH)**2+GMMH**2)*UHANG
34634 AUHIM=-GMMH/((UH-SQMH)**2+GMMH**2)*UHANG
34635 SGZANG=1D0/SQMW*BE2*(3D0-BE2)**2*CTH
34636 ASGRE=XW*SGZANG
34637 ASGIM=0D0
34638 ASZRE=XW1*SH/(SH-SQMZ)*SGZANG
34639 ASZIM=0D0
34640 TGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)+BE2*(4D0-10D0*BE2+
34641 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2+BE2*CTH3)
34642 ATGRE=0.5D0*XW*SH/TH*TGZANG
34643 ATGIM=0D0
34644 ATZRE=0.5D0*XW1*SH/(TH-SQMZ)*TGZANG
34645 ATZIM=0D0
34646 UGZANG=1D0/SQMW*(BE2*(4D0-2D0*BE2+BE4)-BE2*(4D0-10D0*BE2+
34647 & BE4)*CTH+(2D0-11D0*BE2+10D0*BE4)*CTH2-BE2*CTH3)
34648 AUGRE=0.5D0*XW*SH/UH*UGZANG
34649 AUGIM=0D0
34650 AUZRE=0.5D0*XW1*SH/(UH-SQMZ)*UGZANG
34651 AUZIM=0D0
34652 A4ARE=1D0/SQMW*(1D0+2D0*BE2-6D0*BE2*CTH-CTH2)
34653 A4AIM=0D0
34654 A4SRE=2D0/SQMW*(1D0+2D0*BE2-CTH2)
34655 A4SIM=0D0
34656 FWW=COMFAC*1D0/(4096D0*PARU(1)**2)*(AEM/XW)**4*
34657 & (SH/SQMW)**2*SH2
34658 IF(MSTP(46).LE.0) THEN
34659 AWWARE=ASHRE
34660 AWWAIM=ASHIM
34661 AWWSRE=0D0
34662 AWWSIM=0D0
34663 ELSEIF(MSTP(46).EQ.1) THEN
34664 AWWARE=ASHRE+ATHRE+ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
34665 AWWAIM=ASHIM+ATHIM+ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
34666 AWWSRE=-ATHRE-AUHRE+ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
34667 AWWSIM=-ATHIM-AUHIM+ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
34668 ELSE
34669 AWWARE=ASGRE+ASZRE+ATGRE+ATZRE+A4ARE
34670 AWWAIM=ASGIM+ASZIM+ATGIM+ATZIM+A4AIM
34671 AWWSRE=ATGRE+ATZRE+AUGRE+AUZRE+A4SRE
34672 AWWSIM=ATGIM+ATZIM+AUGIM+AUZIM+A4SIM
34673 ENDIF
34674 AWWA2=AWWARE**2+AWWAIM**2
34675 AWWS2=AWWSRE**2+AWWSIM**2
34676
34677 ELSE
34678C...Strongly interacting Z_L/W_L model of Dobado, Herrero, Terron
34679 FWWA=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*(64D0/9D0)*
34680 & ABS(A00U+0.5D0*A20U+4.5D0*A11U*DBLE(CTH))**2
34681 FWWS=COMFAC*(AEM/(4D0*PARU(1)*XW))**2*64D0*ABS(A20U)**2
34682 ENDIF
34683
34684 DO 330 I=MMIN1,MMAX1
34685 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 330
34686 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
34687 DO 320 J=MMIN2,MMAX2
34688 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 320
34689 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
34690 IF(EI*EJ.LT.0D0) THEN
34691C...W+W-
34692 IF(MSTP(45).EQ.1) GOTO 320
34693 IF(MSTP(46).LE.2) FACWW=FWW*AWWA2*WIDS(24,1)
34694 IF(MSTP(46).GE.3) FACWW=FWWA*WIDS(24,1)
34695 ELSE
34696C...W+W+/W-W-
34697 IF(MSTP(45).EQ.2) GOTO 320
34698 IF(MSTP(46).LE.2) FACWW=FWW*AWWS2
34699 IF(MSTP(46).GE.3) FACWW=FWWS
34700 IF(EI.GT.0D0) FACWW=FACWW*WIDS(24,4)
34701 IF(EI.LT.0D0) FACWW=FACWW*WIDS(24,5)
34702 ENDIF
34703 NCHN=NCHN+1
34704 ISIG(NCHN,1)=I
34705 ISIG(NCHN,2)=J
34706 ISIG(NCHN,3)=1
34707 SIGH(NCHN)=FACWW*VINT(180+I)*VINT(180+J)
34708 IF(EI*EJ.GT.0D0) SIGH(NCHN)=0.5D0*SIGH(NCHN)
34709 320 CONTINUE
34710 330 CONTINUE
34711 340 CONTINUE
34712 ENDIF
34713
34714 ELSEIF(ISUB.LE.120) THEN
34715 IF(ISUB.EQ.102) THEN
34716C...g + g -> h0 (or H0, or A0)
34717 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34718 HS=SHR*WDTP(0)
34719 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34720 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34721 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34722 & FACBW=0D0
34723C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34724 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34725 WDTP13=0D0
34726 DO 345 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34727 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34728 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34729 345 CONTINUE
34730 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34731 & '(PYSGHG:) did not find Higgs -> g g channel')
34732 HI=SHR*WDTP13/32D0
34733 ELSE
34734 HI=SHR*WDTP(13)/32D0
34735 ENDIF
34736 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 350
34737 NCHN=NCHN+1
34738 ISIG(NCHN,1)=21
34739 ISIG(NCHN,2)=21
34740 ISIG(NCHN,3)=1
34741 SIGH(NCHN)=HI*FACBW*HF
34742 350 CONTINUE
34743
34744 ELSEIF(ISUB.EQ.103) THEN
34745C...gamma + gamma -> h0 (or H0, or A0)
34746 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
34747 HS=SHR*WDTP(0)
34748 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
34749 FACBW=4D0*COMFAC/((SH-SQMH)**2+HS**2)
34750 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
34751 & FACBW=0D0
34752C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34753 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34754 WDTP14=0D0
34755 DO 355 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34756 IF(KFDP(IDC,1).EQ.22.AND.KFDP(IDC,2).EQ.22.AND.
34757 & KFDP(IDC,3).EQ.0) WDTP14=PMAS(KFHIGG,2)*BRAT(IDC)
34758 355 CONTINUE
34759 IF(WDTP14.EQ.0D0) CALL PYERRM(26,
34760 & '(PYSGHG:) did not find Higgs -> gamma gamma channel')
34761 HI=SHR*WDTP14*2D0
34762 ELSE
34763 HI=SHR*WDTP(14)*2D0
34764 ENDIF
34765 IF(KFAC(1,22)*KFAC(2,22).EQ.0) GOTO 360
34766 NCHN=NCHN+1
34767 ISIG(NCHN,1)=22
34768 ISIG(NCHN,2)=22
34769 ISIG(NCHN,3)=1
34770 SIGH(NCHN)=HI*FACBW*HF
34771 360 CONTINUE
34772
34773 ELSEIF(ISUB.EQ.110) THEN
34774C...f + fbar -> gamma + h0
34775 THUH=MAX(TH*UH,SH*CKIN(3)**2)
34776 FACHG=COMFAC*(3D0*AEM**4)/(2D0*PARU(1)**2*XW*SQMW)*SH*THUH
34777 FACHG=FACHG*WIDS(KFHIGG,2)
34778C...Calculate loop contributions for intermediate gamma* and Z0
34779 CIGTOT=DCMPLX(0D0,0D0)
34780 CIZTOT=DCMPLX(0D0,0D0)
34781 JMAX=3*MSTP(1)+1
34782 DO 370 J=1,JMAX
34783 IF(J.LE.2*MSTP(1)) THEN
34784 FNC=1D0
34785 EJ=KCHG(J,1)/3D0
34786 AJ=SIGN(1D0,EJ+0.1D0)
34787 VJ=AJ-4D0*EJ*XWV
34788 BALP=SQM4/(2D0*PMAS(J,1))**2
34789 BBET=SH/(2D0*PMAS(J,1))**2
34790 ELSEIF(J.LE.3*MSTP(1)) THEN
34791 FNC=3D0
34792 JL=2*(J-2*MSTP(1))-1
34793 EJ=KCHG(10+JL,1)/3D0
34794 AJ=SIGN(1D0,EJ+0.1D0)
34795 VJ=AJ-4D0*EJ*XWV
34796 BALP=SQM4/(2D0*PMAS(10+JL,1))**2
34797 BBET=SH/(2D0*PMAS(10+JL,1))**2
34798 ELSE
34799 BALP=SQM4/(2D0*PMAS(24,1))**2
34800 BBET=SH/(2D0*PMAS(24,1))**2
34801 ENDIF
34802 BABI=1D0/(BALP-BBET)
34803 IF(BALP.LT.1D0) THEN
34804 F0ALP=DCMPLX(DBLE(ASIN(SQRT(BALP))),0D0)
34805 F1ALP=F0ALP**2
34806 ELSE
34807 F0ALP=DCMPLX(DBLE(LOG(SQRT(BALP)+SQRT(BALP-1D0))),
34808 & -DBLE(0.5D0*PARU(1)))
34809 F1ALP=-F0ALP**2
34810 ENDIF
34811 F2ALP=DBLE(SQRT(ABS(BALP-1D0)/BALP))*F0ALP
34812 IF(BBET.LT.1D0) THEN
34813 F0BET=DCMPLX(DBLE(ASIN(SQRT(BBET))),0D0)
34814 F1BET=F0BET**2
34815 ELSE
34816 F0BET=DCMPLX(DBLE(LOG(SQRT(BBET)+SQRT(BBET-1D0))),
34817 & -DBLE(0.5D0*PARU(1)))
34818 F1BET=-F0BET**2
34819 ENDIF
34820 F2BET=DBLE(SQRT(ABS(BBET-1D0)/BBET))*F0BET
34821 IF(J.LE.3*MSTP(1)) THEN
34822 FIF=DBLE(0.5D0*BABI)+DBLE(BABI**2)*(DBLE(0.5D0*(1D0-BALP+
34823 & BBET))*(F1BET-F1ALP)+DBLE(BBET)*(F2BET-F2ALP))
34824 CIGTOT=CIGTOT+DBLE(FNC*EJ**2)*FIF
34825 CIZTOT=CIZTOT+DBLE(FNC*EJ*VJ)*FIF
34826 ELSE
34827 TXW=XW/XW1
34828 CIGTOT=CIGTOT-0.5*(DBLE(BABI*(1.5D0+BALP))+DBLE(BABI**2)*
34829 & (DBLE(1.5D0-3D0*BALP+4D0*BBET)*(F1BET-F1ALP)+
34830 & DBLE(BBET*(2D0*BALP+3D0))*(F2BET-F2ALP)))
34831 CIZTOT=CIZTOT-DBLE(0.5D0*BABI*XW1)*(DBLE(5D0-TXW+2D0*BALP*
34832 & (1D0-TXW))*(1D0+DBLE(2D0*BABI*BBET)*(F2BET-F2ALP))+
34833 & DBLE(BABI*(4D0*BBET*(3D0-TXW)-(2D0*BALP-1D0)*(5D0-TXW)))*
34834 & (F1BET-F1ALP))
34835 ENDIF
34836 370 CONTINUE
34837 CIGTOT=CIGTOT/DBLE(SH)
34838 CIZTOT=CIZTOT*DBLE(XWC)/DCMPLX(DBLE(SH-SQMZ),DBLE(GMMZ))
34839C...Loop over initial flavours
34840 DO 380 I=MMINA,MMAXA
34841 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
34842 EI=KCHG(IABS(I),1)/3D0
34843 AI=SIGN(1D0,EI)
34844 VI=AI-4D0*EI*XWV
34845 FCOI=1D0
34846 IF(IABS(I).LE.10) FCOI=FACA/3D0
34847 NCHN=NCHN+1
34848 ISIG(NCHN,1)=I
34849 ISIG(NCHN,2)=-I
34850 ISIG(NCHN,3)=1
34851 SIGH(NCHN)=FACHG*FCOI*(ABS(DBLE(EI)*CIGTOT+DBLE(VI)*
34852 & CIZTOT)**2+AI**2*ABS(CIZTOT)**2)
34853 380 CONTINUE
34854
34855 ELSEIF(ISUB.EQ.111) THEN
34856C...f + fbar -> g + h0 (q + qbar -> g + h0 only)
34857 IF(MSTP(38).NE.0) THEN
34858C...Simple case: only do gg <-> h exactly.
34859 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34860C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34861 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34862 WDTP13=0D0
34863 DO 385 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34864 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34865 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34866 385 CONTINUE
34867 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34868 & '(PYSGHG:) did not find Higgs -> g g channel')
34869 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP13/SQRT(SQM4))*
34870 & (TH**2+UH**2)/(SH*SQM4)
34871 ELSE
34872 FACGH=COMFAC*FACA*(2D0/9D0)*AS*(WDTP(13)/SQRT(SQM4))*
34873 & (TH**2+UH**2)/(SH*SQM4)
34874 ENDIF
34875C...Propagators: as simulated in PYOFSH and as desired
34876 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34877 GMMHC=SQRT(SQM4)*WDTP(0)
34878 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34879 & ((SQM4-SQMH)**2+GMMHC**2)
34880 FACGH=FACGH*HBW4C/HBW4
34881 ELSE
34882C...Messy case: do full loop integrals
34883 A5STUR=0D0
34884 A5STUI=0D0
34885 DO 390 I=1,2*MSTP(1)
34886 SQMQ=PMAS(I,1)**2
34887 EPSS=4D0*SQMQ/SH
34888 EPSH=4D0*SQMQ/SQMH
34889 CALL PYWAUX(1,EPSS,W1SR,W1SI)
34890 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34891 CALL PYWAUX(2,EPSS,W2SR,W2SI)
34892 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34893 A5STUR=A5STUR+EPSH*(1D0+SH/(TH+UH)*(W1SR-W1HR)+
34894 & (0.25D0-SQMQ/(TH+UH))*(W2SR-W2HR))
34895 A5STUI=A5STUI+EPSH*(SH/(TH+UH)*(W1SI-W1HI)+
34896 & (0.25D0-SQMQ/(TH+UH))*(W2SI-W2HI))
34897 390 CONTINUE
34898 FACGH=COMFAC*FACA/(144D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34899 & SQMH/SH*(UH**2+TH**2)/(UH+TH)**2*(A5STUR**2+A5STUI**2)
34900 FACGH=FACGH*WIDS(25,2)
34901 ENDIF
34902 DO 400 I=MMINA,MMAXA
34903 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
34904 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
34905 NCHN=NCHN+1
34906 ISIG(NCHN,1)=I
34907 ISIG(NCHN,2)=-I
34908 ISIG(NCHN,3)=1
34909 SIGH(NCHN)=FACGH
34910 400 CONTINUE
34911
34912 ELSEIF(ISUB.EQ.112) THEN
34913C...f + g -> f + h0 (q + g -> q + h0 only)
34914 IF(MSTP(38).NE.0) THEN
34915C...Simple case: only do gg <-> h exactly.
34916 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34917C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34918 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34919 WDTP13=0D0
34920 DO 405 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34921 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34922 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34923 405 CONTINUE
34924 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34925 & '(PYSGHG:) did not find Higgs -> g g channel')
34926 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP13/SQRT(SQM4))*
34927 & (SH**2+UH**2)/(-TH*SQM4)
34928 ELSE
34929 FACQH=COMFAC*FACA*(1D0/12D0)*AS*(WDTP(13)/SQRT(SQM4))*
34930 & (SH**2+UH**2)/(-TH*SQM4)
34931 ENDIF
34932C...Propagators: as simulated in PYOFSH and as desired
34933 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34934 GMMHC=SQRT(SQM4)*WDTP(0)
34935 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34936 & ((SQM4-SQMH)**2+GMMHC**2)
34937 FACQH=FACQH*HBW4C/HBW4
34938 ELSE
34939C...Messy case: do full loop integrals
34940 A5TSUR=0D0
34941 A5TSUI=0D0
34942 DO 410 I=1,2*MSTP(1)
34943 SQMQ=PMAS(I,1)**2
34944 EPST=4D0*SQMQ/TH
34945 EPSH=4D0*SQMQ/SQMH
34946 CALL PYWAUX(1,EPST,W1TR,W1TI)
34947 CALL PYWAUX(1,EPSH,W1HR,W1HI)
34948 CALL PYWAUX(2,EPST,W2TR,W2TI)
34949 CALL PYWAUX(2,EPSH,W2HR,W2HI)
34950 A5TSUR=A5TSUR+EPSH*(1D0+TH/(SH+UH)*(W1TR-W1HR)+
34951 & (0.25D0-SQMQ/(SH+UH))*(W2TR-W2HR))
34952 A5TSUI=A5TSUI+EPSH*(TH/(SH+UH)*(W1TI-W1HI)+
34953 & (0.25D0-SQMQ/(SH+UH))*(W2TI-W2HI))
34954 410 CONTINUE
34955 FACQH=COMFAC*FACA/(384D0*PARU(1)**2)*AEM/XW*AS**3*SQMH/SQMW*
34956 & SQMH/(-TH)*(UH**2+SH**2)/(UH+SH)**2*(A5TSUR**2+A5TSUI**2)
34957 FACQH=FACQH*WIDS(25,2)
34958 ENDIF
34959 DO 430 I=MMINA,MMAXA
34960 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 430
34961 DO 420 ISDE=1,2
34962 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 420
34963 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 420
34964 NCHN=NCHN+1
34965 ISIG(NCHN,ISDE)=I
34966 ISIG(NCHN,3-ISDE)=21
34967 ISIG(NCHN,3)=1
34968 SIGH(NCHN)=FACQH
34969 420 CONTINUE
34970 430 CONTINUE
34971
34972 ELSEIF(ISUB.EQ.113) THEN
34973C...g + g -> g + h0
34974 IF(MSTP(38).NE.0) THEN
34975C...Simple case: only do gg <-> h exactly.
34976 CALL PYWIDT(KFHIGG,SQM4,WDTP,WDTE)
34977C...PS: Only use fixed-width when using SLHA decay table for this Higgs
34978 IF (IMSS(22).GE.1.AND.MWID(KFHIGG).EQ.2) THEN
34979 WDTP13=0D0
34980 DO 435 IDC=MDCY(KFHIGG,2),MDCY(KFHIGG,2)+MDCY(KFHIGG,3)-1
34981 IF(KFDP(IDC,1).EQ.21.AND.KFDP(IDC,2).EQ.21.AND.
34982 & KFDP(IDC,3).EQ.0) WDTP13=PMAS(KFHIGG,2)*BRAT(IDC)
34983 435 CONTINUE
34984 IF(WDTP13.EQ.0D0) CALL PYERRM(26,
34985 & '(PYSGHG:) did not find Higgs -> g g channel')
34986 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP13/SQRT(SQM4))*
34987 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34988 ELSE
34989 FACGH=COMFAC*FACA*(3D0/16D0)*AS*(WDTP(13)/SQRT(SQM4))*
34990 & (SH**4+TH**4+UH**4+SQM4**4)/(SH*TH*UH*SQM4)
34991 ENDIF
34992C...Propagators: as simulated in PYOFSH and as desired
34993 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
34994 GMMHC=SQRT(SQM4)*WDTP(0)
34995 HBW4C=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/
34996 & ((SQM4-SQMH)**2+GMMHC**2)
34997 FACGH=FACGH*HBW4C/HBW4
34998 ELSE
34999C...Messy case: do full loop integrals
35000 A2STUR=0D0
35001 A2STUI=0D0
35002 A2USTR=0D0
35003 A2USTI=0D0
35004 A2TUSR=0D0
35005 A2TUSI=0D0
35006 A4STUR=0D0
35007 A4STUI=0D0
35008 DO 440 I=1,2*MSTP(1)
35009 SQMQ=PMAS(I,1)**2
35010 EPSS=4D0*SQMQ/SH
35011 EPST=4D0*SQMQ/TH
35012 EPSU=4D0*SQMQ/UH
35013 EPSH=4D0*SQMQ/SQMH
35014 IF(EPSH.LT.1D-6) GOTO 440
35015 CALL PYWAUX(1,EPSS,W1SR,W1SI)
35016 CALL PYWAUX(1,EPST,W1TR,W1TI)
35017 CALL PYWAUX(1,EPSU,W1UR,W1UI)
35018 CALL PYWAUX(1,EPSH,W1HR,W1HI)
35019 CALL PYWAUX(2,EPSS,W2SR,W2SI)
35020 CALL PYWAUX(2,EPST,W2TR,W2TI)
35021 CALL PYWAUX(2,EPSU,W2UR,W2UI)
35022 CALL PYWAUX(2,EPSH,W2HR,W2HI)
35023 CALL PYI3AU(EPSS,TH/UH,Y3STUR,Y3STUI)
35024 CALL PYI3AU(EPSS,UH/TH,Y3SUTR,Y3SUTI)
35025 CALL PYI3AU(EPST,SH/UH,Y3TSUR,Y3TSUI)
35026 CALL PYI3AU(EPST,UH/SH,Y3TUSR,Y3TUSI)
35027 CALL PYI3AU(EPSU,SH/TH,Y3USTR,Y3USTI)
35028 CALL PYI3AU(EPSU,TH/SH,Y3UTSR,Y3UTSI)
35029 CALL PYI3AU(EPSH,SQMH/SH*TH/UH,YHSTUR,YHSTUI)
35030 CALL PYI3AU(EPSH,SQMH/SH*UH/TH,YHSUTR,YHSUTI)
35031 CALL PYI3AU(EPSH,SQMH/TH*SH/UH,YHTSUR,YHTSUI)
35032 CALL PYI3AU(EPSH,SQMH/TH*UH/SH,YHTUSR,YHTUSI)
35033 CALL PYI3AU(EPSH,SQMH/UH*SH/TH,YHUSTR,YHUSTI)
35034 CALL PYI3AU(EPSH,SQMH/UH*TH/SH,YHUTSR,YHUTSI)
35035 W3STUR=YHSTUR-Y3STUR-Y3UTSR
35036 W3STUI=YHSTUI-Y3STUI-Y3UTSI
35037 W3SUTR=YHSUTR-Y3SUTR-Y3TUSR
35038 W3SUTI=YHSUTI-Y3SUTI-Y3TUSI
35039 W3TSUR=YHTSUR-Y3TSUR-Y3USTR
35040 W3TSUI=YHTSUI-Y3TSUI-Y3USTI
35041 W3TUSR=YHTUSR-Y3TUSR-Y3SUTR
35042 W3TUSI=YHTUSI-Y3TUSI-Y3SUTI
35043 W3USTR=YHUSTR-Y3USTR-Y3TSUR
35044 W3USTI=YHUSTI-Y3USTI-Y3TSUI
35045 W3UTSR=YHUTSR-Y3UTSR-Y3STUR
35046 W3UTSI=YHUTSI-Y3UTSI-Y3STUI
35047 B2STUR=SQMQ/SQMH**2*(SH*(UH-SH)/(SH+UH)+2D0*TH*UH*
35048 & (UH+2D0*SH)/(SH+UH)**2*(W1TR-W1HR)+(SQMQ-SH/4D0)*
35049 & (0.5D0*W2SR+0.5D0*W2HR-W2TR+W3STUR)+SH2*(2D0*SQMQ/
35050 & (SH+UH)**2-0.5D0/(SH+UH))*(W2TR-W2HR)+0.5D0*TH*UH/SH*
35051 & (W2HR-2D0*W2TR)+0.125D0*(SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUR)
35052 B2STUI=SQMQ/SQMH**2*(2D0*TH*UH*(UH+2D0*SH)/(SH+UH)**2*
35053 & (W1TI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2TI+
35054 & W3STUI)+SH2*(2D0*SQMQ/(SH+UH)**2-0.5D0/(SH+UH))*
35055 & (W2TI-W2HI)+0.5D0*TH*UH/SH*(W2HI-2D0*W2TI)+0.125D0*
35056 & (SH-12D0*SQMQ-4D0*TH*UH/SH)*W3TSUI)
35057 B2SUTR=SQMQ/SQMH**2*(SH*(TH-SH)/(SH+TH)+2D0*UH*TH*
35058 & (TH+2D0*SH)/(SH+TH)**2*(W1UR-W1HR)+(SQMQ-SH/4D0)*
35059 & (0.5D0*W2SR+0.5D0*W2HR-W2UR+W3SUTR)+SH2*(2D0*SQMQ/
35060 & (SH+TH)**2-0.5D0/(SH+TH))*(W2UR-W2HR)+0.5D0*UH*TH/SH*
35061 & (W2HR-2D0*W2UR)+0.125D0*(SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTR)
35062 B2SUTI=SQMQ/SQMH**2*(2D0*UH*TH*(TH+2D0*SH)/(SH+TH)**2*
35063 & (W1UI-W1HI)+(SQMQ-SH/4D0)*(0.5D0*W2SI+0.5D0*W2HI-W2UI+
35064 & W3SUTI)+SH2*(2D0*SQMQ/(SH+TH)**2-0.5D0/(SH+TH))*
35065 & (W2UI-W2HI)+0.5D0*UH*TH/SH*(W2HI-2D0*W2UI)+0.125D0*
35066 & (SH-12D0*SQMQ-4D0*UH*TH/SH)*W3USTI)
35067 B2TSUR=SQMQ/SQMH**2*(TH*(UH-TH)/(TH+UH)+2D0*SH*UH*
35068 & (UH+2D0*TH)/(TH+UH)**2*(W1SR-W1HR)+(SQMQ-TH/4D0)*
35069 & (0.5D0*W2TR+0.5D0*W2HR-W2SR+W3TSUR)+TH2*(2D0*SQMQ/
35070 & (TH+UH)**2-0.5D0/(TH+UH))*(W2SR-W2HR)+0.5D0*SH*UH/TH*
35071 & (W2HR-2D0*W2SR)+0.125D0*(TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUR)
35072 B2TSUI=SQMQ/SQMH**2*(2D0*SH*UH*(UH+2D0*TH)/(TH+UH)**2*
35073 & (W1SI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2SI+
35074 & W3TSUI)+TH2*(2D0*SQMQ/(TH+UH)**2-0.5D0/(TH+UH))*
35075 & (W2SI-W2HI)+0.5D0*SH*UH/TH*(W2HI-2D0*W2SI)+0.125D0*
35076 & (TH-12D0*SQMQ-4D0*SH*UH/TH)*W3STUI)
35077 B2TUSR=SQMQ/SQMH**2*(TH*(SH-TH)/(TH+SH)+2D0*UH*SH*
35078 & (SH+2D0*TH)/(TH+SH)**2*(W1UR-W1HR)+(SQMQ-TH/4D0)*
35079 & (0.5D0*W2TR+0.5D0*W2HR-W2UR+W3TUSR)+TH2*(2D0*SQMQ/
35080 & (TH+SH)**2-0.5D0/(TH+SH))*(W2UR-W2HR)+0.5D0*UH*SH/TH*
35081 & (W2HR-2D0*W2UR)+0.125D0*(TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSR)
35082 B2TUSI=SQMQ/SQMH**2*(2D0*UH*SH*(SH+2D0*TH)/(TH+SH)**2*
35083 & (W1UI-W1HI)+(SQMQ-TH/4D0)*(0.5D0*W2TI+0.5D0*W2HI-W2UI+
35084 & W3TUSI)+TH2*(2D0*SQMQ/(TH+SH)**2-0.5D0/(TH+SH))*
35085 & (W2UI-W2HI)+0.5D0*UH*SH/TH*(W2HI-2D0*W2UI)+0.125D0*
35086 & (TH-12D0*SQMQ-4D0*UH*SH/TH)*W3UTSI)
35087 B2USTR=SQMQ/SQMH**2*(UH*(TH-UH)/(UH+TH)+2D0*SH*TH*
35088 & (TH+2D0*UH)/(UH+TH)**2*(W1SR-W1HR)+(SQMQ-UH/4D0)*
35089 & (0.5D0*W2UR+0.5D0*W2HR-W2SR+W3USTR)+UH2*(2D0*SQMQ/
35090 & (UH+TH)**2-0.5D0/(UH+TH))*(W2SR-W2HR)+0.5D0*SH*TH/UH*
35091 & (W2HR-2D0*W2SR)+0.125D0*(UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTR)
35092 B2USTI=SQMQ/SQMH**2*(2D0*SH*TH*(TH+2D0*UH)/(UH+TH)**2*
35093 & (W1SI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2SI+
35094 & W3USTI)+UH2*(2D0*SQMQ/(UH+TH)**2-0.5D0/(UH+TH))*
35095 & (W2SI-W2HI)+0.5D0*SH*TH/UH*(W2HI-2D0*W2SI)+0.125D0*
35096 & (UH-12D0*SQMQ-4D0*SH*TH/UH)*W3SUTI)
35097 B2UTSR=SQMQ/SQMH**2*(UH*(SH-UH)/(UH+SH)+2D0*TH*SH*
35098 & (SH+2D0*UH)/(UH+SH)**2*(W1TR-W1HR)+(SQMQ-UH/4D0)*
35099 & (0.5D0*W2UR+0.5D0*W2HR-W2TR+W3UTSR)+UH2*(2D0*SQMQ/
35100 & (UH+SH)**2-0.5D0/(UH+SH))*(W2TR-W2HR)+0.5D0*TH*SH/UH*
35101 & (W2HR-2D0*W2TR)+0.125D0*(UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSR)
35102 B2UTSI=SQMQ/SQMH**2*(2D0*TH*SH*(SH+2D0*UH)/(UH+SH)**2*
35103 & (W1TI-W1HI)+(SQMQ-UH/4D0)*(0.5D0*W2UI+0.5D0*W2HI-W2TI+
35104 & W3UTSI)+UH2*(2D0*SQMQ/(UH+SH)**2-0.5D0/(UH+SH))*
35105 & (W2TI-W2HI)+0.5D0*TH*SH/UH*(W2HI-2D0*W2TI)+0.125D0*
35106 & (UH-12D0*SQMQ-4D0*TH*SH/UH)*W3TUSI)
35107 B4STUR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
35108 & (W2SR-W2HR+W3STUR))
35109 B4STUI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2SI-W2HI+W3STUI)
35110 B4TUSR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
35111 & (W2TR-W2HR+W3TUSR))
35112 B4TUSI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2TI-W2HI+W3TUSI)
35113 B4USTR=0.25D0*EPSH*(-2D0/3D0+0.25D0*(EPSH-1D0)*
35114 & (W2UR-W2HR+W3USTR))
35115 B4USTI=0.25D0*EPSH*0.25D0*(EPSH-1D0)*(W2UI-W2HI+W3USTI)
35116 A2STUR=A2STUR+B2STUR+B2SUTR
35117 A2STUI=A2STUI+B2STUI+B2SUTI
35118 A2USTR=A2USTR+B2USTR+B2UTSR
35119 A2USTI=A2USTI+B2USTI+B2UTSI
35120 A2TUSR=A2TUSR+B2TUSR+B2TSUR
35121 A2TUSI=A2TUSI+B2TUSI+B2TSUI
35122 A4STUR=A4STUR+B4STUR+B4USTR+B4TUSR
35123 A4STUI=A4STUI+B4STUI+B4USTI+B4TUSI
35124 440 CONTINUE
35125 FACGH=COMFAC*FACA*3D0/(128D0*PARU(1)**2)*AEM/XW*AS**3*
35126 & SQMH/SQMW*SQMH**3/(SH*TH*UH)*(A2STUR**2+A2STUI**2+A2USTR**2+
35127 & A2USTI**2+A2TUSR**2+A2TUSI**2+A4STUR**2+A4STUI**2)
35128 FACGH=FACGH*WIDS(25,2)
35129 ENDIF
35130 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 450
35131 NCHN=NCHN+1
35132 ISIG(NCHN,1)=21
35133 ISIG(NCHN,2)=21
35134 ISIG(NCHN,3)=1
35135 SIGH(NCHN)=FACGH
35136 450 CONTINUE
35137 ENDIF
35138
35139 ELSEIF(ISUB.LE.170) THEN
35140 IF(ISUB.EQ.121) THEN
35141C...g + g -> Q + Qbar + h0
35142 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 460
35143 IA=KFPR(ISUBSV,2)
35144 PMF=PYMRUN(IA,SH)
35145 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
35146 & (0.5D0*PMF/PMAS(24,1))**2
35147 WID2=1D0
35148 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
35149 FACQQH=FACQQH*WID2
35150 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
35151 IKFI=1
35152 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
35153 IF(IA.GT.10) IKFI=3
35154 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
35155 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
35156 FACQQH=FACQQH/(1D0+RMSS(41))**2
35157 IF(IHIGG.NE.3) THEN
35158 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
35159 & PARU(151+10*IHIGG))**2
35160 ENDIF
35161 ENDIF
35162 ENDIF
35163 CALL PYQQBH(WTQQBH)
35164 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35165 HS=SHR*WDTP(0)
35166 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35167 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35168 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35169 & FACBW=0D0
35170 NCHN=NCHN+1
35171 ISIG(NCHN,1)=21
35172 ISIG(NCHN,2)=21
35173 ISIG(NCHN,3)=1
35174 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
35175 460 CONTINUE
35176
35177 ELSEIF(ISUB.EQ.122) THEN
35178C...q + qbar -> Q + Qbar + h0
35179 IA=KFPR(ISUBSV,2)
35180 PMF=PYMRUN(IA,SH)
35181 FACQQH=COMFAC*(4D0*PARU(1)*AEM/XW)*(4D0*PARU(1)*AS)**2*
35182 & (0.5D0*PMF/PMAS(24,1))**2
35183 WID2=1D0
35184 IF(IA.EQ.6.OR.IA.EQ.7.OR.IA.EQ.8) WID2=WIDS(IA,1)
35185 FACQQH=FACQQH*WID2
35186 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) THEN
35187 IKFI=1
35188 IF(IA.LE.10.AND.MOD(IA,2).EQ.0) IKFI=2
35189 IF(IA.GT.10) IKFI=3
35190 FACQQH=FACQQH*PARU(150+10*IHIGG+IKFI)**2
35191 IF(IMSS(1).NE.0.AND.IA.EQ.5) THEN
35192 FACQQH=FACQQH/(1D0+RMSS(41))**2
35193 IF(IHIGG.NE.3) THEN
35194 FACQQH=FACQQH*(1D0+RMSS(41)*PARU(152+10*IHIGG)/
35195 & PARU(151+10*IHIGG))**2
35196 ENDIF
35197 ENDIF
35198 ENDIF
35199 CALL PYQQBH(WTQQBH)
35200 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35201 HS=SHR*WDTP(0)
35202 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35203 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35204 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35205 & FACBW=0D0
35206 DO 470 I=MMINA,MMAXA
35207 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35208 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 470
35209 NCHN=NCHN+1
35210 ISIG(NCHN,1)=I
35211 ISIG(NCHN,2)=-I
35212 ISIG(NCHN,3)=1
35213 SIGH(NCHN)=FACQQH*WTQQBH*FACBW
35214 470 CONTINUE
35215
35216 ELSEIF(ISUB.EQ.123) THEN
35217C...f + f' -> f + f' + h0 (or H0, or A0) (Z0 + Z0 -> h0 as
35218C...inner process)
35219 FACNOR=COMFAC*(4D0*PARU(1)*AEM/(XW*XW1))**3*SQMZ/32D0
35220 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
35221 & PARU(154+10*IHIGG)**2
35222 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
35223 & (VINT(216)-VINT(209)**2))**2
35224 FACZZ1=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
35225 FACZZ2=FACNOR*FACPRP*VINT(217)*VINT(218)
35226 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35227 HS=SHR*WDTP(0)
35228 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35229 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35230 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35231 & FACBW=0D0
35232 DO 490 I=MMIN1,MMAX1
35233 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 490
35234 IA=IABS(I)
35235 DO 480 J=MMIN2,MMAX2
35236 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 480
35237 JA=IABS(J)
35238 EI=KCHG(IA,1)*ISIGN(1,I)/3D0
35239 AI=SIGN(1D0,KCHG(IA,1)+0.5D0)*ISIGN(1,I)
35240 VI=AI-4D0*EI*XWV
35241 EJ=KCHG(JA,1)*ISIGN(1,J)/3D0
35242 AJ=SIGN(1D0,KCHG(JA,1)+0.5D0)*ISIGN(1,J)
35243 VJ=AJ-4D0*EJ*XWV
35244 FACLR1=(VI**2+AI**2)*(VJ**2+AJ**2)+4D0*VI*AI*VJ*AJ
35245 FACLR2=(VI**2+AI**2)*(VJ**2+AJ**2)-4D0*VI*AI*VJ*AJ
35246 NCHN=NCHN+1
35247 ISIG(NCHN,1)=I
35248 ISIG(NCHN,2)=J
35249 ISIG(NCHN,3)=1
35250 SIGH(NCHN)=(FACLR1*FACZZ1+FACLR2*FACZZ2)*FACBW
35251 480 CONTINUE
35252 490 CONTINUE
35253
35254 ELSEIF(ISUB.EQ.124) THEN
35255C...f + f' -> f" + f"' + h0 (or H0, or A0) (W+ + W- -> h0 as
35256C...inner process)
35257 FACNOR=COMFAC*(4D0*PARU(1)*AEM/XW)**3*SQMW
35258 IF(MSTP(4).GE.1.OR.IHIGG.GE.2) FACNOR=FACNOR*
35259 & PARU(155+10*IHIGG)**2
35260 FACPRP=1D0/((VINT(215)-VINT(204)**2)*
35261 & (VINT(216)-VINT(209)**2))**2
35262 FACWW=FACNOR*FACPRP*(0.5D0*TAUP*VINT(2))*VINT(219)
35263 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35264 HS=SHR*WDTP(0)
35265 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
35266 FACBW=(1D0/PARU(1))*VINT(2)*HF/((SH-SQMH)**2+HS**2)
35267 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35268 & FACBW=0D0
35269 DO 510 I=MMIN1,MMAX1
35270 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 510
35271 EI=SIGN(1D0,DBLE(I))*KCHG(IABS(I),1)
35272 DO 500 J=MMIN2,MMAX2
35273 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 500
35274 EJ=SIGN(1D0,DBLE(J))*KCHG(IABS(J),1)
35275 IF(EI*EJ.GT.0D0) GOTO 500
35276 FACLR=VINT(180+I)*VINT(180+J)
35277 NCHN=NCHN+1
35278 ISIG(NCHN,1)=I
35279 ISIG(NCHN,2)=J
35280 ISIG(NCHN,3)=1
35281 SIGH(NCHN)=FACLR*FACWW*FACBW
35282 500 CONTINUE
35283 510 CONTINUE
35284
35285 ELSEIF(ISUB.EQ.143) THEN
35286C...f + fbar' -> H+/-
35287 SQMHC=PMAS(37,1)**2
35288 CALL PYWIDT(37,SH,WDTP,WDTE)
35289 HS=SHR*WDTP(0)
35290 FACBW=4D0*COMFAC/((SH-SQMHC)**2+HS**2)
35291 HP=AEM/(8D0*XW)*SH/SQMW*SH
35292 DO 530 I=MMIN1,MMAX1
35293 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 530
35294 IA=IABS(I)
35295 IM=(MOD(IA,10)+1)/2
35296 DO 520 J=MMIN2,MMAX2
35297 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 520
35298 JA=IABS(J)
35299 JM=(MOD(JA,10)+1)/2
35300 IF(I*J.GT.0.OR.IA.EQ.JA.OR.IM.NE.JM) GOTO 520
35301 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
35302 & GOTO 520
35303 IF(MOD(IA,2).EQ.0) THEN
35304 IU=IA
35305 IL=JA
35306 ELSE
35307 IU=JA
35308 IL=IA
35309 ENDIF
35310 RML=PYMRUN(IL,SH)**2/SH
35311 RMU=PYMRUN(IU,SH)**2/SH
35312 HI=HP*(RML*PARU(141)**2+RMU/PARU(141)**2)
35313 IF(IA.LE.10) HI=HI*FACA/3D0
35314 KCHHC=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
35315 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHHC)/2)+WDTE(0,4))
35316 NCHN=NCHN+1
35317 ISIG(NCHN,1)=I
35318 ISIG(NCHN,2)=J
35319 ISIG(NCHN,3)=1
35320 SIGH(NCHN)=HI*FACBW*HF
35321 520 CONTINUE
35322 530 CONTINUE
35323
35324 ELSEIF(ISUB.EQ.161) THEN
35325C...f + g -> f' + H+/- (b + g -> t + H+/- only)
35326C...(choice of only b and t to avoid kinematics problems)
35327 FHCQ=COMFAC*FACA*AS*AEM/XW*1D0/24
35328C...H propagator: as simulated in PYOFSH and as desired
35329 SQMHC=PMAS(37,1)**2
35330 GMMHC=PMAS(37,1)*PMAS(37,2)
35331 HBW4=GMMHC/((SQM4-SQMHC)**2+GMMHC**2)
35332 CALL PYWIDT(37,SQM4,WDTP,WDTE)
35333 GMMHCC=SQRT(SQM4)*WDTP(0)
35334 HBW4C=GMMHCC/((SQM4-SQMHC)**2+GMMHCC**2)
35335 FHCQ=FHCQ*HBW4C/HBW4
35336 Q2RM=SH
35337 IF(MSTP(32).EQ.12) Q2RM=PARP(194)
35338 DO 550 I=MMINA,MMAXA
35339 IA=IABS(I)
35340 IF(IA.NE.5) GOTO 550
35341 SQML=PYMRUN(IA,Q2RM)**2
35342 IUA=IA+MOD(IA,2)
35343 SQMQ=PYMRUN(IUA,Q2RM)**2
35344 FACHCQ=FHCQ*(SQML*PARU(141)**2+SQMQ/PARU(141)**2)/SQMW*
35345 & (SH/(SQMQ-UH)+2D0*SQMQ*(SQMHC-UH)/(SQMQ-UH)**2+(SQMQ-UH)/SH-
35346 & 2D0*SQMQ/(SQMQ-UH)+2D0*(SQMHC-UH)/(SQMQ-UH)*
35347 & (SQMHC-SQMQ-SH)/SH)
35348 KCHHC=ISIGN(1,KCHG(IA,1)*ISIGN(1,I))
35349 DO 540 ISDE=1,2
35350 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 540
35351 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 540
35352 NCHN=NCHN+1
35353 ISIG(NCHN,ISDE)=I
35354 ISIG(NCHN,3-ISDE)=21
35355 ISIG(NCHN,3)=1
35356 SIGH(NCHN)=FACHCQ*WIDS(37,(5-KCHHC)/2)
35357 IF(IUA.EQ.6) SIGH(NCHN)=SIGH(NCHN)*WIDS(6,(5+KCHHC)/2)
35358 540 CONTINUE
35359 550 CONTINUE
35360 ENDIF
35361
35362 ELSEIF(ISUB.LE.402) THEN
35363 IF(ISUB.EQ.401) THEN
35364C... g + g -> t + bbar + H-
35365 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 560
35366 IA=KFPR(ISUBSV,2)
35367 CALL PYSTBH(WTTBH)
35368 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35369 HS=SHR*WDTP(0)
35370 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
35371 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35372 & FACBW=0D0
35373 NCHN=NCHN+1
35374 ISIG(NCHN,1)=21
35375 ISIG(NCHN,2)=21
35376 ISIG(NCHN,3)=1
35377 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
35378c Since we don't know yet if H+ or H-, assume H+
35379c when calculating suppression due to closed channels.
35380 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
35381 IF(ABS(WIDS(37,2)-WIDS(37,3))
35382 & .GE.1D-6*(WIDS(37,2)+WIDS(37,3)).OR.
35383 & ABS(WIDS(6,2)-WIDS(6,3))
35384 & .GE.1D-6*(WIDS(6,2)+WIDS(6,3))) THEN
35385 WRITE(*,*)'Error: Process 401 cannot handle different'
35386 WRITE(*,*)'decays for H+ and H- or t and tbar.'
35387 WRITE(*,*)'Execution stopped.'
35388 CALL PYSTOP(108)
35389 END IF
35390 560 CONTINUE
35391
35392 ELSEIF(ISUB.EQ.402) THEN
35393C... q + qbar -> t + bbar + H-
35394 IA=KFPR(ISUBSV,2)
35395 CALL PYSTBH(WTTBH)
35396 CALL PYWIDT(KFHIGG,SH,WDTP,WDTE)
35397 HS=SHR*WDTP(0)
35398 FACBW=(1D0/PARU(1))*VINT(2)*HS/((SH-SQMH)**2+HS**2)
35399 IF(ABS(SHR-PMAS(KFHIGG,1)).GT.PARP(48)*PMAS(KFHIGG,2))
35400 & FACBW=0D0
35401 DO 570 I=MMINA,MMAXA
35402 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
35403 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 570
35404 NCHN=NCHN+1
35405 ISIG(NCHN,1)=I
35406 ISIG(NCHN,2)=-I
35407 ISIG(NCHN,3)=1
35408 SIGH(NCHN)=2d0*COMFAC*WTTBH*FACBW
35409c Since we don't know yet if H+ or H-, assume H+
35410c when calculating suppression due to closed channels.
35411 SIGH(NCHN)=SIGH(NCHN)*WIDS(37,2)*WIDS(6,3)
35412 IF(ABS(WIDS(37,2)-WIDS(37,3))/(WIDS(37,2)+WIDS(37,3))
35413 & .GE.1D-6.OR.
35414 & ABS(WIDS(6,2)-WIDS(6,3))/(WIDS(6,2)+WIDS(6,3))
35415 & .GE.1D-6) THEN
35416 WRITE(*,*)'Error: Process 402 cannot handle different'
35417 WRITE(*,*)'decays for H+ and H- or t and tbar.'
35418 WRITE(*,*)'Execution stopped.'
35419 CALL PYSTOP(108)
35420 END IF
35421 570 CONTINUE
35422 ENDIF
35423 ENDIF
35424
35425 RETURN
35426 END
35427
35428C*********************************************************************
35429
35430C...PYSGSU
35431C...Subprocess cross sections for SUSY processes,
35432C...including Higgs pair production.
35433C...Auxiliary to PYSIGH.
35434
35435 SUBROUTINE PYSGSU(NCHN,SIGS)
35436
35437C...Double precision and integer declarations
35438 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
35439 IMPLICIT INTEGER(I-N)
35440 INTEGER PYK,PYCHGE,PYCOMP
35441C...Parameter statement to help give large particle numbers.
35442 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
35443 &KEXCIT=4000000,KDIMEN=5000000)
35444C...Commonblocks
35445 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
35446 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
35447 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
35448 COMMON/PYINT1/MINT(400),VINT(400)
35449 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
35450 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
35451 COMMON/PYINT4/MWID(500),WIDS(500,5)
35452 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
35453 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
35454 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
35455 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
35456 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
35457 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
35458 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
35459 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
35460 &/PYINT4/,/PYMSSM/,/PYSSMT/,/PYSGCM/
35461C...Local arrays and complex variables
35462 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
35463 COMPLEX*16 OLPP,ORPP,OLP,ORP,OL,OR,QLL,QLR
35464 COMPLEX*16 QRR,QRL,GLIJ,GRIJ,PROPW,PROPZ
35465 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
35466
35467CMRENNA++
35468C...Z and W width, combinations of weak mixing angle
35469 ZWID=PMAS(23,2)
35470 WWID=PMAS(24,2)
35471 TANW=SQRT(XW/XW1)
35472 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
35473
35474C...Convert almost equivalent SUSY processes into each other
35475C...Extract differences in flavours and couplings
35476
35477C...Sleptons and sneutrinos
35478 IF(ISUB.EQ.201.OR.ISUB.EQ.204.OR.ISUB.EQ.207) THEN
35479 KFID=MOD(KFPR(ISUB,1),KSUSY1)
35480 ISUB=201
35481 ILR=0
35482 ELSEIF(ISUB.EQ.202.OR.ISUB.EQ.205.OR.ISUB.EQ.208) THEN
35483 KFID=MOD(KFPR(ISUB,1),KSUSY1)
35484 ISUB=201
35485 ILR=1
35486 ELSEIF(ISUB.EQ.203.OR.ISUB.EQ.206.OR.ISUB.EQ.209) THEN
35487 KFID=MOD(KFPR(ISUB,1),KSUSY1)
35488 ISUB=203
35489 ELSEIF(ISUB.GE.210.AND.ISUB.LE.212) THEN
35490 IF(ISUB.EQ.210) THEN
35491 RKF=2.0D0
35492 ELSEIF(ISUB.EQ.211) THEN
35493 RKF=SFMIX(15,1)**2
35494 ELSEIF(ISUB.EQ.212) THEN
35495 RKF=SFMIX(15,2)**2
35496 ENDIF
35497 ISUB=210
35498 ELSEIF(ISUB.EQ.213.OR.ISUB.EQ.214) THEN
35499 IF(ISUB.EQ.213) THEN
35500 KFID=MOD(KFPR(ISUB,1),KSUSY1)
35501 RKF=2.0D0
35502 ELSEIF(ISUB.EQ.214) THEN
35503 KFID=16
35504 RKF=1.0D0
35505 ENDIF
35506 ISUB=213
35507
35508C...Neutralinos
35509 ELSEIF(ISUB.GE.216.AND.ISUB.LE.225) THEN
35510 IF(ISUB.EQ.216) THEN
35511 IZID1=1
35512 IZID2=1
35513 ELSEIF(ISUB.EQ.217) THEN
35514 IZID1=2
35515 IZID2=2
35516 ELSEIF(ISUB.EQ.218) THEN
35517 IZID1=3
35518 IZID2=3
35519 ELSEIF(ISUB.EQ.219) THEN
35520 IZID1=4
35521 IZID2=4
35522 ELSEIF(ISUB.EQ.220) THEN
35523 IZID1=1
35524 IZID2=2
35525 ELSEIF(ISUB.EQ.221) THEN
35526 IZID1=1
35527 IZID2=3
35528 ELSEIF(ISUB.EQ.222) THEN
35529 IZID1=1
35530 IZID2=4
35531 ELSEIF(ISUB.EQ.223) THEN
35532 IZID1=2
35533 IZID2=3
35534 ELSEIF(ISUB.EQ.224) THEN
35535 IZID1=2
35536 IZID2=4
35537 ELSEIF(ISUB.EQ.225) THEN
35538 IZID1=3
35539 IZID2=4
35540 ENDIF
35541 ISUB=216
35542
35543C...Charginos
35544 ELSEIF(ISUB.GE.226.AND.ISUB.LE.228) THEN
35545 IF(ISUB.EQ.226) THEN
35546 IZID1=1
35547 IZID2=1
35548 ELSEIF(ISUB.EQ.227) THEN
35549 IZID1=2
35550 IZID2=2
35551 ELSEIF(ISUB.EQ.228) THEN
35552 IZID1=1
35553 IZID2=2
35554 ENDIF
35555 ISUB=226
35556
35557C...Neutralino + chargino
35558 ELSEIF(ISUB.GE.229.AND.ISUB.LE.236) THEN
35559 IF(ISUB.EQ.229) THEN
35560 IZID1=1
35561 IZID2=1
35562 ELSEIF(ISUB.EQ.230) THEN
35563 IZID1=1
35564 IZID2=2
35565 ELSEIF(ISUB.EQ.231) THEN
35566 IZID1=1
35567 IZID2=3
35568 ELSEIF(ISUB.EQ.232) THEN
35569 IZID1=1
35570 IZID2=4
35571 ELSEIF(ISUB.EQ.233) THEN
35572 IZID1=2
35573 IZID2=1
35574 ELSEIF(ISUB.EQ.234) THEN
35575 IZID1=2
35576 IZID2=2
35577 ELSEIF(ISUB.EQ.235) THEN
35578 IZID1=2
35579 IZID2=3
35580 ELSEIF(ISUB.EQ.236) THEN
35581 IZID1=2
35582 IZID2=4
35583 ENDIF
35584 ISUB=229
35585
35586C...Gluino + neutralino
35587 ELSEIF(ISUB.GE.237.AND.ISUB.LE.240) THEN
35588 IF(ISUB.EQ.237) THEN
35589 IZID=1
35590 ELSEIF(ISUB.EQ.238) THEN
35591 IZID=2
35592 ELSEIF(ISUB.EQ.239) THEN
35593 IZID=3
35594 ELSEIF(ISUB.EQ.240) THEN
35595 IZID=4
35596 ENDIF
35597 ISUB=237
35598
35599C...Gluino + chargino
35600 ELSEIF(ISUB.GE.241.AND.ISUB.LE.242) THEN
35601 IF(ISUB.EQ.241) THEN
35602 IZID=1
35603 ELSEIF(ISUB.EQ.242) THEN
35604 IZID=2
35605 ENDIF
35606 ISUB=241
35607
35608C...Squark + neutralino
35609 ELSEIF(ISUB.GE.246.AND.ISUB.LE.253) THEN
35610 ILR=0
35611 IF(MOD(ISUB,2).NE.0) ILR=1
35612 IF(ISUB.LE.247) THEN
35613 IZID=1
35614 ELSEIF(ISUB.LE.249) THEN
35615 IZID=2
35616 ELSEIF(ISUB.LE.251) THEN
35617 IZID=3
35618 ELSEIF(ISUB.LE.253) THEN
35619 IZID=4
35620 ENDIF
35621 ISUB=246
35622 RKF=5D0
35623
35624C...Squark + chargino
35625 ELSEIF(ISUB.GE.254.AND.ISUB.LE.257) THEN
35626 IF(ISUB.LE.255) THEN
35627 IZID=1
35628 ELSEIF(ISUB.LE.257) THEN
35629 IZID=2
35630 ENDIF
35631 IF(MOD(ISUB,2).EQ.0) THEN
35632 ILR=0
35633 ELSE
35634 ILR=1
35635 ENDIF
35636 ISUB=254
35637 RKF=5D0
35638
35639C...Squark + gluino
35640 ELSEIF(ISUB.EQ.258.OR.ISUB.EQ.259) THEN
35641 ISUB=258
35642 RKF=4D0
35643
35644C...Stops
35645 ELSEIF(ISUB.EQ.261.OR.ISUB.EQ.262) THEN
35646 ILR=0
35647 IF(ISUB.EQ.262) ILR=1
35648 ISUB=261
35649 ELSEIF(ISUB.EQ.265) THEN
35650 ISUB=264
35651
35652C...Squarks
35653 ELSEIF(ISUB.GE.271.AND.ISUB.LE.280) THEN
35654 ILR=0
35655 IF(ISUB.LE.273) THEN
35656 IF(ISUB.EQ.273) ILR=1
35657 ISUB=271
35658 RKF=16D0
35659 ELSEIF(ISUB.LE.276) THEN
35660 IF(ISUB.EQ.276) ILR=1
35661 ISUB=274
35662 RKF=16D0
35663 ELSEIF(ISUB.LE.278) THEN
35664 IF(ISUB.EQ.278) ILR=1
35665 ISUB=277
35666 RKF=4D0
35667 ELSE
35668 IF(ISUB.EQ.280) ILR=1
35669 ISUB=279
35670 RKF=4D0
35671 ENDIF
35672C...Sbottoms
35673 ELSEIF(ISUB.GE.281.AND.ISUB.LE.296) THEN
35674 ILR=0
35675 IF(ISUB.LE.283) THEN
35676 IF(ISUB.EQ.283) ILR=1
35677 ISUB=271
35678 RKF=4D0
35679 ELSEIF(ISUB.LE.286) THEN
35680 IF(ISUB.EQ.286) ILR=1
35681 ISUB=274
35682 RKF=4D0
35683 ELSEIF(ISUB.LE.288) THEN
35684 IF(ISUB.EQ.288) ILR=1
35685 ISUB=277
35686 RKF=1D0
35687 ELSEIF(ISUB.LE.290) THEN
35688 IF(ISUB.EQ.290) ILR=1
35689 ISUB=279
35690 RKF=1D0
35691 ELSEIF(ISUB.LE.293) THEN
35692 IF(ISUB.EQ.293) ILR=1
35693 ISUB=271
35694 RKF=1D0
35695 ELSEIF(ISUB.EQ.296) THEN
35696 ILR=1
35697 ISUB=274
35698 RKF=1D0
35699C...Squark + gluino
35700 ELSEIF(ISUB.EQ.294.OR.ISUB.EQ.295) THEN
35701 ISUB=258
35702 RKF=1D0
35703 ENDIF
35704C...H+/- + H0
35705 ELSEIF(ISUB.EQ.297.OR.ISUB.EQ.298) THEN
35706 IF(ISUB.EQ.297) THEN
35707 RKF=.5D0*PARU(195)**2
35708 ELSEIF(ISUB.EQ.298) THEN
35709 RKF=.5D0*(1D0-PARU(195)**2)
35710 ENDIF
35711 ISUB=210
35712C...A0 + H0
35713 ELSEIF(ISUB.EQ.299.OR.ISUB.EQ.300) THEN
35714 IF(ISUB.EQ.299) THEN
35715 RKF=PARU(186)**2
35716 KFID=25
35717 ELSEIF(ISUB.EQ.300) THEN
35718 RKF=PARU(187)**2
35719 KFID=35
35720 ENDIF
35721 ISUB=213
35722C...H+ + H-
35723 ELSEIF(ISUB.EQ.301) THEN
35724 KFID=37
35725 RKF=1D0
35726 ISUB=201
35727 ENDIF
35728
35729C...Supersymmetric processes - all of type 2 -> 2 :
35730C...correct final-state Breit-Wigners from fixed to running width.
35731 IF(MSTP(42).GT.0) THEN
35732 DO 100 I=1,2
35733 KFLW=KFPR(ISUBSV,I)
35734 KCW=PYCOMP(KFLW)
35735 IF(PMAS(KCW,2).LT.PARP(41)) GOTO 100
35736 IF(I.EQ.1) SQMI=SQM3
35737 IF(I.EQ.2) SQMI=SQM4
35738 SQMS=PMAS(KCW,1)**2
35739 GMMS=PMAS(KCW,1)*PMAS(KCW,2)
35740 HBWS=GMMS/((SQMI-SQMS)**2+GMMS**2)
35741 CALL PYWIDT(KFLW,SQMI,WDTP,WDTE)
35742 GMMI=SQRT(SQMI)*WDTP(0)
35743 HBWI=GMMI/((SQMI-SQMS)**2+GMMI**2)
35744 COMFAC=COMFAC*(HBWI/HBWS)
35745 100 CONTINUE
35746 ENDIF
35747
35748C...Differential cross section expressions.
35749
35750 IF(ISUB.LE.210) THEN
35751 IF(ISUB.EQ.201) THEN
35752C...f + fbar -> e_L + e_Lbar
35753 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35754 DO 130 I=MMIN1,MMAX1
35755 IA=IABS(I)
35756 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 130
35757 EI=KCHG(IA,1)/3D0
35758 TT3I=SIGN(1D0,EI+1D-6)/2D0
35759 EJ=-1D0
35760 TT3J=-1D0/2D0
35761 FCOL=1D0
35762C...Color factor for e+ e-
35763 IF(IA.GE.11) FCOL=3D0
35764 IF(ISUBSV.EQ.301) THEN
35765 A1=1D0
35766 A2=0D0
35767 ELSEIF(ILR.EQ.1) THEN
35768 A1=SFMIX(KFID,3)**2
35769 A2=SFMIX(KFID,4)**2
35770 ELSEIF(ILR.EQ.0) THEN
35771 A1=SFMIX(KFID,1)**2
35772 A2=SFMIX(KFID,2)**2
35773 ENDIF
35774 XLQ=(TT3J-EJ*XW)*A1
35775 XRQ=(-EJ*XW)*A2
35776 XLF=(TT3I-EI*XW)
35777 XRF=(-EI*XW)
35778 TAA=(EI*EJ)**2*(POLL+POLR)
35779 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ+XRQ)**2/XW**2/XW1**2
35780 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*ZWID/SH**2)
35781 TAZ=2D0*EI*EJ*(XLQ+XRQ)*(XLF*POLL+XRF*POLR)/XW/XW1
35782 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
35783 TNN=0.0D0
35784 TAN=0.0D0
35785 TZN=0.0D0
35786 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35787 FAC2=SQRT(2D0)
35788 TNN1=0D0
35789 TNN2=0D0
35790 TNN3=0D0
35791 DO 120 II=1,4
35792 DK=1D0/(TH-SMZ(II)**2)
35793 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35794 & ZMIX(II,1))
35795 FREK=FAC2*TANW*EI*ZMIX(II,1)
35796 TNN1=TNN1+FLEK**2*DK
35797 TNN2=TNN2+FREK**2*DK
35798 DO 110 JJ=1,4
35799 DL=1D0/(TH-SMZ(JJ)**2)
35800 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35801 & ZMIX(JJ,1))
35802 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35803 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35804 110 CONTINUE
35805 120 CONTINUE
35806 TNN=(UH*TH-SQM3*SQM4)*(A1**2*TNN1**2*POLL+
35807 & A2**2*TNN2**2*POLR)
35808 TNN=(TNN+SH*A1*A2*TNN3*((1D0-PARJ(131))*(1D0-PARJ(132))+
35809 & (1D0+PARJ(131))*(1D0+PARJ(132))))/4D0/XW**2
35810 TZN=(UH*TH-SQM3*SQM4)*(XLQ+XRQ)*
35811 & (TNN1*XLF*A1*POLL+TNN2*XRF*A2*POLR)
35812 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35813 & (1D0-SQMZ/SH)/SH
35814 TZN=TZN/XW**2/XW1
35815 TAN=EI*EJ*(UH*TH-SQM3*SQM4)/SH*(A1*TNN1*POLL+
35816 & A2*TNN2*POLR)/XW
35817 ENDIF
35818 FACQQ1=COMFAC*AEM**2*(TAA+TZZ+TAZ)*FCOL/3D0
35819 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH**2
35820 FACQQ2=COMFAC*AEM**2*(TNN+TZN+TAN)*FCOL/3D0
35821 NCHN=NCHN+1
35822 ISIG(NCHN,1)=I
35823 ISIG(NCHN,2)=-I
35824 ISIG(NCHN,3)=1
35825 SIGH(NCHN)=FACQQ1+FACQQ2
35826 130 CONTINUE
35827
35828 ELSEIF(ISUB.EQ.203) THEN
35829C...f + fbar -> e_L + e_Rbar
35830 DO 160 I=MMIN1,MMAX1
35831 IA=IABS(I)
35832 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 160
35833 EI=KCHG(IABS(I),1)/3D0
35834 TT3I=SIGN(1D0,EI)/2D0
35835 EJ=-1
35836 TT3J=-1D0/2D0
35837 FCOL=1D0
35838C...Color factor for e+ e-
35839 IF(IA.GE.11) FCOL=3D0
35840 A1=SFMIX(KFID,1)**2
35841 A2=SFMIX(KFID,2)**2
35842 XLQ=(TT3J-EJ*XW)
35843 XRQ=(-EJ*XW)
35844 XLF=(TT3I-EI*XW)
35845 XRF=(-EI*XW)
35846 TZZ=(XLF**2*POLL+XRF**2*POLR)*(XLQ-XRQ)**2
35847 & /XW**2/XW1**2*A1*A2
35848 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
35849 TNN=0.0D0
35850 TZN=0.0D0
35851 TNNA=0D0
35852 TNNB=0D0
35853 IF(IA.GE.11.AND.IA.LE.18.AND.KFID.EQ.IA) THEN
35854 FAC2=SQRT(2D0)
35855 TNN1=0D0
35856 TNN2=0D0
35857 TNN3=0D0
35858 DO 150 II=1,4
35859 DK=1D0/(TH-SMZ(II)**2)
35860 FLEK=-FAC2*(TT3I*ZMIX(II,2)-TANW*(TT3I-EI)*
35861 & ZMIX(II,1))
35862 FREK=FAC2*TANW*EI*ZMIX(II,1)
35863 TNN1=TNN1+FLEK**2*DK
35864 TNN2=TNN2+FREK**2*DK
35865 DO 140 JJ=1,4
35866 DL=1D0/(TH-SMZ(JJ)**2)
35867 FLEL=-FAC2*(TT3J*ZMIX(JJ,2)-TANW*(TT3J-EJ)*
35868 & ZMIX(JJ,1))
35869 FREL=FAC2*TANW*EJ*ZMIX(JJ,1)
35870 TNN3=TNN3+FLEK*FREK*FLEL*FREL*DK*DL*SMZ(II)*SMZ(JJ)
35871 140 CONTINUE
35872 150 CONTINUE
35873 TNN=(UH*TH-SQM3*SQM4)*A1*A2*(TNN2**2*POLR+TNN1**2*POLL)
35874 TNNA=(TNN+SH*(A1**2*POLLL+A2**2*POLRR)*TNN3)/4D0
35875 TNNB=(TNN+SH*(A1**2*POLRR+A2**2*POLLL)*TNN3)/4D0
35876 TZN=(UH*TH-SQM3*SQM4)*A1*A2
35877 TZN=TZN*(XLQ-XRQ)*(XLF*TNN1*POLL-XRF*TNN2*POLR)/XW1
35878 TZN=TZN/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*
35879 & (1D0-SQMZ/SH)/SH
35880 ENDIF
35881 FACQQ0=COMFAC*AEM**2*TZZ*FCOL/3D0*(UH*TH-SQM3*SQM4)/SH2
35882 FACQQ2=COMFAC*AEM**2/XW**2*(TNNA+TZN)*FCOL/3D0
35883 FACQQ1=COMFAC*AEM**2/XW**2*(TNNB+TZN)*FCOL/3D0
35884C%%%%%%%%%%%
35885 NCHN=NCHN+1
35886 ISIG(NCHN,1)=I
35887 ISIG(NCHN,2)=-I
35888 ISIG(NCHN,3)=1
35889 SIGH(NCHN)=(FACQQ0+FACQQ1)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35890 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
35891 NCHN=NCHN+1
35892 ISIG(NCHN,1)=I
35893 ISIG(NCHN,2)=-I
35894 ISIG(NCHN,3)=2
35895 SIGH(NCHN)=(FACQQ0+FACQQ2)*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
35896 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35897 160 CONTINUE
35898
35899 ELSEIF(ISUB.EQ.210) THEN
35900C...q + qbar' -> W*- > ~l_L + ~nu_L
35901 FAC0=RKF*COMFAC*AEM**2/XW**2/12D0
35902 FAC1=(TH*UH-SQM3*SQM4)/((SH-SQMW)**2+WWID**2*SQMW)
35903 DO 180 I=MMIN1,MMAX1
35904 IA=IABS(I)
35905 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 180
35906 DO 170 J=MMIN2,MMAX2
35907 JA=IABS(J)
35908 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 170
35909 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 170
35910 FCKM=3D0
35911 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
35912 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
35913 KCHW=2
35914 IF(KCHSUM.LT.0) KCHW=3
35915 NCHN=NCHN+1
35916 ISIG(NCHN,1)=I
35917 ISIG(NCHN,2)=J
35918 ISIG(NCHN,3)=1
35919 IF(ISUBSV.EQ.297.OR.ISUBSV.EQ.298) THEN
35920 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35921 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35922 ELSE
35923 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),5-KCHW)*
35924 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
35925 ENDIF
35926 SIGH(NCHN)=FAC0*FAC1*FCKM*FACR
35927 170 CONTINUE
35928 180 CONTINUE
35929 ENDIF
35930
35931 ELSEIF(ISUB.LE.220) THEN
35932 IF(ISUB.EQ.213) THEN
35933C...f + fbar -> ~nu_L + ~nu_Lbar
35934 IF(ISUBSV.EQ.299.OR.ISUBSV.EQ.300) THEN
35935 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35936 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35937 ELSE
35938 FACR=WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35939 ENDIF
35940 COMFAC=COMFAC*FACR
35941 PROPZ2=(SH-SQMZ)**2+ZWID**2*SQMZ
35942 XLL=0.5D0
35943 XLR=0.0D0
35944 DO 190 I=MMIN1,MMAX1
35945 IA=IABS(I)
35946 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 190
35947 EI=KCHG(IA,1)/3D0
35948 FCOL=1D0
35949C...Color factor for e+ e-
35950 IF(IA.GE.11) FCOL=3D0
35951 XLQ=(SIGN(1D0,EI)-2D0*EI*XW)/2D0
35952 XRQ=-EI*XW
35953 TZC=0.0D0
35954 TCC=0.0D0
35955 IF(IA.GE.11.AND.KFID.EQ.IA+1) THEN
35956 TZC=VMIX(1,1)**2/(TH-SMW(1)**2)+VMIX(2,1)**2/
35957 & (TH-SMW(2)**2)
35958 TCC=TZC**2
35959 TZC=TZC/XW1*(SH-SQMZ)/PROPZ2*XLQ*XLL
35960 ENDIF
35961 FACQQ1=(XLQ**2+XRQ**2)*(XLL+XLR)**2/XW1**2/PROPZ2
35962 FACQQ2=TZC+TCC/4D0
35963 NCHN=NCHN+1
35964 ISIG(NCHN,1)=I
35965 ISIG(NCHN,2)=-I
35966 ISIG(NCHN,3)=1
35967 SIGH(NCHN)=(FACQQ1+FACQQ2)*RKF*(UH*TH-SQM3*SQM4)*COMFAC
35968 & *AEM**2*FCOL/3D0/XW**2
35969 190 CONTINUE
35970
35971 ELSEIF(ISUB.EQ.216) THEN
35972C...q + qbar -> ~chi0_1 + ~chi0_1
35973 IF(IZID1.EQ.IZID2) THEN
35974 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
35975 ELSE
35976 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
35977 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
35978 ENDIF
35979 FACXX=COMFAC*AEM**2/3D0/XW**2
35980 IF(IZID1.EQ.IZID2) FACXX=FACXX/2D0
35981 ZM12=SQM3
35982 ZM22=SQM4
35983 WU2 = (UH-ZM12)*(UH-ZM22)
35984 WT2 = (TH-ZM12)*(TH-ZM22)
35985 WS2 = SMZ(IZID1)*SMZ(IZID2)*SH
35986 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
35987 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
35988 DO 200 I=1,4
35989 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
35990 IF(IZID2.NE.IZID1) THEN
35991 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
35992 ENDIF
35993 200 CONTINUE
35994 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
35995 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
35996 ORPP=DCONJG(OLPP)
35997 DO 210 I=MMINA,MMAXA
35998 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 210
35999 EI=KCHG(IABS(I),1)/3D0
36000 T3I=SIGN(1D0,EI+1D-6)/2D0
36001 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2
36002 XMR2=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2
36003 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
36004 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
36005 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
36006 QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
36007 QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
36008 & /DCMPLX(TH-XML2)
36009 QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
36010 QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
36011 & -DCONJG(GRIJ)/DCMPLX(UH-XMR2)
36012 FCOL=1D0
36013 IF(IABS(I).GE.11) FCOL=3D0
36014 FACGG1=(ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
36015 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
36016 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
36017 & QRL*DCONJG(QRR)*POLR)*WS2
36018 NCHN=NCHN+1
36019 ISIG(NCHN,1)=I
36020 ISIG(NCHN,2)=-I
36021 ISIG(NCHN,3)=1
36022 SIGH(NCHN)=FACXX*FACGG1*FCOL
36023 210 CONTINUE
36024 ENDIF
36025
36026 ELSEIF(ISUB.LE.230) THEN
36027 IF(ISUB.EQ.226) THEN
36028C...f + fbar -> ~chi+_1 + ~chi-_1
36029 FACXX=COMFAC*AEM**2/3D0
36030 ZM12=SQM3
36031 ZM22=SQM4
36032 WU2 = (UH-ZM12)*(UH-ZM22)
36033 WT2 = (TH-ZM12)*(TH-ZM22)
36034 WS2 = SMW(IZID1)*SMW(IZID2)*SH
36035 PROPZ2 = (SH-SQMZ)**2 + SQMZ*ZWID**2
36036 PROPZ=DCMPLX(SH-SQMZ,-ZWID*PMAS(23,1))/DCMPLX(PROPZ2)
36037 DIFF=0D0
36038 IF(IZID1.EQ.IZID2) DIFF=1D0
36039 DO 220 I=1,2
36040 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
36041 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
36042 IF(IZID2.NE.IZID1) THEN
36043 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
36044 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
36045 ENDIF
36046 220 CONTINUE
36047 OLP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
36048 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0+DCMPLX(XW*DIFF)
36049 ORP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
36050 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0+DCMPLX(XW*DIFF)
36051 DO 230 I=MMINA,MMAXA
36052 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 230
36053 EI=KCHG(IABS(I),1)/3D0
36054 T3I=SIGN(1D0,EI+1D-6)/2D0
36055 QRL=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*ORP
36056 QLL=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*PROPZ*ORP
36057 QRR=DCMPLX(-EI/SH*DIFF)-DCMPLX(EI/XW1)*PROPZ*OLP
36058 IF(MOD(I,2).EQ.0) THEN
36059 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)-1),1)**2
36060 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
36061 & PROPZ*OLP-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*
36062 & DCMPLX(T3I/XW/(TH-XML2))
36063 ELSE
36064 XML2=PMAS(PYCOMP(KSUSY1+IABS(I)+1),1)**2
36065 QLR=DCMPLX(-EI/SH*DIFF)+DCMPLX((T3I-XW*EI)/XW/XW1)*
36066 & PROPZ*OLP-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*
36067 & DCMPLX(T3I/XW/(TH-XML2))
36068 ENDIF
36069 FCOL=1D0
36070 IF(IABS(I).GE.11) FCOL=3D0
36071 FACSUM=((ABS(QLL)**2*POLL+ABS(QRR)**2*POLR)*WU2+
36072 & (ABS(QRL)**2*POLR+ABS(QLR)**2*POLL)*WT2+
36073 & 2D0*DBLE(QLR*DCONJG(QLL)*POLL+
36074 & QRL*DCONJG(QRR)*POLR)*WS2)*FACXX*FCOL
36075 NCHN=NCHN+1
36076 ISIG(NCHN,1)=I
36077 ISIG(NCHN,2)=-I
36078 ISIG(NCHN,3)=1
36079 IF(IZID1.EQ.IZID2) THEN
36080 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36081 ELSE
36082 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
36083 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36084 NCHN=NCHN+1
36085 ISIG(NCHN,1)=I
36086 ISIG(NCHN,2)=-I
36087 ISIG(NCHN,3)=2
36088 SIGH(NCHN)=FACSUM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36089 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
36090 ENDIF
36091 230 CONTINUE
36092
36093 ELSEIF(ISUB.EQ.229) THEN
36094C...q + qbar' -> ~chi0_1 + ~chi+-_1
36095 FACXX=COMFAC*AEM**2/6D0/XW**2
36096 ZM12=SQM3
36097 ZM22=SQM4
36098 WU2 = (UH-ZM12)*(UH-ZM22)
36099 WT2 = (TH-ZM12)*(TH-ZM22)
36100 WS2 = SMW(IZID1)*SMZ(IZID2)*SH
36101 RT2I = 1D0/SQRT(2D0)
36102 PROPW = DCMPLX(SH-SQMW,-WWID*PMAS(24,1))/
36103 & DCMPLX((SH-SQMW)**2+WWID**2*SQMW,0D0)
36104 DO 240 I=1,2
36105 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
36106 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
36107 240 CONTINUE
36108 DO 250 I=1,4
36109 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
36110 250 CONTINUE
36111 OL=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
36112 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)*PROPW
36113 OR=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
36114 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)*PROPW
36115
36116 DO 270 I=MMIN1,MMAX1
36117 IA=IABS(I)
36118 IF(I.EQ.0.OR.IA.GT.20.OR.KFAC(1,I).EQ.0) GOTO 270
36119 EI=KCHG(IA,1)/3D0
36120 T3I=SIGN(1D0,EI+1D-6)/2D0
36121 DO 260 J=MMIN2,MMAX2
36122 JA=IABS(J)
36123 IF(J.EQ.0.OR.JA.GT.20.OR.KFAC(2,J).EQ.0) GOTO 260
36124 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 260
36125 EJ=KCHG(JA,1)/3D0
36126 T3J=SIGN(1D0,EJ+1D-6)/2D0
36127 FCKM=3D0
36128 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
36129 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
36130 KCHW=2
36131 IF(KCHSUM.LT.0) KCHW=3
36132 IF(MOD(IA,2).EQ.0) THEN
36133 ZMI2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
36134 ZMJ2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
36135 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
36136 & TANW+ZMIXC(IZID2,2)*T3I)/DCMPLX(UH-ZMI2)
36137 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
36138 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
36139 & /DCMPLX(TH-ZMJ2)
36140 ELSE
36141 ZMI2 = PMAS(PYCOMP(KSUSY1+JA),1)**2
36142 ZMJ2 = PMAS(PYCOMP(KSUSY1+IA),1)**2
36143 QLL=OL+VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
36144 & TANW+ZMIXC(IZID2,2)*T3J)/DCMPLX(UH-ZMJ2)
36145 QLR=OR-DCONJG(UMIXC(IZID1,1))*(
36146 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
36147 & /DCMPLX(TH-ZMI2)
36148 ENDIF
36149 ZINTR=DBLE(QLR*DCONJG(QLL))
36150 FACGG1=FACXX*(ABS(QLL)**2*WU2+ABS(QLR)**2*WT2+
36151 & 2D0*ZINTR*WS2)
36152 NCHN=NCHN+1
36153 ISIG(NCHN,1)=I
36154 ISIG(NCHN,2)=J
36155 ISIG(NCHN,3)=1
36156 SIGH(NCHN)=FACGG1*FCKM*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36157 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
36158 260 CONTINUE
36159 270 CONTINUE
36160 ENDIF
36161
36162 ELSEIF(ISUB.LE.240) THEN
36163 IF(ISUB.EQ.237) THEN
36164C...q + qbar -> gluino + ~chi0_1
36165 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36166 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36167 ASYUK=RMSS(42)*AS
36168 FAC0=COMFAC*ASYUK*AEM*4D0/9D0/XW
36169 GM2=SQM3
36170 ZM2=SQM4
36171 DO 280 I=MMINA,MMAXA
36172 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36173 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 280
36174 EI=KCHG(IABS(I),1)/3D0
36175 IA=IABS(I)
36176 XLQC = -TANW*EI*ZMIX(IZID,1)
36177 XRQC =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
36178 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
36179 XLQ2=XLQC**2
36180 XRQ2=XRQC**2
36181 XML2=PMAS(PYCOMP(KSUSY1+IA),1)**2
36182 XMR2=PMAS(PYCOMP(KSUSY2+IA),1)**2
36183 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XML2)**2
36184 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XML2)**2
36185 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XML2)/(UH-XML2)
36186 SGCHIL=XLQ2*(ATKIN+AUKIN-2D0*ATUKIN)
36187 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMR2)**2
36188 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMR2)**2
36189 ATUKIN=SMZ(IZID)*SQRT(GM2)*SH/(TH-XMR2)/(UH-XMR2)
36190 SGCHIR=XRQ2*(ATKIN+AUKIN-2D0*ATUKIN)
36191 NCHN=NCHN+1
36192 ISIG(NCHN,1)=I
36193 ISIG(NCHN,2)=-I
36194 ISIG(NCHN,3)=1
36195 SIGH(NCHN)=FAC0*(SGCHIL+SGCHIR)
36196 280 CONTINUE
36197 ENDIF
36198
36199 ELSEIF(ISUB.LE.250) THEN
36200 IF(ISUB.EQ.241) THEN
36201C...q + qbar' -> ~chi+-_1 + gluino
36202 FACWG=COMFAC*AS*AEM/XW*2D0/9D0
36203 GM2=SQM3
36204 ZM2=SQM4
36205 FAC01=2D0*UMIX(IZID,1)*VMIX(IZID,1)
36206 FAC0=UMIX(IZID,1)**2
36207 FAC1=VMIX(IZID,1)**2
36208 DO 300 I=MMIN1,MMAX1
36209 IA=IABS(I)
36210 IF(I.EQ.0.OR.IA.GT.10.OR.KFAC(1,I).EQ.0) GOTO 300
36211 DO 290 J=MMIN2,MMAX2
36212 JA=IABS(J)
36213 IF(J.EQ.0.OR.JA.GT.10.OR.KFAC(2,J).EQ.0) GOTO 290
36214 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 290
36215 FCKM=1D0
36216 IF(IA.LE.10) FCKM=VCKM((IA+1)/2,(JA+1)/2)
36217 KCHSUM=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
36218 KCHW=2
36219 IF(KCHSUM.LT.0) KCHW=3
36220 XMU2=PMAS(PYCOMP(KSUSY1+2),1)**2
36221 XMD2=PMAS(PYCOMP(KSUSY1+1),1)**2
36222 ATKIN=(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2
36223 AUKIN=(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2
36224 ATUKIN=SMW(IZID)*SQRT(GM2)*SH/(TH-XMU2)/(UH-XMD2)
36225 XMU2=PMAS(PYCOMP(KSUSY2+2),1)**2
36226 XMD2=PMAS(PYCOMP(KSUSY2+1),1)**2
36227 ATKIN=(ATKIN+(TH-GM2)*(TH-ZM2)/(TH-XMU2)**2)/2D0
36228 AUKIN=(AUKIN+(UH-GM2)*(UH-ZM2)/(UH-XMD2)**2)/2D0
36229 ATUKIN=(ATUKIN+SMW(IZID)*SQRT(GM2)*
36230 & SH/(TH-XMU2)/(UH-XMD2))/2D0
36231 NCHN=NCHN+1
36232 ISIG(NCHN,1)=I
36233 ISIG(NCHN,2)=J
36234 ISIG(NCHN,3)=1
36235 SIGH(NCHN)=FACWG*FCKM*(FAC0*ATKIN+FAC1*AUKIN-
36236 & FAC01*ATUKIN)*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36237 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHW)
36238 290 CONTINUE
36239 300 CONTINUE
36240
36241 ELSEIF(ISUB.EQ.243) THEN
36242C...q + qbar -> gluino + gluino
36243 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36244 XMT=SQM3-TH
36245 XMU=SQM3-UH
36246 DO 310 I=MMINA,MMAXA
36247 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
36248 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 310
36249 NCHN=NCHN+1
36250 XSU=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-UH
36251 XST=PMAS(PYCOMP(KSUSY1+IABS(I)),1)**2-TH
36252 FACGG1=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
36253 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
36254 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
36255 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
36256 XSU=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-UH
36257 XST=PMAS(PYCOMP(KSUSY2+IABS(I)),1)**2-TH
36258 FACGG2=COMFAC*AS**2*8D0/3D0*( (XMT**2+XMU**2+
36259 & 2D0*SQM3*SH)/SH2 + RMSS(42)**2*(4D0/9D0*(XMT**2/XST**2+
36260 & XMU**2/XSU**2) + SQM3*SH/XST/XSU/9D0) - RMSS(42)*(
36261 & (XMT**2+SH*SQM3)/SH/XST + (XMU**2+SH*SQM3)/SH/XSU ))
36262 ISIG(NCHN,1)=I
36263 ISIG(NCHN,2)=-I
36264 ISIG(NCHN,3)=1
36265C...1/2 for identical particles
36266 SIGH(NCHN)=0.25D0*(FACGG1+FACGG2)
36267 310 CONTINUE
36268
36269 ELSEIF(ISUB.EQ.244) THEN
36270C...g + g -> gluino + gluino
36271 COMFAC=COMFAC*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36272 XMT=SQM3-TH
36273 XMU=SQM3-UH
36274 FACQQ1=COMFAC*AS**2*9D0/4D0*(
36275 & (XMT*XMU-2D0*SQM3*(TH+SQM3))/XMT**2 -
36276 & (XMT*XMU+SQM3*(UH-TH))/SH/XMT )
36277 FACQQ2=COMFAC*AS**2*9D0/4D0*(
36278 & (XMU*XMT-2D0*SQM3*(UH+SQM3))/XMU**2 -
36279 & (XMU*XMT+SQM3*(TH-UH))/SH/XMU )
36280 FACQQ3=COMFAC*AS**2*9D0/4D0*(2D0*XMT*XMU/SH2 +
36281 & SQM3*(SH-4D0*SQM3)/XMT/XMU)
36282 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 320
36283 NCHN=NCHN+1
36284 ISIG(NCHN,1)=21
36285 ISIG(NCHN,2)=21
36286 ISIG(NCHN,3)=1
36287 SIGH(NCHN)=FACQQ1/2D0
36288 NCHN=NCHN+1
36289 ISIG(NCHN,1)=21
36290 ISIG(NCHN,2)=21
36291 ISIG(NCHN,3)=2
36292 SIGH(NCHN)=FACQQ2/2D0
36293 NCHN=NCHN+1
36294 ISIG(NCHN,1)=21
36295 ISIG(NCHN,2)=21
36296 ISIG(NCHN,3)=3
36297 SIGH(NCHN)=FACQQ3/2D0
36298 320 CONTINUE
36299
36300 ELSEIF(ISUB.EQ.246) THEN
36301C...g + q_j -> ~chi0_1 + ~q_j
36302 FAC0=COMFAC*AS*AEM/6D0/XW
36303 ZM2=SQM4
36304 QM2=SQM3
36305 FACZQ0=FAC0*( (ZM2-TH)/SH +
36306 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
36307 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
36308 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36309 DO 340 I=-KFNSQ,KFNSQ,2*KFNSQ
36310 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 340
36311 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 340
36312 EI=KCHG(IABS(I),1)/3D0
36313 IA=IABS(I)
36314 XRQZ = -TANW*EI*ZMIX(IZID,1)
36315 XLQZ =(SIGN(1D0,EI)*ZMIX(IZID,2)-TANW*
36316 & (SIGN(1D0,EI)-2D0*EI)*ZMIX(IZID,1))/2D0
36317 IF(ILR.EQ.0) THEN
36318 BS=XLQZ**2*SFMIX(IA,1)**2+XRQZ**2*SFMIX(IA,2)**2
36319 ELSE
36320 BS=XLQZ**2*SFMIX(IA,3)**2+XRQZ**2*SFMIX(IA,4)**2
36321 ENDIF
36322 FACZQ=FACZQ0*BS
36323 KCHQ=2
36324 IF(I.LT.0) KCHQ=3
36325 DO 330 ISDE=1,2
36326 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 330
36327 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 330
36328 NCHN=NCHN+1
36329 ISIG(NCHN,ISDE)=I
36330 ISIG(NCHN,3-ISDE)=21
36331 ISIG(NCHN,3)=1
36332 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36333 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36334 330 CONTINUE
36335 340 CONTINUE
36336 ENDIF
36337
36338 ELSEIF(ISUB.LE.260) THEN
36339 IF(ISUB.EQ.254) THEN
36340C...g + q_j -> ~chi1_1 + ~q_i
36341 FAC0=COMFAC*AS*AEM/12D0/XW
36342 ZM2=SQM4
36343 QM2=SQM3
36344 AU=UMIX(IZID,1)**2
36345 AD=VMIX(IZID,1)**2
36346 FACZQ0=FAC0*( (ZM2-TH)/SH +
36347 & (UH-ZM2)*(UH+QM2)/(UH-QM2)**2 -
36348 & (SH*(UH+ZM2)+2D0*(QM2-ZM2)*(ZM2-UH))/SH/(UH-QM2) )
36349 KFNSQ1=MOD(KFPR(ISUBSV,1),KSUSY1)
36350 IF(MOD(KFNSQ1,2).EQ.0) THEN
36351 KFNSQ=KFNSQ1-1
36352 KCHW=2
36353 ELSE
36354 KFNSQ=KFNSQ1+1
36355 KCHW=3
36356 ENDIF
36357 DO 360 I=-KFNSQ,KFNSQ,2*KFNSQ
36358 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 360
36359 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 360
36360 IA=IABS(I)
36361 IF(MOD(IA,2).EQ.0) THEN
36362 FACZQ=FACZQ0*AU
36363 ELSE
36364 FACZQ=FACZQ0*AD
36365 ENDIF
36366 FACZQ=FACZQ*SFMIX(KFNSQ1,1+2*ILR)**2
36367 KCHQ=2
36368 IF(I.LT.0) KCHQ=3
36369 KCHWQ=KCHW
36370 IF(I.LT.0) KCHWQ=5-KCHW
36371 DO 350 ISDE=1,2
36372 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 350
36373 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 350
36374 NCHN=NCHN+1
36375 ISIG(NCHN,ISDE)=I
36376 ISIG(NCHN,3-ISDE)=21
36377 ISIG(NCHN,3)=1
36378 SIGH(NCHN)=FACZQ*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36379 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHWQ)
36380 350 CONTINUE
36381 360 CONTINUE
36382
36383 ELSEIF(ISUB.EQ.258) THEN
36384C...g + q_j -> gluino + ~q_i
36385 XG2=SQM4
36386 XQ2=SQM3
36387 XMT=XG2-TH
36388 XMU=XG2-UH
36389 XST=XQ2-TH
36390 XSU=XQ2-UH
36391 FACQG1=0.5D0*4D0/9D0*XMT/SH + (XMT*SH+2D0*XG2*XST)/XMT**2 -
36392 & ( (SH-XQ2+XG2)*(-XST)-SH*XG2 )/SH/(-XMT) +
36393 & 0.5D0*1D0/2D0*( XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST) +
36394 & (-XMU)*(TH+XG2+2D0*XQ2) )/2D0/XMT/XSU
36395 FACQG2= 4D0/9D0*(-XMU)*(UH+XQ2)/XSU**2 + 1D0/18D0*
36396 & (SH*(UH+XG2)
36397 & +2D0*(XQ2-XG2)*XMU)/SH/(-XSU) + 0.5D0*4D0/9D0*XMT/SH +
36398 & 0.5D0*1D0/2D0*(XST*(TH+2D0*UH+XG2)-XMT*(SH-2D0*XST)+
36399 & (-XMU)*(TH+XG2+2D0*XQ2))/2D0/XMT/XSU
36400 ASYUK=RMSS(42)*AS
36401 FACQG1=COMFAC*AS*ASYUK*FACQG1/2D0
36402 FACQG2=COMFAC*AS*ASYUK*FACQG2/2D0
36403 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36404 DO 380 I=-KFNSQ,KFNSQ,2*KFNSQ
36405 IF(I.LT.MMINA.OR.I.GT.MMAXA) GOTO 380
36406 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 380
36407 KCHQ=2
36408 IF(I.LT.0) KCHQ=3
36409 FACSEL=RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36410 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36411 DO 370 ISDE=1,2
36412 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 370
36413 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 370
36414 NCHN=NCHN+1
36415 ISIG(NCHN,ISDE)=I
36416 ISIG(NCHN,3-ISDE)=21
36417 ISIG(NCHN,3)=1
36418 SIGH(NCHN)=FACQG1*FACSEL
36419 NCHN=NCHN+1
36420 ISIG(NCHN,ISDE)=I
36421 ISIG(NCHN,3-ISDE)=21
36422 ISIG(NCHN,3)=2
36423 SIGH(NCHN)=FACQG2*FACSEL
36424 370 CONTINUE
36425 380 CONTINUE
36426 ENDIF
36427
36428 ELSEIF(ISUB.LE.270) THEN
36429 IF(ISUB.EQ.261) THEN
36430C...q_i + q_ibar -> ~t_1 + ~t_1bar
36431 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )*
36432 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36433 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36434 FAC0=AS**2*4D0/9D0
36435 DO 390 I=MMIN1,MMAX1
36436 IA=IABS(I)
36437 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 390
36438 IF(IA.GE.11.AND.IA.LE.18) THEN
36439 EI=KCHG(IA,1)/3D0
36440 EJ=KCHG(KFNSQ,1)/3D0
36441 T3I=SIGN(1D0,EI)/2D0
36442 T3J=SIGN(1D0,EJ)/2D0
36443 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,2*ILR+1)**2
36444 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2*ILR+2)**2
36445 XLF=2D0*(T3I-EI*XW)
36446 XRF=2D0*(-EI*XW)
36447 TAA=0.5D0*(EI*EJ)**2
36448 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
36449 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
36450 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
36451 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
36452 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
36453 ENDIF
36454 NCHN=NCHN+1
36455 ISIG(NCHN,1)=I
36456 ISIG(NCHN,2)=-I
36457 ISIG(NCHN,3)=1
36458 SIGH(NCHN)=FACQQ1*FAC0
36459 390 CONTINUE
36460
36461 ELSEIF(ISUB.EQ.263) THEN
36462C...f + fbar -> ~t1 + ~t2bar
36463 DO 400 I=MMIN1,MMAX1
36464 IA=IABS(I)
36465 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
36466 EI=KCHG(IABS(I),1)/3D0
36467 TT3I=SIGN(1D0,EI)/2D0
36468 EJ=2D0/3D0
36469 TT3J=1D0/2D0
36470 FCOL=1D0
36471C...Color factor for e+ e-
36472 IF(IA.GE.11) FCOL=3D0
36473 XLQ=2D0*(TT3J-EJ*XW)
36474 XRQ=2D0*(-EJ*XW)
36475 XLF=2D0*(TT3I-EI*XW)
36476 XRF=2D0*(-EI*XW)
36477 TZZ=(XLF**2+XRF**2)*(XLQ-XRQ)**2/64D0/XW**2/XW1**2
36478 TZZ=TZZ*(SFMIX(6,1)*SFMIX(6,2))**2
36479 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
36480C...Factor of 2 for t1 t2bar + t2 t1bar
36481C...PS: bug fix 24 Aug 2010. Factor 2 accounted for by the 2 channels.
36482 FACQQ1=COMFAC*AEM**2*TZZ*FCOL*4D0
36483 FACQQ1=FACQQ1*( UH*TH-SQM3*SQM4 )/SH2
36484 NCHN=NCHN+1
36485 ISIG(NCHN,1)=I
36486 ISIG(NCHN,2)=-I
36487 ISIG(NCHN,3)=1
36488 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),2)*
36489 & WIDS(PYCOMP(KFPR(ISUBSV,2)),3)
36490 NCHN=NCHN+1
36491 ISIG(NCHN,1)=I
36492 ISIG(NCHN,2)=-I
36493 ISIG(NCHN,3)=2
36494 SIGH(NCHN)=FACQQ1*WIDS(PYCOMP(KFPR(ISUBSV,1)),3)*
36495 & WIDS(PYCOMP(KFPR(ISUBSV,2)),2)
36496 400 CONTINUE
36497
36498 ELSEIF(ISUB.EQ.264) THEN
36499C...g + g -> ~t_1 + ~t_1bar
36500 XSU=SQM3-UH
36501 XST=SQM3-TH
36502 FAC0=COMFAC*AS**2*(7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )*0.5D0*
36503 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36504 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
36505 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
36506 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 410
36507 NCHN=NCHN+1
36508 ISIG(NCHN,1)=21
36509 ISIG(NCHN,2)=21
36510 ISIG(NCHN,3)=1
36511 SIGH(NCHN)=FACQQ1
36512 NCHN=NCHN+1
36513 ISIG(NCHN,1)=21
36514 ISIG(NCHN,2)=21
36515 ISIG(NCHN,3)=2
36516 SIGH(NCHN)=FACQQ2
36517 410 CONTINUE
36518 ENDIF
36519
36520 ELSEIF(ISUB.LE.280) THEN
36521 IF(ISUB.EQ.271) THEN
36522C...q + q' -> ~q + ~q' (~g exchange)
36523 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
36524 XMT=XMG2-TH
36525 XMU=XMG2-UH
36526 XSU1=SQM3-UH
36527 XSU2=SQM4-UH
36528 XST1=SQM3-TH
36529 XST2=SQM4-TH
36530 ASYUK=RMSS(42)*AS
36531 IF(ILR.EQ.1) THEN
36532 FACQQ1=COMFAC*ASYUK**2*4D0/9D0*( -(XST1*XST2+SH*TH)/XMT**2 )
36533 FACQQ2=COMFAC*ASYUK**2*4D0/9D0*( -(XSU1*XSU2+SH*UH)/XMU**2 )
36534 FACQQB=0.0D0
36535 ELSE
36536 FACQQ1=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMT**2 )
36537 FACQQ2=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( SH*XMG2/XMU**2 )
36538 FACQQB=0.5D0*COMFAC*ASYUK**2*4D0/9D0*( -2D0*SH*XMG2/3D0/
36539 & XMT/XMU )
36540 ENDIF
36541 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
36542 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
36543 DO 430 I=-KFNSQI,KFNSQI,2*KFNSQI
36544 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 430
36545 IA=IABS(I)
36546 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
36547 KCHQ=2
36548 IF(I.LT.0) KCHQ=3
36549 DO 420 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
36550 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 420
36551 JA=IABS(J)
36552 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
36553 IF(I*J.LT.0) GOTO 420
36554 NCHN=NCHN+1
36555 ISIG(NCHN,1)=I
36556 ISIG(NCHN,2)=J
36557 ISIG(NCHN,3)=1
36558 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36559 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
36560 IF(I.EQ.J) THEN
36561 IF(ILR.EQ.0) THEN
36562 SIGH(NCHN)=0.5D0*(FACQQ1+0.5D0*FACQQB)*RKF*
36563 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
36564 ELSE
36565 SIGH(NCHN)=0.5D0*FACQQ1*RKF*
36566 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36567 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
36568 ENDIF
36569 NCHN=NCHN+1
36570 ISIG(NCHN,1)=I
36571 ISIG(NCHN,2)=J
36572 ISIG(NCHN,3)=2
36573 IF(ILR.EQ.0) THEN
36574 SIGH(NCHN)=0.5D0*(FACQQ2+0.5D0*FACQQB)*RKF*
36575 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ+2)
36576 ELSE
36577 SIGH(NCHN)=0.5D0*FACQQ2*RKF*
36578 & WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36579 & WIDS(PYCOMP(KFPR(ISUBSV,2)),KCHQ)
36580 ENDIF
36581 ENDIF
36582 420 CONTINUE
36583 430 CONTINUE
36584
36585 ELSEIF(ISUB.EQ.274) THEN
36586C...q + qbar' -> ~q + ~qbar'
36587 XMG2=PMAS(PYCOMP(KSUSY1+21),1)**2
36588 XMT=XMG2-TH
36589 XMU=XMG2-UH
36590 IF(ILR.EQ.0) THEN
36591C...Mrenna...Normalization.and.1/XMT
36592 FACQQ1=COMFAC*AS**2*2D0/9D0*(
36593 & (UH*TH-SQM3*SQM4)/XMT**2 )*RMSS(42)**2
36594 FACQQB=COMFAC*AS**2*4D0/9D0*(
36595 & (UH*TH-SQM3*SQM4)/SH2 )
36596 FACQQI=-COMFAC*AS**2*4D0/27D0*(
36597 & (UH*TH-SQM3*SQM4)/SH/XMT )*RMSS(42)
36598 FACQQB=FACQQB+FACQQ1+FACQQI
36599 ELSE
36600 FACQQ1=COMFAC*AS**2*4D0/9D0*( XMG2*SH/XMT**2 )*RMSS(42)**2
36601 FACQQB=FACQQ1
36602 ENDIF
36603 KFNSQI=MOD(KFPR(ISUBSV,1),KSUSY1)
36604 KFNSQJ=MOD(KFPR(ISUBSV,2),KSUSY1)
36605 DO 450 I=-KFNSQI,KFNSQI,2*KFNSQI
36606 IF(I.LT.MMIN1.OR.I.GT.MMAX1) GOTO 450
36607 IA=IABS(I)
36608 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 450
36609 KCHQ=2
36610 IF(I.LT.0) KCHQ=3
36611 DO 440 J=-KFNSQJ,KFNSQJ,2*KFNSQJ
36612 IF(J.LT.MMIN2.OR.J.GT.MMAX2) GOTO 440
36613 JA=IABS(J)
36614 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 440
36615 IF(I*J.GT.0) GOTO 440
36616 NCHN=NCHN+1
36617 ISIG(NCHN,1)=I
36618 ISIG(NCHN,2)=J
36619 ISIG(NCHN,3)=1
36620 SIGH(NCHN)=FACQQ1*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),KCHQ)*
36621 & WIDS(PYCOMP(KFPR(ISUBSV,2)),5-KCHQ)
36622 IF(ILR.EQ.0.AND.I.EQ.-J) SIGH(NCHN)=FACQQB*RKF*
36623 & WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36624 440 CONTINUE
36625 450 CONTINUE
36626
36627 ELSEIF(ISUB.EQ.277) THEN
36628C...q_i + q_ibar -> ~q_j + ~q_jbar ,i .ne. j
36629C...if i .eq. j covered in 274
36630 FACQQ1=COMFAC*( (UH*TH-SQM3*SQM4)/ SH**2 )
36631 KFNSQ=MOD(KFPR(ISUBSV,1),KSUSY1)
36632 FAC0=0D0
36633 DO 460 I=MMIN1,MMAX1
36634 IA=IABS(I)
36635 IF(I.EQ.0.OR.(IA.GT.MSTP(58).AND.IA.LE.10).OR.
36636 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
36637 IF(IA.EQ.KFNSQ) GOTO 460
36638 IF(IA.EQ.11.OR.IA.EQ.13.OR.IA.EQ.15) THEN
36639 EI=KCHG(IA,1)/3D0
36640 EJ=KCHG(KFNSQ,1)/3D0
36641 T3J=SIGN(0.5D0,EJ)
36642 T3I=SIGN(1D0,EI)/2D0
36643 IF(ILR.EQ.0) THEN
36644 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,1)
36645 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,2)
36646 ELSE
36647 XLQ=2D0*(T3J-EJ*XW)*SFMIX(KFNSQ,3)
36648 XRQ=2D0*(-EJ*XW)*SFMIX(KFNSQ,4)
36649 ENDIF
36650 XLF=2D0*(T3I-EI*XW)
36651 XRF=2D0*(-EI*XW)
36652 IF(ILR.EQ.0) THEN
36653 XRQ=0D0
36654 ELSE
36655 XLQ=0D0
36656 ENDIF
36657 TAA=0.5D0*(EI*EJ)**2
36658 TZZ=(XLF**2+XRF**2)*(XLQ+XRQ)**2/64D0/XW**2/XW1**2
36659 TZZ=TZZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)
36660 TAZ=EI*EJ*(XLQ+XRQ)*(XLF+XRF)/8D0/XW/XW1
36661 TAZ=TAZ/((1D0-SQMZ/SH)**2+SQMZ*(ZWID/SH)**2)*(1D0-SQMZ/SH)
36662 FAC0=AEM**2*12D0*(TAA+TZZ+TAZ)
36663 ELSEIF(IA.LE.6) THEN
36664 FAC0=AS**2*8D0/9D0/2D0
36665 ENDIF
36666 NCHN=NCHN+1
36667 ISIG(NCHN,1)=I
36668 ISIG(NCHN,2)=-I
36669 ISIG(NCHN,3)=1
36670 SIGH(NCHN)=FACQQ1*FAC0*RKF*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36671 460 CONTINUE
36672
36673 ELSEIF(ISUB.EQ.279) THEN
36674C...g + g -> ~q_j + ~q_jbar
36675 XSU=SQM3-UH
36676 XST=SQM3-TH
36677C...4=RKF because ~t ~tbar and ~b ~bbar treated separately
36678 FAC0=RKF*COMFAC*AS**2*( 7D0/48D0+3D0*(UH-TH)**2/16D0/SH2 )
36679 FACQQ1=FAC0*(0.5D0+2D0*SQM3*TH/XST**2 + 2D0*SQM3**2/XSU/XST)
36680 FACQQ2=FAC0*(0.5D0+2D0*SQM3*UH/XSU**2 + 2D0*SQM3**2/XSU/XST)
36681 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 470
36682 NCHN=NCHN+1
36683 ISIG(NCHN,1)=21
36684 ISIG(NCHN,2)=21
36685 ISIG(NCHN,3)=1
36686 SIGH(NCHN)=FACQQ1/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36687 NCHN=NCHN+1
36688 ISIG(NCHN,1)=21
36689 ISIG(NCHN,2)=21
36690 ISIG(NCHN,3)=2
36691 SIGH(NCHN)=FACQQ2/2D0*WIDS(PYCOMP(KFPR(ISUBSV,1)),1)
36692 470 CONTINUE
36693
36694 ENDIF
36695 ENDIF
36696CMRENNA--
36697
36698 RETURN
36699 END
36700
36701C*********************************************************************
36702
36703C...PYSGTC
36704C...Subprocess cross sections for Technicolor processes.
36705C...Auxiliary to PYSIGH.
36706
36707 SUBROUTINE PYSGTC(NCHN,SIGS)
36708
36709C...Double precision and integer declarations
36710 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
36711 IMPLICIT INTEGER(I-N)
36712 INTEGER PYK,PYCHGE,PYCOMP
36713C...Parameter statement to help give large particle numbers.
36714 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
36715 &KEXCIT=4000000,KDIMEN=5000000)
36716C...Commonblocks
36717 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
36718 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
36719 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
36720 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
36721 COMMON/PYINT1/MINT(400),VINT(400)
36722 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
36723 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
36724 COMMON/PYINT4/MWID(500),WIDS(500,5)
36725 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
36726 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
36727 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
36728 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
36729 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
36730 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
36731 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
36732C...Local arrays and complex variables
36733 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
36734 COMPLEX*16 SSMZ,SSMR,SSMO,DETD,F2L,F2R,DARHO,DZRHO,DAOME,DZOME
36735 COMPLEX*16 SSMX,DAAST,DZAST,DWAST
36736 COMPLEX*16 DAA,DZZ,DAZ,DWW,DWRHO
36737 COMPLEX*16 ZTC(6,6),YTC(6,6),DGGS,DGGT,DGGU,DGVS,DGVT,DGVU
36738 COMPLEX*16 DQQS,DQQT,DQQU,DQTS,DQGS,DTGS
36739 COMPLEX*16 DVVS,DVVT,DVVU
36740 INTEGER INDX(6)
36741
36742C...Combinations of weak mixing angle.
36743 TANW=SQRT(XW/XW1)
36744 CT2W=(1D0-2D0*XW)/(2D0*XW/TANW)
36745
36746C...Convert almost equivalent technicolor processes into
36747C...a few basic processes, and set distinguishing parameters.
36748 IF(ISUB.GE.361.AND.ISUB.LE.380) THEN
36749 SQTV=RTCM(12)**2
36750 SQTA=RTCM(13)**2
36751 SN2W=2D0*SQRT(XW*XW1)
36752 CS2W=1D0-2D0*XW
36753 CT2W=CS2W/SN2W
36754 CSXI=COS(ASIN(RTCM(3)))
36755 CSXIP=COS(ASIN(RTCM(4)))
36756 QUPD=2D0*RTCM(2)-1D0
36757 Q2UD=RTCM(2)**2+(RTCM(2)-1D0)**2
36758 CAB2=0D0
36759 VOGP=0D0
36760 VRGP=0D0
36761 AOGP=0D0
36762 ARGP=0D0
36763 VXGP=0D0
36764 AXGP=0D0
36765 VAGP=0D0
36766 VZGP=0D0
36767 VWGP=0D0
36768C... rho_tc0, etc. -> W_L W_L, W_L W_T
36769 IF(ISUB.EQ.361) THEN
36770 KFA=24
36771 KFB=24
36772 CAB2=RTCM(3)**4
36773 AXGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36774 ARGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36775 VOGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(12)
36776C...Multiply by sqrt(2) to account for W^+_T W^-_L + W^+_L W^-_T.
36777 AXGP = SQRT(2D0)*AXGP
36778 ARGP = SQRT(2D0)*ARGP
36779 VOGP = SQRT(2D0)*VOGP
36780C... rho_tc0 -> W_L pi_tc-
36781 ELSEIF(ISUB.EQ.362) THEN
36782 KFA=24
36783 KFB=KTECHN+211
36784 ISUB=361
36785 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36786C... pi_tc pi_tc
36787 ELSEIF(ISUB.EQ.363) THEN
36788 KFA=KTECHN+211
36789 KFB=KTECHN+211
36790 ISUB=361
36791 CAB2=(1D0-RTCM(3)**2)**2
36792C... rho_tc0/omega_tc -> gamma pi_tc
36793 ELSEIF(ISUB.EQ.364) THEN
36794 KFA=22
36795 KFB=KTECHN+111
36796 ISUB=361
36797 VOGP=CSXI/RTCM(12)
36798 VRGP=VOGP*QUPD
36799 VAGP=2D0*QUPD*CSXI
36800 VZGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36801C... gamma pi_tc'
36802 ELSEIF(ISUB.EQ.365) THEN
36803 KFA=22
36804 KFB=KTECHN+221
36805 ISUB=361
36806 VRGP=CSXIP/RTCM(12)
36807 VOGP=VRGP*QUPD
36808 VAGP=2D0*Q2UD*CSXIP
36809 VZGP=CSXIP/SN2W*(1D0-4D0*XW*Q2UD)
36810C... Z pi_tc
36811 ELSEIF(ISUB.EQ.366) THEN
36812 KFA=23
36813 KFB=KTECHN+111
36814 ISUB=361
36815 VOGP=CSXI*CT2W/RTCM(12)
36816 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36817 VAGP=QUPD*CSXI*(1D0-4D0*XW)/SN2W
36818 VZGP=-QUPD*CSXI*CS2W/XW1
36819C... Z pi_tc'
36820 ELSEIF(ISUB.EQ.367) THEN
36821 KFA=23
36822 KFB=KTECHN+221
36823 ISUB=361
36824C...RTCM(48) is the M_V for the techni-a
36825 VXGP=-CSXIP/SN2W/RTCM(48)
36826 VRGP=CSXIP*CT2W/RTCM(12)
36827 VOGP=-QUPD*CSXIP*TANW/RTCM(12)
36828 VAGP=CSXIP*(1D0-4D0*Q2UD*XW)/SN2W
36829 VZGP=2D0*CSXIP*(CS2W+4D0*Q2UD*XW**2)/SN2W**2
36830C... W_T pi_tc
36831 ELSEIF(ISUB.EQ.368) THEN
36832 KFA=24
36833 KFB=KTECHN+211
36834 ISUB=361
36835C...RTCM(49) is the M_A for the techni-a
36836 AXGP=-CSXI/(2D0*SQRT(XW))/RTCM(49)
36837 VOGP=CSXI/(2D0*SQRT(XW))/RTCM(12)
36838 ARGP=CSXI/(2D0*SQRT(XW))/RTCM(13)
36839 VAGP=QUPD*CSXI/(2D0*SQRT(XW))
36840 VZGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36841C... rho_tc+, a_T+ -> W_L Z_L, W_T Z_L
36842 ELSEIF(ISUB.EQ.370) THEN
36843 KFA=24
36844 KFB=23
36845 CAB2=RTCM(3)**4
36846 ARGP=-RTCM(3)/(2D0*SQRT(XW))/RTCM(13)
36847 AXGP=RTCM(3)/(2D0*SQRT(XW))/RTCM(49)
36848C... W_L pi_tc0
36849 ELSEIF(ISUB.EQ.371) THEN
36850 KFA=24
36851 KFB=KTECHN+111
36852 ISUB=370
36853 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36854C... Z_L pi_tc+
36855 ELSEIF(ISUB.EQ.372) THEN
36856 KFA=KTECHN+211
36857 KFB=23
36858 ISUB=370
36859 CAB2=RTCM(3)**2*(1D0-RTCM(3)**2)
36860C... pi_tc+ pi_tc0
36861 ELSEIF(ISUB.EQ.373) THEN
36862 KFA=KTECHN+211
36863 KFB=KTECHN+111
36864 ISUB=370
36865 CAB2=(1D0-RTCM(3)**2)**2
36866C... gamma pi_tc+
36867 ELSEIF(ISUB.EQ.374) THEN
36868 KFA=KTECHN+211
36869 KFB=22
36870 ISUB=370
36871 VRGP=QUPD*CSXI/RTCM(12)
36872 VWGP=QUPD*CSXI/(2D0*SQRT(XW))
36873 AXGP=-CSXI/RTCM(49)
36874C... Z_T pi_tc+
36875 ELSEIF(ISUB.EQ.375) THEN
36876 KFA=KTECHN+211
36877 KFB=23
36878 ISUB=370
36879 VRGP=-QUPD*CSXI*TANW/RTCM(12)
36880 ARGP=CSXI/(2D0*SQRT(XW*XW1))/RTCM(13)
36881 VWGP=-QUPD*CSXI/(2D0*SQRT(XW1))
36882 AXGP=-CSXI*CT2W/RTCM(49)
36883C... W_T pi_tc0
36884 ELSEIF(ISUB.EQ.376) THEN
36885 KFA=24
36886 KFB=KTECHN+111
36887 ISUB=370
36888 VRGP=0D0
36889 ARGP=-CSXI/(2D0*SQRT(XW))/RTCM(13)
36890 AXGP=CSXI/(2D0*SQRT(XW))/RTCM(49)
36891C... W_T pi_tc0'
36892 ELSEIF(ISUB.EQ.377) THEN
36893 KFA=24
36894 KFB=KTECHN+221
36895 ISUB=370
36896 VRGP=CSXIP/(2D0*SQRT(XW))/RTCM(12)
36897 VWGP=CSXIP/(2D0*XW)
36898 VXGP=-CSXIP/(2D0*SQRT(XW))/RTCM(48)
36899C... gamma W+
36900 ELSEIF(ISUB.EQ.378) THEN
36901 KFA=24
36902 KFB=22
36903 ISUB=370
36904 VRGP=QUPD*RTCM(3)/RTCM(12)
36905 AXGP=-RTCM(3)/RTCM(49)
36906C... gamma Z
36907 ELSEIF(ISUB.EQ.379) THEN
36908 KFA=23
36909 KFB=22
36910 ISUB=361
36911 VOGP=RTCM(3)/RTCM(12)
36912 VRGP=QUPD*RTCM(3)/RTCM(12)
36913 ELSEIF(ISUB.EQ.380) THEN
36914 KFA=23
36915 KFB=23
36916 ISUB=361
36917 VOGP=RTCM(3)*CT2W/RTCM(12)
36918 VRGP=-QUPD*RTCM(3)*TANW/RTCM(12)
36919 ENDIF
36920 ENDIF
36921
36922C...QCD 2 -> 2 processes: corrections from virtual technicolor exchange.
36923 IF(ISUB.GE.381.AND.ISUB.LE.388) THEN
36924 IF(ITCM(5).LE.4) THEN
36925 SQDQQS=1D0/SH2
36926 SQDQQT=1D0/TH2
36927 SQDQQU=1D0/UH2
36928 SQDGGS=SQDQQS
36929 SQDGGT=SQDQQT
36930 SQDGGU=SQDQQU
36931 REDGGS=1D0/SH
36932 REDGGT=1D0/TH
36933 REDGGU=1D0/UH
36934 REDGTU=1D0/UH/TH
36935 REDGSU=1D0/SH/UH
36936 REDGST=1D0/SH/TH
36937 REDQST=1D0/SH/TH
36938 REDQTU=1D0/UH/TH
36939 SQDLGS=0D0
36940 SQDLGT=0D0
36941 SQDQTS=SQDQQS
36942 ELSEIF(ITCM(5).EQ.5) THEN
36943 TANT3=RTCM(21)
36944 IF(ITCM(2).EQ.0) THEN
36945 IMDL=1
36946 ELSE
36947 IMDL=2
36948 ENDIF
36949 ALPRHT=2.16D0*(3D0/ITCM(1))
36950 SIN2T=2D0*TANT3/(TANT3**2+1D0)
36951 SINT3=TANT3/SQRT(TANT3**2+1D0)
36952 XIG=SQRT(PYALPS(SH)/ALPRHT)
36953 X12=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*COS(RTCM(30))+
36954 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*COS(RTCM(32)))/SQRT(2D0)/SIN2T
36955 X21=(RTCM(29)*SQRT(1D0-RTCM(29)**2)*SIN(RTCM(30))+
36956 & RTCM(31)*SQRT(1D0-RTCM(31)**2)*SIN(RTCM(32)))/SQRT(2D0)/SIN2T
36957 X11=(.25D0*(RTCM(29)**2+RTCM(31)**2+2D0)-
36958 & SINT3**2)*2D0/SIN2T
36959 X22=(.25D0*(2D0-RTCM(29)**2-RTCM(31)**2)-
36960 & SINT3**2)*2D0/SIN2T
36961
36962 SM1122=.5D0*(2D0-RTCM(29)**2-RTCM(31)**2)*RTCM(28)**2
36963 SM1112=X12*RTCM(28)**2*SIN2T
36964 SM1121=-X21*RTCM(28)**2*SIN2T
36965 SM2212=-SM1112
36966 SM2221=-SM1121
36967 SM1221=-.5D0*((1D0-RTCM(29)**2)*SIN(2D0*RTCM(30))+
36968 & (1D0-RTCM(31)**2)*SIN(2D0*RTCM(32)))*RTCM(28)**2
36969
36970C.........SH LOOP
36971 ZTC(1,1)=DCMPLX(SH,0D0)
36972 CALL PYWIDT(3100021,SH,WDTP,WDTE)
36973 IF(WDTP(0).GT.RTCM(33)*SHR) WDTP(0)=RTCM(33)*SHR
36974 ZTC(2,2)=DCMPLX(SH-PMAS(PYCOMP(3100021),1)**2,-SHR*WDTP(0))
36975 CALL PYWIDT(3100113,SH,WDTP,WDTE)
36976 ZTC(3,3)=DCMPLX(SH-PMAS(PYCOMP(3100113),1)**2,-SHR*WDTP(0))
36977 CALL PYWIDT(3400113,SH,WDTP,WDTE)
36978 ZTC(4,4)=DCMPLX(SH-PMAS(PYCOMP(3400113),1)**2,-SHR*WDTP(0))
36979 CALL PYWIDT(3200113,SH,WDTP,WDTE)
36980 ZTC(5,5)=DCMPLX(SH-PMAS(PYCOMP(3200113),1)**2,-SHR*WDTP(0))
36981 CALL PYWIDT(3300113,SH,WDTP,WDTE)
36982 ZTC(6,6)=DCMPLX(SH-PMAS(PYCOMP(3300113),1)**2,-SHR*WDTP(0))
36983 ZTC(1,2)=(0D0,0D0)
36984 ZTC(1,3)=DCMPLX(SH*XIG,0D0)
36985 ZTC(1,4)=ZTC(1,3)
36986 ZTC(1,5)=ZTC(1,2)
36987 ZTC(1,6)=ZTC(1,2)
36988 ZTC(2,3)=DCMPLX(SH*XIG*X11,0D0)
36989 ZTC(2,4)=DCMPLX(SH*XIG*X22,0D0)
36990 ZTC(2,5)=DCMPLX(SH*XIG*X12,0D0)
36991 ZTC(2,6)=DCMPLX(SH*XIG*X21,0D0)
36992 ZTC(3,4)=-SM1122
36993 ZTC(3,5)=-SM1112
36994 ZTC(3,6)=-SM1121
36995 ZTC(4,5)=-SM2212
36996 ZTC(4,6)=-SM2221
36997 ZTC(5,6)=-SM1221
36998
36999 DO 110 I=1,5
37000 DO 100 J=I+1,6
37001 ZTC(J,I)=ZTC(I,J)
37002 100 CONTINUE
37003 110 CONTINUE
37004 CALL PYLDCM(ZTC,6,6,INDX,D)
37005 DO 130 I=1,6
37006 DO 120 J=1,6
37007 YTC(I,J)=(0D0,0D0)
37008 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
37009 120 CONTINUE
37010 130 CONTINUE
37011
37012 DO 140 I=1,6
37013 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
37014 140 CONTINUE
37015 DGGS=YTC(1,1)
37016 DVVS=YTC(2,2)
37017 DGVS=YTC(1,2)
37018
37019 XIG=SQRT(PYALPS(-TH)/ALPRHT)
37020C.........TH LOOP
37021 ZTC(1,1)=DCMPLX(TH)
37022 ZTC(2,2)=DCMPLX(TH-PMAS(PYCOMP(3100021),1)**2)
37023 ZTC(3,3)=DCMPLX(TH-PMAS(PYCOMP(3100113),1)**2)
37024 ZTC(4,4)=DCMPLX(TH-PMAS(PYCOMP(3400113),1)**2)
37025 ZTC(5,5)=DCMPLX(TH-PMAS(PYCOMP(3200113),1)**2)
37026 ZTC(6,6)=DCMPLX(TH-PMAS(PYCOMP(3300113),1)**2)
37027 ZTC(1,2)=(0D0,0D0)
37028 ZTC(1,3)=DCMPLX(TH*XIG,0D0)
37029 ZTC(1,4)=ZTC(1,3)
37030 ZTC(1,5)=ZTC(1,2)
37031 ZTC(1,6)=ZTC(1,2)
37032 ZTC(2,3)=DCMPLX(TH*XIG*X11,0D0)
37033 ZTC(2,4)=DCMPLX(TH*XIG*X22,0D0)
37034 ZTC(2,5)=DCMPLX(TH*XIG*X12,0D0)
37035 ZTC(2,6)=DCMPLX(TH*XIG*X21,0D0)
37036 ZTC(3,4)=-SM1122
37037 ZTC(3,5)=-SM1112
37038 ZTC(3,6)=-SM1121
37039 ZTC(4,5)=-SM2212
37040 ZTC(4,6)=-SM2221
37041 ZTC(5,6)=-SM1221
37042 DO 160 I=1,5
37043 DO 150 J=I+1,6
37044 ZTC(J,I)=ZTC(I,J)
37045 150 CONTINUE
37046 160 CONTINUE
37047 CALL PYLDCM(ZTC,6,6,INDX,D)
37048 DO 180 I=1,6
37049 DO 170 J=1,6
37050 YTC(I,J)=(0D0,0D0)
37051 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
37052 170 CONTINUE
37053 180 CONTINUE
37054 DO 190 I=1,6
37055 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
37056 190 CONTINUE
37057 DGGT=YTC(1,1)
37058 DVVT=YTC(2,2)
37059 DGVT=YTC(1,2)
37060
37061 XIG=SQRT(PYALPS(-UH)/ALPRHT)
37062C.........UH LOOP
37063 ZTC(1,1)=DCMPLX(UH,0D0)
37064 ZTC(2,2)=DCMPLX(UH-PMAS(PYCOMP(3100021),1)**2)
37065 ZTC(3,3)=DCMPLX(UH-PMAS(PYCOMP(3100113),1)**2)
37066 ZTC(4,4)=DCMPLX(UH-PMAS(PYCOMP(3400113),1)**2)
37067 ZTC(5,5)=DCMPLX(UH-PMAS(PYCOMP(3200113),1)**2)
37068 ZTC(6,6)=DCMPLX(UH-PMAS(PYCOMP(3300113),1)**2)
37069 ZTC(1,2)=(0D0,0D0)
37070 ZTC(1,3)=DCMPLX(UH*XIG,0D0)
37071 ZTC(1,4)=ZTC(1,3)
37072 ZTC(1,5)=ZTC(1,2)
37073 ZTC(1,6)=ZTC(1,2)
37074 ZTC(2,3)=DCMPLX(UH*XIG*X11,0D0)
37075 ZTC(2,4)=DCMPLX(UH*XIG*X22,0D0)
37076 ZTC(2,5)=DCMPLX(UH*XIG*X12,0D0)
37077 ZTC(2,6)=DCMPLX(UH*XIG*X21,0D0)
37078 ZTC(3,4)=-SM1122
37079 ZTC(3,5)=-SM1112
37080 ZTC(3,6)=-SM1121
37081 ZTC(4,5)=-SM2212
37082 ZTC(4,6)=-SM2221
37083 ZTC(5,6)=-SM1221
37084 DO 210 I=1,5
37085 DO 200 J=I+1,6
37086 ZTC(J,I)=ZTC(I,J)
37087 200 CONTINUE
37088 210 CONTINUE
37089 CALL PYLDCM(ZTC,6,6,INDX,D)
37090 DO 230 I=1,6
37091 DO 220 J=1,6
37092 YTC(I,J)=(0D0,0D0)
37093 IF(I.EQ.J) YTC(I,J)=(1D0,0D0)
37094 220 CONTINUE
37095 230 CONTINUE
37096 DO 240 I=1,6
37097 CALL PYBKSB(ZTC,6,6,INDX,YTC(1,I))
37098 240 CONTINUE
37099 DGGU=YTC(1,1)
37100 DVVU=YTC(2,2)
37101 DGVU=YTC(1,2)
37102
37103 IF(IMDL.EQ.1) THEN
37104 DQQS=DGGS+DVVS*DCMPLX(TANT3**2)-DGVS*DCMPLX(2D0*TANT3)
37105 DQQT=DGGT+DVVT*DCMPLX(TANT3**2)-DGVT*DCMPLX(2D0*TANT3)
37106 DQQU=DGGU+DVVU*DCMPLX(TANT3**2)-DGVU*DCMPLX(2D0*TANT3)
37107 DQTS=DGGS-DVVS-DGVS*DCMPLX(TANT3-1D0/TANT3)
37108 DQGS=DGGS-DGVS*DCMPLX(TANT3)
37109 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
37110 ELSE
37111 DQQS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
37112 DQQT=DGGT+DVVT*DCMPLX(1D0/TANT3**2)+DGVT*DCMPLX(2D0/TANT3)
37113 DQQU=DGGU+DVVU*DCMPLX(1D0/TANT3**2)+DGVU*DCMPLX(2D0/TANT3)
37114 DQTS=DGGS+DVVS*DCMPLX(1D0/TANT3**2)+DGVS*DCMPLX(2D0/TANT3)
37115 DQGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
37116 DTGS=DGGS+DGVS*DCMPLX(1D0/TANT3)
37117 ENDIF
37118
37119 SQDQTS=ABS(DQTS)**2
37120 SQDQQS=ABS(DQQS)**2
37121 SQDQQT=ABS(DQQT)**2
37122 SQDQQU=ABS(DQQU)**2
37123 SQDLGS=ABS(DCMPLX(SH)*DQGS-DCMPLX(1D0))**2
37124 REDLGS=DBLE(DQGS)
37125 SQDHGS=ABS(DCMPLX(SH)*DTGS-DCMPLX(1D0))**2
37126 REDHGS=DBLE(DTGS)
37127 SQDLGT=ABS(DCMPLX(TH)*DGGT-DCMPLX(1D0))**2
37128
37129 SQDGGS=ABS(DGGS)**2
37130 SQDGGT=ABS(DGGT)**2
37131 SQDGGU=ABS(DGGU)**2
37132 REDGGS=DBLE(DGGS)
37133 REDGGT=DBLE(DGGT)
37134 REDGGU=DBLE(DGGU)
37135 REDGTU=DBLE(DGGU*DCONJG(DGGT))
37136 REDGSU=DBLE(DGGU*DCONJG(DGGS))
37137 REDGST=DBLE(DGGS*DCONJG(DGGT))
37138 REDQST=DBLE(DQQS*DCONJG(DQQT))
37139 REDQTU=DBLE(DQQT*DCONJG(DQQU))
37140 ENDIF
37141 ENDIF
37142
37143
37144C...Differential cross section expressions.
37145
37146 IF(ISUB.LE.190) THEN
37147 IF(ISUB.EQ.149) THEN
37148C...g + g -> eta_tc
37149 KCTC=PYCOMP(KTECHN+331)
37150 CALL PYWIDT(KTECHN+331,SH,WDTP,WDTE)
37151 HS=SHR*WDTP(0)
37152 FACBW=COMFAC*0.5D0/((SH-PMAS(KCTC,1)**2)**2+HS**2)
37153 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37154 HP=SH
37155 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 250
37156 HI=HP*WDTP(3)
37157 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37158 NCHN=NCHN+1
37159 ISIG(NCHN,1)=21
37160 ISIG(NCHN,2)=21
37161 ISIG(NCHN,3)=1
37162 SIGH(NCHN)=HI*FACBW*HF
37163 250 CONTINUE
37164
37165 ELSEIF(ISUB.EQ.165) THEN
37166C...q + qbar -> l+ + l- (including contact term for compositeness)
37167 ZRATR=XWC*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
37168 ZRATI=XWC*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
37169 KFF=IABS(KFPR(ISUB,1))
37170 EF=KCHG(KFF,1)/3D0
37171 AF=SIGN(1D0,EF+0.1D0)
37172 VF=AF-4D0*EF*XWV
37173 VALF=VF+AF
37174 VARF=VF-AF
37175 FCOF=1D0
37176 IF(KFF.LE.10) FCOF=3D0
37177 WID2=1D0
37178 IF(KFF.EQ.6) WID2=WIDS(6,1)
37179 IF(KFF.EQ.7.OR.KFF.EQ.8) WID2=WIDS(KFF,1)
37180 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
37181 DO 260 I=MMINA,MMAXA
37182 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 260
37183 EI=KCHG(IABS(I),1)/3D0
37184 AI=SIGN(1D0,EI+0.1D0)
37185 VI=AI-4D0*EI*XWV
37186 VALI=VI+AI
37187 VARI=VI-AI
37188 FCOI=1D0
37189 IF(IABS(I).LE.10) FCOI=FACA/3D0
37190 IF((ITCM(5).EQ.1.AND.IABS(I).LE.2).OR.ITCM(5).EQ.2) THEN
37191 FGZA=(EI*EF+VALI*VALF*ZRATR+RTCM(42)*SH/
37192 & (AEM*RTCM(41)**2))**2+(VALI*VALF*ZRATI)**2+
37193 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
37194 ELSE
37195 FGZA=(EI*EF+VALI*VALF*ZRATR)**2+(VALI*VALF*ZRATI)**2+
37196 & (EI*EF+VARI*VARF*ZRATR)**2+(VARI*VARF*ZRATI)**2
37197 ENDIF
37198 FGZB=(EI*EF+VALI*VARF*ZRATR)**2+(VALI*VARF*ZRATI)**2+
37199 & (EI*EF+VARI*VALF*ZRATR)**2+(VARI*VALF*ZRATI)**2
37200 FGZAB=AEM**2*(FGZA*UH2/SH2+FGZB*TH2/SH2)
37201 IF((ITCM(5).EQ.3.AND.IABS(I).EQ.2).OR.(ITCM(5).EQ.4.AND.
37202 & MOD(IABS(I),2).EQ.0)) FGZAB=FGZAB+SH2/(2D0*RTCM(41)**4)
37203 NCHN=NCHN+1
37204 ISIG(NCHN,1)=I
37205 ISIG(NCHN,2)=-I
37206 ISIG(NCHN,3)=1
37207 SIGH(NCHN)=COMFAC*FCOI*FCOF*FGZAB*WID2
37208 260 CONTINUE
37209
37210 ELSEIF(ISUB.EQ.166) THEN
37211C...q + q'bar -> l + nu_l (including contact term for compositeness)
37212 WFAC=(1D0/4D0)*(AEM/XW)**2*UH2/((SH-SQMW)**2+GMMW**2)
37213 WCIFAC=WFAC+SH2/(4D0*RTCM(41)**4)
37214 KFF=IABS(KFPR(ISUB,1))
37215 FCOF=1D0
37216 IF(KFF.LE.10) FCOF=3D0
37217 DO 280 I=MMIN1,MMAX1
37218 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 280
37219 IA=IABS(I)
37220 DO 270 J=MMIN2,MMAX2
37221 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 270
37222 JA=IABS(J)
37223 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 270
37224 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37225 & GOTO 270
37226 FCOI=1D0
37227 IF(IA.LE.10) FCOI=VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37228 WID2=1D0
37229 IF((I.GT.0.AND.MOD(I,2).EQ.0).OR.(J.GT.0.AND.
37230 & MOD(J,2).EQ.0)) THEN
37231 IF(KFF.EQ.5) WID2=WIDS(6,2)
37232 IF(KFF.EQ.7) WID2=WIDS(8,2)*WIDS(7,3)
37233 IF(KFF.EQ.17) WID2=WIDS(18,2)*WIDS(17,3)
37234 ELSE
37235 IF(KFF.EQ.5) WID2=WIDS(6,3)
37236 IF(KFF.EQ.7) WID2=WIDS(8,3)*WIDS(7,2)
37237 IF(KFF.EQ.17) WID2=WIDS(18,3)*WIDS(17,2)
37238 ENDIF
37239 NCHN=NCHN+1
37240 ISIG(NCHN,1)=I
37241 ISIG(NCHN,2)=J
37242 ISIG(NCHN,3)=1
37243 SIGH(NCHN)=COMFAC*FCOI*FCOF*WFAC*WID2
37244 IF((ITCM(5).EQ.3.AND.IA.LE.2.AND.JA.LE.2).OR.ITCM(5).EQ.4)
37245 & SIGH(NCHN)=COMFAC*FCOI*FCOF*WCIFAC*WID2
37246 270 CONTINUE
37247 280 CONTINUE
37248 ENDIF
37249
37250 ELSEIF(ISUB.LE.200) THEN
37251 IF(ISUB.EQ.191) THEN
37252C...q + qbar -> rho_tc0.
37253 KCTC=PYCOMP(KTECHN+113)
37254 SQMRHT=PMAS(KCTC,1)**2
37255 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
37256 HS=SHR*WDTP(0)
37257 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
37258 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37259 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37260 ALPRHT=2.16D0*(3D0/ITCM(1))
37261 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)
37262 XWRHT=(1D0-2D0*XW)/(4D0*XW*(1D0-XW))
37263 BWZR=XWRHT*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
37264 BWZI=XWRHT*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
37265 DO 290 I=MMINA,MMAXA
37266 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 290
37267 IA=IABS(I)
37268 EI=KCHG(IABS(I),1)/3D0
37269 AI=SIGN(1D0,EI+0.1D0)
37270 VI=AI-4D0*EI*XWV
37271 VALI=0.5D0*(VI+AI)
37272 VARI=0.5D0*(VI-AI)
37273 HI=HP*((EI+VALI*BWZR)**2+(VALI*BWZI)**2+
37274 & (EI+VARI*BWZR)**2+(VARI*BWZI)**2)
37275 IF(IA.LE.10) HI=HI*FACA/3D0
37276 NCHN=NCHN+1
37277 ISIG(NCHN,1)=I
37278 ISIG(NCHN,2)=-I
37279 ISIG(NCHN,3)=1
37280 SIGH(NCHN)=HI*FACBW*HF
37281 290 CONTINUE
37282
37283 ELSEIF(ISUB.EQ.192) THEN
37284C...q + qbar' -> rho_tc+/-.
37285 KCTC=PYCOMP(KTECHN+213)
37286 SQMRHT=PMAS(KCTC,1)**2
37287 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
37288 HS=SHR*WDTP(0)
37289 FACBW=12D0*COMFAC/((SH-SQMRHT)**2+HS**2)
37290 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37291 ALPRHT=2.16D0*(3D0/ITCM(1))
37292 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMRHT**2/SH)*
37293 & (0.25D0/XW**2)*SH**2/((SH-SQMW)**2+GMMW**2)
37294 DO 310 I=MMIN1,MMAX1
37295 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 310
37296 IA=IABS(I)
37297 DO 300 J=MMIN2,MMAX2
37298 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 300
37299 JA=IABS(J)
37300 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 300
37301 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37302 & GOTO 300
37303 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37304 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHR)/2)+WDTE(0,4))
37305 HI=HP
37306 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
37307 NCHN=NCHN+1
37308 ISIG(NCHN,1)=I
37309 ISIG(NCHN,2)=J
37310 ISIG(NCHN,3)=1
37311 SIGH(NCHN)=HI*FACBW*HF
37312 300 CONTINUE
37313 310 CONTINUE
37314
37315 ELSEIF(ISUB.EQ.193) THEN
37316C...q + qbar -> omega_tc0.
37317 KCTC=PYCOMP(KTECHN+223)
37318 SQMOMT=PMAS(KCTC,1)**2
37319 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
37320 HS=SHR*WDTP(0)
37321 FACBW=12D0*COMFAC/((SH-SQMOMT)**2+HS**2)
37322 IF(ABS(SHR-PMAS(KCTC,1)).GT.PARP(48)*PMAS(KCTC,2)) FACBW=0D0
37323 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37324 ALPRHT=2.16D0*(3D0/ITCM(1))
37325 HP=(1D0/6D0)*(AEM**2/ALPRHT)*(SQMOMT**2/SH)*
37326 & (2D0*RTCM(2)-1D0)**2
37327 BWZR=(0.5D0/(1D0-XW))*SH*(SH-SQMZ)/((SH-SQMZ)**2+GMMZ**2)
37328 BWZI=(0.5D0/(1D0-XW))*SH*GMMZ/((SH-SQMZ)**2+GMMZ**2)
37329 DO 320 I=MMINA,MMAXA
37330 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
37331 IA=IABS(I)
37332 EI=KCHG(IABS(I),1)/3D0
37333 AI=SIGN(1D0,EI+0.1D0)
37334 VI=AI-4D0*EI*XWV
37335 VALI=0.5D0*(VI+AI)
37336 VARI=0.5D0*(VI-AI)
37337 HI=HP*((EI-VALI*BWZR)**2+(VALI*BWZI)**2+
37338 & (EI-VARI*BWZR)**2+(VARI*BWZI)**2)
37339 IF(IA.LE.10) HI=HI*FACA/3D0
37340 NCHN=NCHN+1
37341 ISIG(NCHN,1)=I
37342 ISIG(NCHN,2)=-I
37343 ISIG(NCHN,3)=1
37344 SIGH(NCHN)=HI*FACBW*HF
37345 320 CONTINUE
37346
37347 ELSEIF(ISUB.EQ.194) THEN
37348C...f + fbar -> f' + fbar' via s-channel rho_tc, omega_tc a_T0.
37349C...Default final state is e+e-
37350 KFA=KFPR(ISUBSV,1)
37351 ALPRHT=2.16D0*(3D0/ITCM(1))
37352 HP=AEM**2*COMFAC
37353
37354 SN2W=2D0*SQRT(XW*XW1)
37355C TANW=SQRT(PARU(102)/(1D0-PARU(102)))
37356C CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
37357
37358 QUPD=2D0*RTCM(2)-1D0
37359 FAR=SQRT(AEM/ALPRHT)
37360 FAO=FAR*QUPD
37361 FZR=FAR*CT2W
37362 FZO=-FAO*TANW
37363C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37364 FZX=-FAR/SN2W*RTCM(47)
37365 SFAR=FAR**2
37366 SFAO=FAO**2
37367 SFZR=FZR**2
37368 SFZO=FZO**2
37369 SFZX=FZX**2
37370 CALL PYWIDT(23,SH,WDTP,WDTE)
37371 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
37372 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
37373 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
37374 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
37375 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
37376 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
37377 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
37378C...Propagator including a_T^0
37379 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
37380 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
37381C...Add in techni-a contribution
37382 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
37383 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
37384 $ SFZX*SSMR*SSMO)/DETD/SH
37385 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
37386 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
37387
37388 XWRHT=1D0/(4D0*XW*(1D0-XW))
37389 KFF=IABS(KFPR(ISUB,1))
37390 EF=KCHG(KFF,1)/3D0
37391 AF=SIGN(1D0,EF+0.1D0)
37392 VF=AF-4D0*EF*XWV
37393 VALF=0.5D0*(VF+AF)
37394 VARF=0.5D0*(VF-AF)
37395 FCOF=1D0
37396 IF(KFF.LE.10) FCOF=3D0
37397
37398 WID2=1D0
37399 IF(KFF.GE.6.AND.KFF.LE.8) WID2=WIDS(KFF,1)
37400 IF(KFF.EQ.17.OR.KFF.EQ.18) WID2=WIDS(KFF,1)
37401 DZZ=DZZ*DCMPLX(XWRHT,0D0)
37402 DAZ=DAZ*DCMPLX(SQRT(XWRHT),0D0)
37403
37404 DO 330 I=MMINA,MMAXA
37405 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 330
37406 EI=KCHG(IABS(I),1)/3D0
37407 AI=SIGN(1D0,EI+0.1D0)
37408 VI=AI-4D0*EI*XWV
37409 VALI=0.5D0*(VI+AI)
37410 VARI=0.5D0*(VI-AI)
37411 FCOI=FCOF
37412 IF(IABS(I).LE.10) FCOI=FCOI/3D0
37413 DIFLL=ABS(EI*EF*DAA+VALI*VALF*DZZ+DAZ*(EI*VALF+EF*VALI))**2
37414 DIFRR=ABS(EI*EF*DAA+VARI*VARF*DZZ+DAZ*(EI*VARF+EF*VARI))**2
37415 DIFLR=ABS(EI*EF*DAA+VALI*VARF*DZZ+DAZ*(EI*VARF+EF*VALI))**2
37416 DIFRL=ABS(EI*EF*DAA+VARI*VALF*DZZ+DAZ*(EI*VALF+EF*VARI))**2
37417 FACSIG=(DIFLL+DIFRR)*((UH-SQM4)**2+SH*SQM4)+
37418 & (DIFLR+DIFRL)*((TH-SQM3)**2+SH*SQM3)
37419 NCHN=NCHN+1
37420 ISIG(NCHN,1)=I
37421 ISIG(NCHN,2)=-I
37422 ISIG(NCHN,3)=1
37423 SIGH(NCHN)=HP*FCOI*FACSIG*WID2
37424 330 CONTINUE
37425
37426 ELSEIF(ISUB.EQ.195) THEN
37427C...f + fbar' -> f'' + fbar''' via s-channel rho_tc+, a_T+
37428 KFA=KFPR(ISUBSV,1)
37429 KFB=KFA+1
37430 ALPRHT=2.16D0*(3D0/ITCM(1))
37431 FACTC=COMFAC*(AEM**2/12D0/XW**2)*(UH-SQM3)*(UH-SQM4)*3D0
37432
37433 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
37434C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37435C
37436C...Propagator including a_T^+
37437 FWX=-FWR*RTCM(47)
37438 CALL PYWIDT(24,SH,WDTP,WDTE)
37439 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
37440 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
37441 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
37442 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
37443 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
37444 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
37445 & DCMPLX(FWX**2,0D0)*SSMR
37446 DWW=SSMR*SSMX/DETD/SH
37447 FCOF=1D0
37448 IF(KFA.LE.8) FCOF=3D0
37449 HP=FACTC*ABS(DWW)**2*FCOF
37450
37451 DO 350 I=MMIN1,MMAX1
37452 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 350
37453 IA=IABS(I)
37454 DO 340 J=MMIN2,MMAX2
37455 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 340
37456 JA=IABS(J)
37457 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 340
37458 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37459 & GOTO 340
37460 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37461 HI=HP
37462 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
37463 NCHN=NCHN+1
37464 ISIG(NCHN,1)=I
37465 ISIG(NCHN,2)=J
37466 ISIG(NCHN,3)=1
37467 SIGH(NCHN)=HI*WIDS(KFA,(5-KCHR)/2)*WIDS(KFB,(5+KCHR)/2)
37468 340 CONTINUE
37469 350 CONTINUE
37470 ENDIF
37471
37472 ELSEIF(ISUB.LE.380) THEN
37473 ALPRHT=2.16D0*(3D0/ITCM(1))
37474 IF(ISUB.EQ.361) THEN
37475 FAR=SQRT(AEM/ALPRHT)
37476 FAO=FAR*QUPD
37477 FZR=FAR*CT2W
37478 FZO=-FAO*TANW
37479C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37480 FZX=-FAR/SN2W*RTCM(47)
37481 SFAR=FAR**2
37482 SFAO=FAO**2
37483 SFZR=FZR**2
37484 SFZO=FZO**2
37485 SFZX=FZX**2
37486 CALL PYWIDT(23,SH,WDTP,WDTE)
37487 SSMZ=DCMPLX(1D0-PMAS(23,1)**2/SH,WDTP(0)/SHR)
37488 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
37489 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+113),1)**2/SH,WDTP(0)/SHR)
37490 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
37491 SSMO=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+223),1)**2/SH,WDTP(0)/SHR)
37492 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
37493 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+115),1)**2/SH,WDTP(0)/SHR)
37494 DETD=(FAR*FZO-FAO*FZR)**2+SSMZ*SSMR*SSMO-SFZR*SSMO-
37495 $ SFZO*SSMR-SFAR*SSMO*SSMZ-SFAO*SSMR*SSMZ
37496C...Add in techni-a contribution
37497 DETD=SSMX*DETD-SFZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)
37498 DARHO=-(SSMX*(-FAR*SFZO+FAO*FZO*FZR+FAR*SSMO*SSMZ)-
37499 $ SFZX*FAR*SSMO)/DETD/SH
37500 DZRHO=-(-FZR*SFAO+FAO*FZO*FAR+FZR*SSMO)/DETD/SH*SSMX
37501 DAOME=-(SSMX*(-FAO*SFZR+FAR*FZO*FZR+FAO*SSMR*SSMZ)-
37502 $ SFZX*FAO*SSMR)/DETD/SH
37503 DZOME=-(-FZO*SFAR+FAR*FAO*FZR+FZO*SSMR)/DETD/SH*SSMX
37504 DAAST=-FZX*(FAO*FZO*SSMR+FAR*FZR*SSMO)/DETD/SH
37505 DZAST=-FZX*(SSMR*SSMO-SFAO*SSMR-SFAR*SSMO)/DETD/SH
37506 DAA=(-SSMX*(SFZO*SSMR+SFZR*SSMO-SSMO*SSMR*SSMZ)-
37507 $ SFZX*SSMR*SSMO)/DETD/SH
37508 DZZ=-(SFAO*SSMR+SFAR*SSMO-SSMO*SSMR)/DETD/SH*SSMX
37509 DAZ=(FAR*FZR*SSMO+FAO*FZO*SSMR)/DETD/SH*SSMX
37510
37511C...f + fbar -> gamma pi_tc, gamma pi_tc', Z pi_tc, Z pi_tc',
37512C...W+W-, W pi_tc, pi_T pi_T, etc.
37513 FACA=(SH**2*BE34**2-(TH-UH)**2)
37514 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
37515 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
37516 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
37517 HP=(1D0/24D0)*AEM**2*COMFAC*3D0*SH
37518 DO 370 I=MMINA,MMAXA
37519 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 370
37520 IA=IABS(I)
37521 EI=KCHG(IABS(I),1)/3D0
37522 AI=SIGN(1D0,EI+0.1D0)
37523 VI=AI-4D0*EI*XWV
37524 VALI=0.25D0*(VI+AI) ! = \zeta_{iL} in PRD67-115011
37525 VARI=0.25D0*(VI-AI) ! = \zeta_{iR} in PRD67-115011
37526C...........Eqs. (5) and (6) in LSTC-rates.pdf
37527 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*VRGP
37528 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*VOGP
37529 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*VXGP
37530 F2L=F2L+FANOM*(VAGP*(EI*DAA+VALI*DAZ/SQRT(XW*XW1))+
37531 $ VZGP*(EI*DAZ+VALI*DZZ/SQRT(XW*XW1)))
37532 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*VRGP
37533 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*VOGP
37534 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*VXGP
37535 F2R=F2R+FANOM*(VAGP*(EI*DAA+VARI*DAZ/SQRT(XW*XW1))+
37536 $ VZGP*(EI*DAZ+VARI*DZZ/SQRT(XW*XW1)))
37537 HI=(ABS(F2L)**2+ABS(F2R)**2)*VFAC
37538C...........Eqs. (5) and (7) in LSTC-rates.pdf
37539 F2L=(EI*DARHO+VALI*DZRHO/SQRT(XW*XW1))*ARGP
37540 F2L=F2L+(EI*DAOME+VALI*DZOME/SQRT(XW*XW1))*AOGP
37541 F2L=F2L+(EI*DAAST+VALI*DZAST/SQRT(XW*XW1))*AXGP
37542 F2R=(EI*DARHO+VARI*DZRHO/SQRT(XW*XW1))*ARGP
37543 F2R=F2R+(EI*DAOME+VARI*DZOME/SQRT(XW*XW1))*AOGP
37544 F2R=F2R+(EI*DAAST+VARI*DZAST/SQRT(XW*XW1))*AXGP
37545 HJ=(ABS(F2L)**2+ABS(F2R)**2)*AFAC
37546C
37547C...........Eqs. (24) in PRD67-115011 with DAA, etc.terms dropped.
37548C
37549c$$$ F2L=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
37550c$$$ $ VALI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
37551c$$$ F2R=EI*(DARHO/FAR+(DAA+CT2W*DAZ))+
37552c$$$ $ VARI*(CT2W*DZRHO/FZR+(CT2W*DZZ+DAZ))/SQRT(XW*XW1)
37553 F2L=EI*DARHO/FAR + VALI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
37554 F2R=EI*DARHO/FAR + VARI*CT2W*DZRHO/FZR/SQRT(XW*XW1)
37555 HK=(ABS(F2L)**2+ABS(F2R)**2)*2D0*FACA*CAB2/SH
37556 HI=HI+HJ+HK
37557 IF(IA.LE.10) HI=HI/3D0
37558 NCHN=NCHN+1
37559 ISIG(NCHN,1)=I
37560 ISIG(NCHN,2)=-I
37561 ISIG(NCHN,3)=1
37562 IF(KFA.EQ.KFB) THEN
37563 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),1)
37564 ELSEIF(ISUBSV.EQ.362.OR.ISUBSV.EQ.368) THEN
37565 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),3)
37566 NCHN=NCHN+1
37567 ISIG(NCHN,1)=I
37568 ISIG(NCHN,2)=-I
37569 ISIG(NCHN,3)=2
37570 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),3)*WIDS(PYCOMP(KFB),2)
37571 ELSE
37572 SIGH(NCHN)=HI*HP*WIDS(PYCOMP(KFA),2)*WIDS(PYCOMP(KFB),2)
37573 ENDIF
37574 370 CONTINUE
37575
37576 ELSEIF(ISUB.EQ.370) THEN
37577C...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
37578C...f + fbar' -> gamma pi_tc, etc.
37579 FACA=(SH**2*BE34**2-(TH-UH)**2)
37580 FANOM=SQRT(PARU(1)*AEM)*ITCM(1)/PARU(2)**2/RTCM(1)
37581 VFAC=(TH**2+UH**2-2D0*SQM3*SQM4)
37582 AFAC=(TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM3)
37583 ALPRHT=2.16D0*(3D0/ITCM(1))
37584 FACHP=(1D0/48D0)*AEM**2/XW*COMFAC*3D0*SH
37585 FWR=SQRT(AEM/ALPRHT)/(2D0*SQRT(XW))
37586C...RTCM(47) is the ratio g_{rho_T}/g_{a_T}
37587 FWX=-FWR*RTCM(47)
37588 CALL PYWIDT(24,SH,WDTP,WDTE)
37589 SSMZ=DCMPLX(1D0-PMAS(24,1)**2/SH,WDTP(0)/SHR)
37590 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
37591 SSMR=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+213),1)**2/SH,WDTP(0)/SHR)
37592 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
37593 SSMX=DCMPLX(1D0-PMAS(PYCOMP(KTECHN+215),1)**2/SH,WDTP(0)/SHR)
37594 DETD=SSMX*(SSMZ*SSMR-DCMPLX(FWR**2,0D0))-
37595 & DCMPLX(FWX**2,0D0)*SSMR
37596 DWW=SSMR*SSMX/DETD/SH
37597 DWRHO=-DCMPLX(FWR,0D0)*SSMX/DETD/SH
37598 DWAST=-DCMPLX(FWX,0D0)*SSMR/DETD/SH
37599 HP=FACHP*(AFAC*ABS(DWRHO*ARGP+DWAST*AXGP)**2+
37600 $ VFAC*ABS(FANOM*DWW*VWGP+DWRHO*VRGP+DWAST*VXGP)**2)
37601C
37602C...........Eq. (25) in PRD67-115011 with DWW term dropped.
37603C
37604c$$$ HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWW + DWRHO/FWR)**2
37605 HP=HP+.5D0*FACHP*CAB2*FACA/XW/SH*ABS(DWRHO/FWR)**2
37606C...Add in W_L Z_T axial and vector contributions.
37607 IF(ISUBSV.EQ.370) HP=HP+FACHP*RTCM(3)**2*(
37608 $ (TH**2+UH**2-2D0*SQM3*SQM4+4D0*SH*SQM4)* !AFAC w/ switched masses.
37609 $ ABS(DWRHO/RTCM(13)-DWAST/RTCM(49)*CS2W)**2/SN2W**2+
37610 $ VFAC*QUPD**2*XW/XW1*ABS(DWRHO)**2/RTCM(12)**2)
37611 DO 410 I=MMIN1,MMAX1
37612 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 410
37613 IA=IABS(I)
37614 DO 400 J=MMIN2,MMAX2
37615 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 400
37616 JA=IABS(J)
37617 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 400
37618 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
37619 & GOTO 400
37620 KCHR=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
37621 HI=HP
37622 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)/3D0
37623 NCHN=NCHN+1
37624 ISIG(NCHN,1)=I
37625 ISIG(NCHN,2)=J
37626 ISIG(NCHN,3)=1
37627 IF(ISUBSV.EQ.374.OR.ISUBSV.EQ.378) THEN
37628 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)
37629 ELSE
37630 SIGH(NCHN)=HI*WIDS(PYCOMP(KFA),(5-KCHR)/2)*
37631 & WIDS(PYCOMP(KFB),2)
37632 ENDIF
37633 400 CONTINUE
37634 410 CONTINUE
37635 ENDIF
37636
37637 ELSEIF(ISUB.LE.390) THEN
37638 IF(ISUB.EQ.381) THEN
37639C...f + f' -> f + f' (g exchange)
37640 FACQQ1=COMFAC*AS**2*4D0/9D0*(SH2+UH2)*SQDQQT
37641 FACQQB=COMFAC*AS**2*4D0/9D0*((SH2+UH2)*SQDQQT*FACA-
37642 & MSTP(34)*2D0/3D0*UH2*REDQST)
37643 FACQQ2=COMFAC*AS**2*4D0/9D0*(SH2+TH2)*SQDQQU
37644 FACQQI=-COMFAC*AS**2*4D0/9D0*MSTP(34)*2D0/3D0*SH2/(TH*UH)
37645 RATQQI=(FACQQ1+FACQQ2+FACQQI)/(FACQQ1+FACQQ2)
37646 IF(ITCM(5).GE.1.AND.ITCM(5).LE.4) THEN
37647C...Modifications from contact interactions (compositeness)
37648 FACCI1=FACQQ1+COMFAC*(SH2/RTCM(41)**4)
37649 FACCIB=FACQQB+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
37650 & (UH2/TH+UH2/SH)+COMFAC*(5D0/3D0)*(UH2/RTCM(41)**4)
37651 FACCI2=FACQQ2+COMFAC*(8D0/9D0)*(AS*RTCM(42)/RTCM(41)**2)*
37652 & (SH2/TH+SH2/UH)+COMFAC*(5D0/3D0)*(SH2/RTCM(41)**4)
37653 FACCI3=FACQQ1+COMFAC*(UH2/RTCM(41)**4)
37654 RATCII=(FACCI1+FACCI2+FACQQI)/(FACCI1+FACCI2)
37655 ELSEIF(ITCM(5).EQ.5) THEN
37656 FACCI1=FACQQ1
37657 FACCIB=FACQQB
37658 FACCI2=FACQQ2
37659 FACCI3=FACQQ1
37660CSM.......Check this change from
37661CSM RATCII=1D0
37662 RATCII=RATQQI
37663 ENDIF
37664 DO 430 I=MMIN1,MMAX1
37665 IA=IABS(I)
37666 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 430
37667 DO 420 J=MMIN2,MMAX2
37668 JA=IABS(J)
37669 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 420
37670 NCHN=NCHN+1
37671 ISIG(NCHN,1)=I
37672 ISIG(NCHN,2)=J
37673 ISIG(NCHN,3)=1
37674 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.(IA.GE.3.OR.
37675 & JA.GE.3))) THEN
37676 SIGH(NCHN)=FACQQ1
37677 IF(I.EQ.-J) SIGH(NCHN)=FACQQB
37678 ELSE
37679 SIGH(NCHN)=FACCI1
37680 IF(I*J.LT.0) SIGH(NCHN)=FACCI3
37681 IF(I.EQ.-J) SIGH(NCHN)=FACCIB
37682 ENDIF
37683 IF(I.EQ.J) THEN
37684 NCHN=NCHN+1
37685 ISIG(NCHN,1)=I
37686 ISIG(NCHN,2)=J
37687 ISIG(NCHN,3)=2
37688 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IA.GE.3)) THEN
37689 SIGH(NCHN-1)=0.5D0*FACQQ1*RATQQI
37690 SIGH(NCHN)=0.5D0*FACQQ2*RATQQI
37691 ELSE
37692 SIGH(NCHN-1)=0.5D0*FACCI1*RATCII
37693 SIGH(NCHN)=0.5D0*FACCI2*RATCII
37694 ENDIF
37695 ENDIF
37696 420 CONTINUE
37697 430 CONTINUE
37698
37699 ELSEIF(ISUB.EQ.382) THEN
37700C...f + fbar -> f' + fbar' (q + qbar -> q' + qbar' only)
37701 CALL PYWIDT(21,SH,WDTP,WDTE)
37702 FACQQF=COMFAC*AS**2*4D0/9D0*(TH2+UH2)
37703 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37704 IF(ITCM(5).EQ.1) THEN
37705C...Modifications from contact interactions (compositeness)
37706 FACCIB=FACQQB
37707 DO 440 I=1,2
37708 FACCIB=FACCIB+COMFAC*(UH2/RTCM(41)**4)*(WDTE(I,1)+
37709 & WDTE(I,2)+WDTE(I,4))
37710 440 CONTINUE
37711 ELSEIF(ITCM(5).GE.2.AND.ITCM(5).LE.4) THEN
37712 FACCIB=FACQQB+COMFAC*(UH2/RTCM(41)**4)*
37713 & (WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
37714 ELSEIF(ITCM(5).EQ.5) THEN
37715 FACQQB=FACQQF*SQDQQS*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4)-
37716 & WDTE(5,1)-WDTE(5,2)-WDTE(5,4))
37717 FACCIB=FACQQF*SQDQTS*(WDTE(5,1)+WDTE(5,2)+WDTE(5,4))
37718 ENDIF
37719 DO 450 I=MMINA,MMAXA
37720 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37721 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 450
37722 NCHN=NCHN+1
37723 ISIG(NCHN,1)=I
37724 ISIG(NCHN,2)=-I
37725 ISIG(NCHN,3)=1
37726 IF(ITCM(5).LE.0.OR.(ITCM(5).EQ.1.AND.IABS(I).GE.3)) THEN
37727 SIGH(NCHN)=FACQQB
37728 ELSEIF(ITCM(5).EQ.5) THEN
37729 SIGH(NCHN)=FACQQB
37730 NCHN=NCHN+1
37731 ISIG(NCHN,1)=I
37732 ISIG(NCHN,2)=-I
37733 ISIG(NCHN,3)=2
37734 SIGH(NCHN)=FACCIB
37735 ELSE
37736 SIGH(NCHN)=FACCIB
37737 ENDIF
37738 450 CONTINUE
37739
37740 ELSEIF(ISUB.EQ.383) THEN
37741C...f + fbar -> g + g (q + qbar -> g + g only)
37742 FACGG1=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37743 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37744 FACGG2=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37745 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)
37746 IF(ITCM(5).EQ.5) THEN
37747 FACGG3=COMFAC*AS**2*32D0/27D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37748 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37749 FACGG4=COMFAC*AS**2*32D0/27D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37750 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDHGS)
37751 ENDIF
37752 DO 460 I=MMINA,MMAXA
37753 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37754 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 460
37755 NCHN=NCHN+1
37756 ISIG(NCHN,1)=I
37757 ISIG(NCHN,2)=-I
37758 ISIG(NCHN,3)=1
37759 SIGH(NCHN)=0.5D0*FACGG1
37760 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG3
37761 NCHN=NCHN+1
37762 ISIG(NCHN,1)=I
37763 ISIG(NCHN,2)=-I
37764 ISIG(NCHN,3)=2
37765 SIGH(NCHN)=0.5D0*FACGG2
37766 IF(ITCM(5).EQ.5.AND.IABS(I).EQ.5) SIGH(NCHN)=0.5D0*FACGG4
37767 460 CONTINUE
37768
37769 ELSEIF(ISUB.EQ.384) THEN
37770C...f + g -> f + g (q + g -> q + g only)
37771 FACQG1=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*UH2/TH2-
37772 & UH/SH-9D0/4D0*SH*UH/TH2*SQDLGT)*FACA
37773 FACQG2=COMFAC*AS**2*4D0/9D0*((2D0+MSTP(34)*1D0/4D0)*SH2/TH2-
37774 & SH/UH-9D0/4D0*SH*UH/TH2*SQDLGT)
37775 DO 480 I=MMINA,MMAXA
37776 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 480
37777 DO 470 ISDE=1,2
37778 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 470
37779 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 470
37780 NCHN=NCHN+1
37781 ISIG(NCHN,ISDE)=I
37782 ISIG(NCHN,3-ISDE)=21
37783 ISIG(NCHN,3)=1
37784 SIGH(NCHN)=FACQG1
37785 NCHN=NCHN+1
37786 ISIG(NCHN,ISDE)=I
37787 ISIG(NCHN,3-ISDE)=21
37788 ISIG(NCHN,3)=2
37789 SIGH(NCHN)=FACQG2
37790 470 CONTINUE
37791 480 CONTINUE
37792
37793 ELSEIF(ISUB.EQ.385) THEN
37794C...g + g -> f + fbar (g + g -> q + qbar only)
37795 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 500
37796 IDC0=MDCY(21,2)-1
37797C...Begin by d, u, s flavours.
37798 FLAVWT=0D0
37799 IF(MDME(IDC0+1,1).GE.1) FLAVWT=FLAVWT+
37800 & SQRT(MAX(0D0,1D0-4D0*PMAS(1,1)**2/SH))
37801 IF(MDME(IDC0+2,1).GE.1) FLAVWT=FLAVWT+
37802 & SQRT(MAX(0D0,1D0-4D0*PMAS(2,1)**2/SH))
37803 IF(MDME(IDC0+3,1).GE.1) FLAVWT=FLAVWT+
37804 & SQRT(MAX(0D0,1D0-4D0*PMAS(3,1)**2/SH))
37805 FACQQ1=COMFAC*AS**2*1D0/6D0*(UH/TH-(2D0+MSTP(34)*1D0/4D0)*
37806 & UH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37807 FACQQ2=COMFAC*AS**2*1D0/6D0*(TH/UH-(2D0+MSTP(34)*1D0/4D0)*
37808 & TH2/SH2+9D0/4D0*TH*UH/SH2*SQDLGS)*FLAVWT*FACA
37809 NCHN=NCHN+1
37810 ISIG(NCHN,1)=21
37811 ISIG(NCHN,2)=21
37812 ISIG(NCHN,3)=1
37813 SIGH(NCHN)=FACQQ1
37814 NCHN=NCHN+1
37815 ISIG(NCHN,1)=21
37816 ISIG(NCHN,2)=21
37817 ISIG(NCHN,3)=2
37818 SIGH(NCHN)=FACQQ2
37819C...Next c and b flavours: modified that and uhat for fixed
37820C...cos(theta-hat).
37821 DO 490 IFL=4,5
37822 SQMAVG=PMAS(IFL,1)**2
37823 IF(MDME(IDC0+IFL,1).GE.1.AND.SH.GT.4.04D0*SQMAVG) THEN
37824 BE34=SQRT(1D0-4D0*SQMAVG/SH)
37825 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37826 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37827 THUHQ=THQ*UHQ-SQMAVG*SH
37828 IF(MSTP(34).EQ.0) THEN
37829 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37830 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37831 ELSE
37832 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37833 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37834 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37835 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37836 ENDIF
37837 IF(ITCM(5).GE.5) THEN
37838 IF(IFL.EQ.4) THEN
37839 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37840 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37841 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37842 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37843 ELSE
37844 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37845 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37846 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37847 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37848 ENDIF
37849 ENDIF
37850 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1*BE34
37851 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2*BE34
37852 NCHN=NCHN+1
37853 ISIG(NCHN,1)=21
37854 ISIG(NCHN,2)=21
37855 ISIG(NCHN,3)=1+2*(IFL-3)
37856 SIGH(NCHN)=FACQQ1
37857 NCHN=NCHN+1
37858 ISIG(NCHN,1)=21
37859 ISIG(NCHN,2)=21
37860 ISIG(NCHN,3)=2+2*(IFL-3)
37861 SIGH(NCHN)=FACQQ2
37862 ENDIF
37863 490 CONTINUE
37864 500 CONTINUE
37865
37866 ELSEIF(ISUB.EQ.386) THEN
37867C...g + g -> g + g
37868 IF(ITCM(5).LE.4) THEN
37869 FACGG1=COMFAC*AS**2*9D0/4D0*(SH2/TH2+2D0*SH/TH+3D0+
37870 & 2D0*TH/SH+TH2/SH2)*FACA
37871 FACGG2=COMFAC*AS**2*9D0/4D0*(UH2/SH2+2D0*UH/SH+3D0+
37872 & 2D0*SH/UH+SH2/UH2)*FACA
37873 FACGG3=COMFAC*AS**2*9D0/4D0*(TH2/UH2+2D0*TH/UH+3D0+
37874 & 2D0*UH/TH+UH2/TH2)
37875 ELSE
37876 GST= (12D0 + 40D0*TH/SH + 56D0*TH2/SH2 + 32D0*TH**3/SH**3 +
37877 & 16D0*TH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*TH + 16D0*TH2)+
37878 & 4D0*REDGST*(SH + 2D0*TH)*
37879 & (2D0*SH**3 - 3D0*SH2*TH - 2D0*SH*TH2 + 2D0*TH**3)/SH2 +
37880 & 2D0*REDGGS*(2D0*SH - 12D0*TH2/SH - 8D0*TH**3/SH2) +
37881 & 2D0*REDGGT*(4D0*SH - 22D0*TH - 68D0*TH2/SH - 60D0*TH**3/SH2-
37882 & 32D0*TH**4/SH**3 - 16D0*TH**5/SH**4) +
37883 & SQDGGT*(16D0*SH2 + 16D0*SH*TH + 68D0*TH2 + 144D0*TH**3/SH +
37884 & 96D0*TH**4/SH2 + 32D0*TH**5/SH**3 + 16D0*TH**6/SH**4))/16D0
37885 GSU= (12D0 + 40D0*UH/SH + 56D0*UH2/SH2 + 32D0*UH**3/SH**3 +
37886 & 16D0*UH**4/SH**4 + SQDGGS*(4D0*SH2 + 16D0*SH*UH + 16D0*UH2)+
37887 & 4D0*REDGSU*(SH + 2D0*UH)*
37888 & (2D0*SH**3 - 3D0*SH2*UH - 2D0*SH*UH2 + 2D0*UH**3)/SH2 +
37889 & 2D0*REDGGS*(2D0*SH - 12D0*UH2/SH - 8D0*UH**3/SH2) +
37890 & 2D0*REDGGU*(4D0*SH - 22D0*UH - 68D0*UH2/SH - 60D0*UH**3/SH2-
37891 & 32D0*UH**4/SH**3 - 16D0*UH**5/SH**4) +
37892 & SQDGGU*(16D0*SH2 + 16D0*SH*UH + 68D0*UH2 + 144D0*UH**3/SH +
37893 & 96D0*UH**4/SH2 + 32D0*UH**5/SH**3 + 16D0*UH**6/SH**4))/16D0
37894 GUT= (12D0 - 16D0*TH*(TH - UH)**2*UH/SH**4 +
37895 & 4D0*REDGGU*(2D0*TH**5 - 15D0*TH**4*UH - 48D0*TH**3*UH2 -
37896 & 58D0*TH2*UH**3 - 10D0*TH*UH**4 + UH**5)/SH**4 +
37897 & 4D0*REDGGT*(TH**5 - 10D0*TH**4*UH - 58D0*TH**3*UH2 -
37898 & 48D0*TH2*UH**3 - 15D0*TH*UH**4 + 2D0*UH**5)/SH**4 +
37899 & 4D0*SQDGGU*(4D0*TH**6 + 20D0*TH**5*UH + 57D0*TH**4*UH2 +
37900 & 72D0*TH**3*UH**3+ 38D0*TH2*UH**4+4D0*TH*UH**5 +UH**6)/SH**4+
37901 & 4D0*SQDGGT*(4D0*UH**6 + 4D0*TH**5*UH + 38D0*TH**4*UH2 +
37902 & 72D0*TH**3*UH**3 +57D0*TH2*UH**4+20D0*TH*UH**5+TH**6)/SH**4+
37903 & 2D0*REDGTU*((TH - UH)**2* (TH**4 + 20D0*TH**3*UH +
37904 & 30D0*TH2*UH2 + 20D0*TH*UH**3 + UH**4) +
37905 & SH2*(7D0*TH**4 + 52D0*TH**3*UH + 274D0*TH2*UH2 +
37906 & 52D0*TH*UH**3 + 7D0*UH**4))/(2D0*SH**4))/16D0
37907 FACGG1=COMFAC*AS**2*9D0/4D0*GST*FACA
37908 FACGG2=COMFAC*AS**2*9D0/4D0*GSU*FACA
37909 FACGG3=COMFAC*AS**2*9D0/4D0*GUT
37910 ENDIF
37911 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 510
37912 NCHN=NCHN+1
37913 ISIG(NCHN,1)=21
37914 ISIG(NCHN,2)=21
37915 ISIG(NCHN,3)=1
37916 SIGH(NCHN)=0.5D0*FACGG1
37917 NCHN=NCHN+1
37918 ISIG(NCHN,1)=21
37919 ISIG(NCHN,2)=21
37920 ISIG(NCHN,3)=2
37921 SIGH(NCHN)=0.5D0*FACGG2
37922 NCHN=NCHN+1
37923 ISIG(NCHN,1)=21
37924 ISIG(NCHN,2)=21
37925 ISIG(NCHN,3)=3
37926 SIGH(NCHN)=0.5D0*FACGG3
37927 510 CONTINUE
37928
37929 ELSEIF(ISUB.EQ.387) THEN
37930C...q + qbar -> Q + Qbar
37931 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37932 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37933 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37934 FACQQB=COMFAC*AS**2*4D0/9D0*((THQ**2+UHQ**2)/SH2+
37935 & 2D0*SQMAVG/SH)
37936 IF(ITCM(5).GE.5) THEN
37937 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37938 FACQQB=FACQQB*SH2*SQDQTS
37939 ELSE
37940 FACQQB=FACQQB*SH2*SQDQQS
37941 ENDIF
37942 ENDIF
37943 IF(MSTP(35).GE.1) FACQQB=FACQQB*PYHFTH(SH,SQMAVG,0D0)
37944 WID2=1D0
37945 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37946 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37947 FACQQB=FACQQB*WID2
37948 DO 520 I=MMINA,MMAXA
37949 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
37950 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 520
37951 NCHN=NCHN+1
37952 ISIG(NCHN,1)=I
37953 ISIG(NCHN,2)=-I
37954 ISIG(NCHN,3)=1
37955 SIGH(NCHN)=FACQQB
37956 520 CONTINUE
37957
37958 ELSEIF(ISUB.EQ.388) THEN
37959C...g + g -> Q + Qbar
37960 SQMAVG=0.5D0*(SQM3+SQM4)-0.25D0*(SQM3-SQM4)**2/SH
37961 THQ=-0.5D0*SH*(1D0-BE34*CTH)
37962 UHQ=-0.5D0*SH*(1D0+BE34*CTH)
37963 THUHQ=THQ*UHQ-SQMAVG*SH
37964 IF(MSTP(34).EQ.0) THEN
37965 FACQQ1=UHQ/THQ-2D0*UHQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/THQ**2
37966 FACQQ2=THQ/UHQ-2D0*THQ**2/SH2+4D0*(SQMAVG/SH)*THUHQ/UHQ**2
37967 ELSE
37968 FACQQ1=UHQ/THQ-2.25D0*UHQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37969 & THQ**2+0.5D0*SQMAVG*(THQ+SQMAVG)/THQ**2-SQMAVG**2/(SH*THQ)
37970 FACQQ2=THQ/UHQ-2.25D0*THQ**2/SH2+4.5D0*(SQMAVG/SH)*THUHQ/
37971 & UHQ**2+0.5D0*SQMAVG*(UHQ+SQMAVG)/UHQ**2-SQMAVG**2/(SH*UHQ)
37972 ENDIF
37973 IF(ITCM(5).GE.5) THEN
37974 IF(MINT(55).EQ.5.OR.MINT(55).EQ.6) THEN
37975 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDHGS+
37976 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37977 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDHGS+
37978 & 2.25D0*THQ*UHQ/SH2*SQDHGS
37979 ELSE
37980 FACQQ1=FACQQ1+2.25D0*SQMAVG*(THQ-UHQ)/(SH*THQ)*REDLGS+
37981 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37982 FACQQ2=FACQQ2+2.25D0*SQMAVG*(UHQ-THQ)/(SH*UHQ)*REDLGS+
37983 & 2.25D0*THQ*UHQ/SH2*SQDLGS
37984 ENDIF
37985 ENDIF
37986 FACQQ1=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ1
37987 FACQQ2=COMFAC*FACA*AS**2*(1D0/6D0)*FACQQ2
37988 IF(MSTP(35).GE.1) THEN
37989 FATRE=PYHFTH(SH,SQMAVG,2D0/7D0)
37990 FACQQ1=FACQQ1*FATRE
37991 FACQQ2=FACQQ2*FATRE
37992 ENDIF
37993 WID2=1D0
37994 IF(MINT(55).EQ.6) WID2=WIDS(6,1)
37995 IF(MINT(55).EQ.7.OR.MINT(55).EQ.8) WID2=WIDS(MINT(55),1)
37996 FACQQ1=FACQQ1*WID2
37997 FACQQ2=FACQQ2*WID2
37998 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 530
37999 NCHN=NCHN+1
38000 ISIG(NCHN,1)=21
38001 ISIG(NCHN,2)=21
38002 ISIG(NCHN,3)=1
38003 SIGH(NCHN)=FACQQ1
38004 NCHN=NCHN+1
38005 ISIG(NCHN,1)=21
38006 ISIG(NCHN,2)=21
38007 ISIG(NCHN,3)=2
38008 SIGH(NCHN)=FACQQ2
38009 530 CONTINUE
38010 ENDIF
38011 ENDIF
38012
38013CMRENNA--
38014
38015 RETURN
38016 END
38017
38018C*********************************************************************
38019
38020C...PYSGEX
38021C...Subprocess cross sections for assorted exotic processes,
38022C...including Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*.
38023C...Auxiliary to PYSIGH.
38024
38025 SUBROUTINE PYSGEX(NCHN,SIGS)
38026
38027C...Double precision and integer declarations
38028 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38029 IMPLICIT INTEGER(I-N)
38030 INTEGER PYK,PYCHGE,PYCOMP
38031C...Parameter statement to help give large particle numbers.
38032 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
38033 &KEXCIT=4000000,KDIMEN=5000000)
38034C...Commonblocks
38035 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38036 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38037 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
38038 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38039 COMMON/PYINT1/MINT(400),VINT(400)
38040 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
38041 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
38042 COMMON/PYINT4/MWID(500),WIDS(500,5)
38043 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
38044 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
38045 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
38046 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
38047 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
38048 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYINT1/,/PYINT2/,
38049 &/PYINT3/,/PYINT4/,/PYTCSM/,/PYSGCM/
38050C...Local arrays
38051 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
38052
38053C...Differential cross section expressions.
38054
38055 IF(ISUB.LE.160) THEN
38056 IF(ISUB.EQ.141) THEN
38057C...f + fbar -> gamma*/Z0/Z'0
38058 SQMZP=PMAS(32,1)**2
38059 MINT(61)=2
38060 CALL PYWIDT(32,SH,WDTP,WDTE)
38061 HP0=AEM/3D0*SH
38062 HP1=AEM/3D0*XWC*SH
38063 HP2=HP1
38064 HS=SHR*VINT(117)
38065 HSP=SHR*WDTP(0)
38066 FACZP=4D0*COMFAC*3D0
38067 DO 100 I=MMINA,MMAXA
38068 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 100
38069 EI=KCHG(IABS(I),1)/3D0
38070 AI=SIGN(1D0,EI)
38071 VI=AI-4D0*EI*XWV
38072 IA=IABS(I)
38073 IF(IA.LT.10) THEN
38074 IF(IA.LE.2) THEN
38075 VPI=PARU(123-2*MOD(IABS(I),2))
38076 API=PARU(124-2*MOD(IABS(I),2))
38077 ELSEIF(IA.LE.4) THEN
38078 VPI=PARJ(182-2*MOD(IABS(I),2))
38079 API=PARJ(183-2*MOD(IABS(I),2))
38080 ELSE
38081 VPI=PARJ(190-2*MOD(IABS(I),2))
38082 API=PARJ(191-2*MOD(IABS(I),2))
38083 ENDIF
38084 ELSE
38085 IF(IA.LE.12) THEN
38086 VPI=PARU(127-2*MOD(IABS(I),2))
38087 API=PARU(128-2*MOD(IABS(I),2))
38088 ELSEIF(IA.LE.14) THEN
38089 VPI=PARJ(186-2*MOD(IABS(I),2))
38090 API=PARJ(187-2*MOD(IABS(I),2))
38091 ELSE
38092 VPI=PARJ(194-2*MOD(IABS(I),2))
38093 API=PARJ(195-2*MOD(IABS(I),2))
38094 ENDIF
38095 ENDIF
38096 HI0=HP0
38097 IF(IABS(I).LE.10) HI0=HI0*FACA/3D0
38098 HI1=HP1
38099 IF(IABS(I).LE.10) HI1=HI1*FACA/3D0
38100 HI2=HP2
38101 IF(IABS(I).LE.10) HI2=HI2*FACA/3D0
38102 NCHN=NCHN+1
38103 ISIG(NCHN,1)=I
38104 ISIG(NCHN,2)=-I
38105 ISIG(NCHN,3)=1
38106C...Special case: if only branching ratios known then use them.
38107 IF(MWID(32).EQ.2.AND.MSTP(44).EQ.3) THEN
38108 HI=0D0
38109 IF(IA.LT.10) THEN
38110 HI=SHR*WDTP(IA)*FACA/9D0
38111 ELSEIF(IA.LT.20) THEN
38112 HI=SHR*WDTP(IA-2)
38113 ENDIF
38114 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38115 SIGH(NCHN)=HI*FACZP*HF/((SH-SQMZP)**2+HSP**2)
38116 ELSE
38117C...Normal cross section.
38118 SIGH(NCHN)=FACZP*(EI**2/SH2*HI0*HP0*VINT(111)+EI*VI*
38119 & (1D0-SQMZ/SH)/((SH-SQMZ)**2+HS**2)*(HI0*HP1+HI1*HP0)*
38120 & VINT(112)+EI*VPI*(1D0-SQMZP/SH)/((SH-SQMZP)**2+HSP**2)*
38121 & (HI0*HP2+HI2*HP0)*VINT(113)+(VI**2+AI**2)/
38122 & ((SH-SQMZ)**2+HS**2)*HI1*HP1*VINT(114)+(VI*VPI+AI*API)*
38123 & ((SH-SQMZ)*(SH-SQMZP)+HS*HSP)/(((SH-SQMZ)**2+HS**2)*
38124 & ((SH-SQMZP)**2+HSP**2))*(HI1*HP2+HI2*HP1)*VINT(115)+
38125 & (VPI**2+API**2)/((SH-SQMZP)**2+HSP**2)*HI2*HP2*VINT(116))
38126 ENDIF
38127 100 CONTINUE
38128
38129 ELSEIF(ISUB.EQ.142) THEN
38130C...f + fbar' -> W'+/-
38131 SQMWP=PMAS(34,1)**2
38132 CALL PYWIDT(34,SH,WDTP,WDTE)
38133 HS=SHR*WDTP(0)
38134 FACBW=4D0*COMFAC/((SH-SQMWP)**2+HS**2)*3D0
38135 HP=AEM/(24D0*XW)*SH
38136 DO 120 I=MMIN1,MMAX1
38137 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 120
38138 IA=IABS(I)
38139 DO 110 J=MMIN2,MMAX2
38140 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 110
38141 JA=IABS(J)
38142 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 110
38143 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
38144 & GOTO 110
38145 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38146C...Special case: if only branching ratios known then use them.
38147 IF(MWID(34).EQ.2) THEN
38148 HI=0D0
38149 DO 105 IDC=MDCY(34,2),MDCY(34,2)+MDCY(34,3)-1
38150 IF((IA.EQ.IABS(KFDP(IDC,1)).AND.JA.EQ.
38151 & IABS(KFDP(IDC,2))).OR.(IA.EQ.IABS(KFDP(IDC,2))
38152 & .AND.JA.EQ.IABS(KFDP(IDC,1))))
38153 & HI=SHR*WDTP(IDC+1-MDCY(34,2))
38154 105 CONTINUE
38155 IF(IA.LT.10) HI=HI*FACA/9D0
38156 ELSE
38157C...Normal cross section.
38158 HI=HP*(PARU(133)**2+PARU(134)**2)
38159 IF(IA.LE.10) HI=HP*(PARU(131)**2+PARU(132)**2)*
38160 & VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
38161 ENDIF
38162 NCHN=NCHN+1
38163 ISIG(NCHN,1)=I
38164 ISIG(NCHN,2)=J
38165 ISIG(NCHN,3)=1
38166 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
38167 SIGH(NCHN)=HI*FACBW*HF
38168 110 CONTINUE
38169 120 CONTINUE
38170
38171 ELSEIF(ISUB.EQ.144) THEN
38172C...f + fbar' -> R
38173 SQMR=PMAS(41,1)**2
38174 CALL PYWIDT(41,SH,WDTP,WDTE)
38175 HS=SHR*WDTP(0)
38176 FACBW=4D0*COMFAC/((SH-SQMR)**2+HS**2)*3D0
38177 HP=AEM/(12D0*XW)*SH
38178 DO 140 I=MMIN1,MMAX1
38179 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 140
38180 IA=IABS(I)
38181 DO 130 J=MMIN2,MMAX2
38182 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 130
38183 JA=IABS(J)
38184 IF(I*J.GT.0.OR.IABS(IA-JA).NE.2) GOTO 130
38185 HI=HP
38186 IF(IA.LE.10) HI=HI*FACA/3D0
38187 HF=SHR*(WDTE(0,1)+WDTE(0,(10-(I+J))/4)+WDTE(0,4))
38188 NCHN=NCHN+1
38189 ISIG(NCHN,1)=I
38190 ISIG(NCHN,2)=J
38191 ISIG(NCHN,3)=1
38192 SIGH(NCHN)=HI*FACBW*HF
38193 130 CONTINUE
38194 140 CONTINUE
38195
38196 ELSEIF(ISUB.EQ.145) THEN
38197C...q + l -> LQ (leptoquark)
38198 SQMLQ=PMAS(42,1)**2
38199 CALL PYWIDT(42,SH,WDTP,WDTE)
38200 HS=SHR*WDTP(0)
38201 FACBW=4D0*COMFAC/((SH-SQMLQ)**2+HS**2)
38202 IF(ABS(SHR-PMAS(42,1)).GT.PARP(48)*PMAS(42,2)) FACBW=0D0
38203 HP=AEM/4D0*SH
38204 KFLQQ=KFDP(MDCY(42,2),1)
38205 KFLQL=KFDP(MDCY(42,2),2)
38206 DO 160 I=MMIN1,MMAX1
38207 IF(KFAC(1,I).EQ.0) GOTO 160
38208 IA=IABS(I)
38209 IF(IA.NE.KFLQQ.AND.IA.NE.IABS(KFLQL)) GOTO 160
38210 DO 150 J=MMIN2,MMAX2
38211 IF(KFAC(2,J).EQ.0) GOTO 150
38212 JA=IABS(J)
38213 IF(JA.NE.KFLQQ.AND.JA.NE.IABS(KFLQL)) GOTO 150
38214 IF(I*J.NE.KFLQQ*KFLQL) GOTO 150
38215 IF(JA.EQ.IA) GOTO 150
38216 IF(IA.EQ.KFLQQ) KCHLQ=ISIGN(1,I)
38217 IF(JA.EQ.KFLQQ) KCHLQ=ISIGN(1,J)
38218 HI=HP*PARU(151)
38219 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHLQ)/2)+WDTE(0,4))
38220 NCHN=NCHN+1
38221 ISIG(NCHN,1)=I
38222 ISIG(NCHN,2)=J
38223 ISIG(NCHN,3)=1
38224 SIGH(NCHN)=HI*FACBW*HF
38225 150 CONTINUE
38226 160 CONTINUE
38227
38228 ELSEIF(ISUB.EQ.146) THEN
38229C...e + gamma* -> e* (excited lepton)
38230 KFQSTR=KFPR(ISUB,1)
38231 KCQSTR=PYCOMP(KFQSTR)
38232 KFQEXC=MOD(KFQSTR,KEXCIT)
38233 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
38234 HS=SHR*WDTP(0)
38235 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
38236 QF=-RTCM(43)/2D0-RTCM(44)/2D0
38237 FACBW=FACBW*AEM*QF**2*SH/RTCM(41)**2
38238 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
38239 & FACBW=0D0
38240 HP=SH
38241 DO 180 I=-KFQEXC,KFQEXC,2*KFQEXC
38242 DO 170 ISDE=1,2
38243 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 170
38244 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 170
38245 HI=HP
38246 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38247 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
38248 NCHN=NCHN+1
38249 ISIG(NCHN,ISDE)=I
38250 ISIG(NCHN,3-ISDE)=22
38251 ISIG(NCHN,3)=1
38252 SIGH(NCHN)=HI*FACBW*HF
38253 170 CONTINUE
38254 180 CONTINUE
38255
38256 ELSEIF(ISUB.EQ.147.OR.ISUB.EQ.148) THEN
38257C...d + g -> d* and u + g -> u* (excited quarks)
38258 KFQSTR=KFPR(ISUB,1)
38259 KCQSTR=PYCOMP(KFQSTR)
38260 KFQEXC=MOD(KFQSTR,KEXCIT)
38261 CALL PYWIDT(KFQSTR,SH,WDTP,WDTE)
38262 HS=SHR*WDTP(0)
38263 FACBW=COMFAC/((SH-PMAS(KCQSTR,1)**2)**2+HS**2)
38264 FACBW=FACBW*AS*RTCM(45)**2*SH/(3D0*RTCM(41)**2)
38265 IF(ABS(SHR-PMAS(KCQSTR,1)).GT.PARP(48)*PMAS(KCQSTR,2))
38266 & FACBW=0D0
38267 HP=SH
38268 DO 200 I=-KFQEXC,KFQEXC,2*KFQEXC
38269 DO 190 ISDE=1,2
38270 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 190
38271 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 190
38272 HI=HP
38273 IF(I.GT.0) HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38274 IF(I.LT.0) HF=SHR*(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))
38275 NCHN=NCHN+1
38276 ISIG(NCHN,ISDE)=I
38277 ISIG(NCHN,3-ISDE)=21
38278 ISIG(NCHN,3)=1
38279 SIGH(NCHN)=HI*FACBW*HF
38280 190 CONTINUE
38281 200 CONTINUE
38282 ENDIF
38283
38284 ELSEIF(ISUB.LE.190) THEN
38285 IF(ISUB.EQ.162) THEN
38286C...q + g -> LQ + lbar; LQ=leptoquark
38287 SQMLQ=PMAS(42,1)**2
38288 FACLQ=COMFAC*FACA*PARU(151)*(AS*AEM/6D0)*(-TH/SH)*
38289 & (UH2+SQMLQ**2)/(UH-SQMLQ)**2
38290 KFLQQ=KFDP(MDCY(42,2),1)
38291 DO 220 I=MMINA,MMAXA
38292 IF(IABS(I).NE.KFLQQ) GOTO 220
38293 KCHLQ=ISIGN(1,I)
38294 DO 210 ISDE=1,2
38295 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 210
38296 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 210
38297 NCHN=NCHN+1
38298 ISIG(NCHN,ISDE)=I
38299 ISIG(NCHN,3-ISDE)=21
38300 ISIG(NCHN,3)=1
38301 SIGH(NCHN)=FACLQ*WIDS(42,(5-KCHLQ)/2)
38302 210 CONTINUE
38303 220 CONTINUE
38304
38305 ELSEIF(ISUB.EQ.163) THEN
38306C...g + g -> LQ + LQbar; LQ=leptoquark
38307 SQMLQ=PMAS(42,1)**2
38308 FACLQ=COMFAC*FACA*WIDS(42,1)*(AS**2/2D0)*
38309 & (7D0/48D0+3D0*(UH-TH)**2/(16D0*SH2))*(1D0+2D0*SQMLQ*TH/
38310 & (TH-SQMLQ)**2+2D0*SQMLQ*UH/(UH-SQMLQ)**2+4D0*SQMLQ**2/
38311 & ((TH-SQMLQ)*(UH-SQMLQ)))
38312 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 230
38313 NCHN=NCHN+1
38314 ISIG(NCHN,1)=21
38315 ISIG(NCHN,2)=21
38316C...Since don't know proper colour flow, randomize between alternatives
38317 ISIG(NCHN,3)=INT(1.5D0+PYR(0))
38318 SIGH(NCHN)=FACLQ
38319 230 CONTINUE
38320
38321 ELSEIF(ISUB.EQ.164) THEN
38322C...q + qbar -> LQ + LQbar; LQ=leptoquark
38323 DELTA=0.25D0*(SQM3-SQM4)**2/SH
38324 SQMLQ=0.5D0*(SQM3+SQM4)-DELTA
38325 TH=TH-DELTA
38326 UH=UH-DELTA
38327C SQMLQ=PMAS(42,1)**2
38328 FACLQA=COMFAC*WIDS(42,1)*(AS**2/9D0)*
38329 & (SH*(SH-4D0*SQMLQ)-(UH-TH)**2)/SH2
38330 FACLQS=COMFAC*WIDS(42,1)*((PARU(151)**2*AEM**2/8D0)*
38331 & (-SH*TH-(SQMLQ-TH)**2)/TH2+(PARU(151)*AEM*AS/18D0)*
38332 & ((SQMLQ-TH)*(UH-TH)+SH*(SQMLQ+TH))/(SH*TH))
38333 KFLQQ=KFDP(MDCY(42,2),1)
38334 DO 240 I=MMINA,MMAXA
38335 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
38336 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 240
38337 NCHN=NCHN+1
38338 ISIG(NCHN,1)=I
38339 ISIG(NCHN,2)=-I
38340 ISIG(NCHN,3)=1
38341 SIGH(NCHN)=FACLQA
38342 IF(IABS(I).EQ.KFLQQ) SIGH(NCHN)=FACLQA+FACLQS
38343 240 CONTINUE
38344
38345 ELSEIF(ISUB.EQ.167.OR.ISUB.EQ.168) THEN
38346C...q + q' -> q" + d* and q + q' -> q" + u* (excited quarks)
38347 KFQSTR=KFPR(ISUB,2)
38348 KCQSTR=PYCOMP(KFQSTR)
38349 KFQEXC=MOD(KFQSTR,KEXCIT)
38350 FACQSA=COMFAC*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)
38351 FACQSB=COMFAC*0.25D0*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
38352 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
38353C...Propagators: as simulated in PYOFSH and as desired
38354 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
38355 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
38356 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
38357 GMMQC=SQRT(SQM4)*WDTP(0)
38358 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
38359 FACQSA=FACQSA*HBW4C/HBW4
38360 FACQSB=FACQSB*HBW4C/HBW4
38361C...Branching ratios.
38362 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
38363 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
38364 DO 260 I=MMIN1,MMAX1
38365 IA=IABS(I)
38366 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 260
38367 DO 250 J=MMIN2,MMAX2
38368 JA=IABS(J)
38369 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 250
38370 IF(IA.EQ.KFQEXC.AND.I.EQ.J) THEN
38371 NCHN=NCHN+1
38372 ISIG(NCHN,1)=I
38373 ISIG(NCHN,2)=J
38374 ISIG(NCHN,3)=1
38375 IF(I.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
38376 IF(I.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
38377 NCHN=NCHN+1
38378 ISIG(NCHN,1)=I
38379 ISIG(NCHN,2)=J
38380 ISIG(NCHN,3)=2
38381 IF(J.GT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRPOS
38382 IF(J.LT.0) SIGH(NCHN)=(4D0/3D0)*FACQSA*BRNEG
38383 ELSEIF((IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC).AND.I*J.GT.0) THEN
38384 NCHN=NCHN+1
38385 ISIG(NCHN,1)=I
38386 ISIG(NCHN,2)=J
38387 ISIG(NCHN,3)=1
38388 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
38389 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSA*BRPOS
38390 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSA*BRNEG
38391 ELSEIF(IA.EQ.KFQEXC.AND.I.EQ.-J) THEN
38392 NCHN=NCHN+1
38393 ISIG(NCHN,1)=I
38394 ISIG(NCHN,2)=J
38395 ISIG(NCHN,3)=1
38396 IF(I.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
38397 IF(I.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
38398 NCHN=NCHN+1
38399 ISIG(NCHN,1)=I
38400 ISIG(NCHN,2)=J
38401 ISIG(NCHN,3)=2
38402 IF(J.GT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRPOS
38403 IF(J.LT.0) SIGH(NCHN)=(8D0/3D0)*FACQSB*BRNEG
38404 ELSEIF(I.EQ.-J) THEN
38405 NCHN=NCHN+1
38406 ISIG(NCHN,1)=I
38407 ISIG(NCHN,2)=J
38408 ISIG(NCHN,3)=1
38409 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38410 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38411 NCHN=NCHN+1
38412 ISIG(NCHN,1)=I
38413 ISIG(NCHN,2)=J
38414 ISIG(NCHN,3)=2
38415 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38416 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38417 ELSEIF(IA.EQ.KFQEXC.OR.JA.EQ.KFQEXC) THEN
38418 NCHN=NCHN+1
38419 ISIG(NCHN,1)=I
38420 ISIG(NCHN,2)=J
38421 ISIG(NCHN,3)=1
38422 IF(JA.EQ.KFQEXC) ISIG(NCHN,3)=2
38423 IF(ISIG(NCHN,ISIG(NCHN,3)).GT.0) SIGH(NCHN)=FACQSB*BRPOS
38424 IF(ISIG(NCHN,ISIG(NCHN,3)).LT.0) SIGH(NCHN)=FACQSB*BRNEG
38425 ENDIF
38426 250 CONTINUE
38427 260 CONTINUE
38428
38429 ELSEIF(ISUB.EQ.169) THEN
38430C...q + qbar -> e + e* (excited lepton)
38431 KFQSTR=KFPR(ISUB,2)
38432 KCQSTR=PYCOMP(KFQSTR)
38433 KFQEXC=MOD(KFQSTR,KEXCIT)
38434 FACQSB=(COMFAC/12D0)*(SH/RTCM(41)**2)**2*(1D0-SQM4/SH)*
38435 & (1D0+SQM4/SH)*(1D0+CTH)*(1D0+((SH-SQM4)/(SH+SQM4))*CTH)
38436C...Propagators: as simulated in PYOFSH and as desired
38437 GMMQ=PMAS(KCQSTR,1)*PMAS(KCQSTR,2)
38438 HBW4=GMMQ/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQ**2)
38439 CALL PYWIDT(KFQSTR,SQM4,WDTP,WDTE)
38440 GMMQC=SQRT(SQM4)*WDTP(0)
38441 HBW4C=GMMQC/((SQM4-PMAS(KCQSTR,1)**2)**2+GMMQC**2)
38442 FACQSB=FACQSB*HBW4C/HBW4
38443C...Branching ratios.
38444 BRPOS=(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))/WDTP(0)
38445 BRNEG=(WDTE(0,1)+WDTE(0,3)+WDTE(0,4))/WDTP(0)
38446 DO 270 I=MMIN1,MMAX1
38447 IA=IABS(I)
38448 IF(I.EQ.0.OR.IA.GT.6.OR.KFAC(1,I).EQ.0) GOTO 270
38449 J=-I
38450 JA=IABS(J)
38451 IF(J.EQ.0.OR.JA.GT.6.OR.KFAC(2,J).EQ.0) GOTO 270
38452 NCHN=NCHN+1
38453 ISIG(NCHN,1)=I
38454 ISIG(NCHN,2)=J
38455 ISIG(NCHN,3)=1
38456 IF(I.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38457 IF(I.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38458 NCHN=NCHN+1
38459 ISIG(NCHN,1)=I
38460 ISIG(NCHN,2)=J
38461 ISIG(NCHN,3)=2
38462 IF(J.GT.0) SIGH(NCHN)=FACQSB*BRPOS
38463 IF(J.LT.0) SIGH(NCHN)=FACQSB*BRNEG
38464 270 CONTINUE
38465 ENDIF
38466
38467 ELSEIF(ISUB.LE.360) THEN
38468 IF(ISUB.EQ.341.OR.ISUB.EQ.342) THEN
38469C...l + l -> H_L++/-- or H_R++/--.
38470 KFRES=KFPR(ISUB,1)
38471 KFREC=PYCOMP(KFRES)
38472 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
38473 HS=SHR*WDTP(0)
38474 FACBW=8D0*COMFAC/((SH-PMAS(KFREC,1)**2)**2+HS**2)
38475 DO 290 I=MMIN1,MMAX1
38476 IA=IABS(I)
38477 IF((IA.NE.11.AND.IA.NE.13.AND.IA.NE.15).OR.KFAC(1,I).EQ.0)
38478 & GOTO 290
38479 DO 280 J=MMIN2,MMAX2
38480 JA=IABS(J)
38481 IF((JA.NE.11.AND.JA.NE.13.AND.JA.NE.15).OR.KFAC(2,J).EQ.0)
38482 & GOTO 280
38483 IF(I*J.LT.0) GOTO 280
38484 KCHH=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38485 NCHN=NCHN+1
38486 ISIG(NCHN,1)=I
38487 ISIG(NCHN,2)=J
38488 ISIG(NCHN,3)=1
38489 HI=SH*PARP(181+3*((IA-11)/2)+(JA-11)/2)**2/(8D0*PARU(1))
38490 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
38491 SIGH(NCHN)=HI*FACBW*HF
38492 280 CONTINUE
38493 290 CONTINUE
38494
38495 ELSEIF(ISUB.GE.343.AND.ISUB.LE.348) THEN
38496C...l + gamma -> H_L++/-- l' or l + gamma -> H_R++/-- l'.
38497 KFRES=KFPR(ISUB,1)
38498 KFREC=PYCOMP(KFRES)
38499C...Propagators: as simulated in PYOFSH and as desired
38500 HBW3=PMAS(KFREC,1)*PMAS(KFREC,2)/((SQM3-PMAS(KFREC,1)**2)**2+
38501 & (PMAS(KFREC,1)*PMAS(KFREC,2))**2)
38502 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
38503 GMMC=SQRT(SQM3)*WDTP(0)
38504 HBW3C=GMMC/((SQM3-PMAS(KFREC,1)**2)**2+GMMC**2)
38505 FHCC=COMFAC*AEM*HBW3C/HBW3
38506 DO 310 I=MMINA,MMAXA
38507 IA=IABS(I)
38508 IF(IA.NE.11.AND.IA.NE.13.AND.IA.NE.15) GOTO 310
38509 SQML=PMAS(IA,1)**2
38510 J=ISIGN(KFPR(ISUB,2),-I)
38511 KCHH=ISIGN(2,KCHG(IA,1)*ISIGN(1,I))
38512 WIDSC=(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))/WDTP(0)
38513 SMM1=8D0*(SH+TH-SQM3)*(SH+TH-2D0*SQM3-SQML-SQM4)/
38514 & (UH-SQM3)**2
38515 SMM2=2D0*((2D0*SQM3-3D0*SQML)*SQM4+(SQML-2D0*SQM4)*TH-
38516 & (TH-SQM4)*SH)/(TH-SQM4)**2
38517 SMM3=2D0*((2D0*SQM3-3D0*SQM4+TH)*SQML-(2D0*SQML-SQM4+TH)*
38518 & SH)/(SH-SQML)**2
38519 SMM12=4D0*((2D0*SQML-SQM4-2D0*SQM3+TH)*SH+(TH-3D0*SQM3-
38520 & 3D0*SQM4)*TH+(2D0*SQM3-2D0*SQML+3D0*SQM4)*SQM3)/
38521 & ((UH-SQM3)*(TH-SQM4))
38522 SMM13=-4D0*((TH+SQML-2D0*SQM4)*TH-(SQM3+3D0*SQML-2D0*SQM4)*
38523 & SQM3+(SQM3+3D0*SQML+TH)*SH-(TH-SQM3+SH)**2)/
38524 & ((UH-SQM3)*(SH-SQML))
38525 SMM23=-4D0*((SQML-SQM4+SQM3)*TH-SQM3**2+SQM3*(SQML+SQM4)-
38526 & 3D0*SQML*SQM4-(SQML-SQM4-SQM3+TH)*SH)/
38527 & ((SH-SQML)*(TH-SQM4))
38528 SMM=(SH/(SH-SQML))**2*(SMM1+SMM2+SMM3+SMM12+SMM13+SMM23)*
38529 & PARP(181+3*((IA-11)/2)+(IABS(J)-11)/2)**2/(4D0*PARU(1))
38530 DO 300 ISDE=1,2
38531 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,22).EQ.0) GOTO 300
38532 IF(ISDE.EQ.2.AND.KFAC(1,22)*KFAC(2,I).EQ.0) GOTO 300
38533 NCHN=NCHN+1
38534 ISIG(NCHN,ISDE)=I
38535 ISIG(NCHN,3-ISDE)=22
38536 ISIG(NCHN,3)=0
38537 SIGH(NCHN)=FHCC*SMM*WIDSC
38538 300 CONTINUE
38539 310 CONTINUE
38540
38541 ELSEIF(ISUB.EQ.349.OR.ISUB.EQ.350) THEN
38542C...f + fbar -> H_L++ + H_L-- or H_R++ + H_R--
38543 KFRES=KFPR(ISUB,1)
38544 KFREC=PYCOMP(KFRES)
38545 SQMH=PMAS(KFREC,1)**2
38546 GMMH=PMAS(KFREC,1)*PMAS(KFREC,2)
38547C...Propagators: H++/-- as simulated in PYOFSH and as desired
38548 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
38549 CALL PYWIDT(KFRES,SQM3,WDTP,WDTE)
38550 GMMH3=SQRT(SQM3)*WDTP(0)
38551 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
38552 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
38553 CALL PYWIDT(KFRES,SQM4,WDTP,WDTE)
38554 GMMH4=SQRT(SQM4)*WDTP(0)
38555 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
38556C...Kinematical and coupling functions
38557 FACHH=COMFAC*(HBW3C/HBW3)*(HBW4C/HBW4)*(TH*UH-SQM3*SQM4)
38558 XWHH=(1D0-2D0*XWV)/(8D0*XWV*(1D0-XWV))
38559C...Loop over allowed flavours
38560 DO 320 I=MMINA,MMAXA
38561 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 320
38562 EI=KCHG(IABS(I),1)/3D0
38563 AI=SIGN(1D0,EI+0.1D0)
38564 VI=AI-4D0*EI*XWV
38565 FCOI=1D0
38566 IF(IABS(I).LE.10) FCOI=FACA/3D0
38567 IF(ISUB.EQ.349) THEN
38568 HBWZ=1D0/((SH-SQMZ)**2+GMMZ**2)
38569 IF(IABS(I).LT.10) THEN
38570 DSIGHH=8D0*AEM**2*(EI**2/SH2+
38571 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
38572 & (VI**2+AI**2)*XWHH**2*HBWZ)
38573 ELSE
38574 IAOFF=181+3*((IABS(I)-11)/2)
38575 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
38576 & (4D0*PARU(1))
38577 DSIGHH=8D0*AEM**2*(EI**2/SH2+
38578 & 2D0*EI*VI*XWHH*(SH-SQMZ)*HBWZ/SH+
38579 & (VI**2+AI**2)*XWHH**2*HBWZ)+
38580 & 8D0*AEM*(EI*HSUM/(SH*TH)+
38581 & (VI+AI)*XWHH*HSUM*(SH-SQMZ)*HBWZ/TH)+
38582 & 4D0*HSUM**2/TH2
38583 ENDIF
38584 ELSE
38585 IF(IABS(I).LT.10) THEN
38586 DSIGHH=8D0*AEM**2*EI**2/SH2
38587 ELSE
38588 IAOFF=181+3*((IABS(I)-11)/2)
38589 HSUM=(PARP(IAOFF)**2+PARP(IAOFF+1)**2+PARP(IAOFF+2)**2)/
38590 & (4D0*PARU(1))
38591 DSIGHH=8D0*AEM**2*EI**2/SH2+8D0*AEM*EI*HSUM/(SH*TH)+
38592 & 4D0*HSUM**2/TH2
38593 ENDIF
38594 ENDIF
38595 NCHN=NCHN+1
38596 ISIG(NCHN,1)=I
38597 ISIG(NCHN,2)=-I
38598 ISIG(NCHN,3)=1
38599 SIGH(NCHN)=FACHH*FCOI*DSIGHH
38600 320 CONTINUE
38601
38602 ELSEIF(ISUB.EQ.351.OR.ISUB.EQ.352) THEN
38603C...f + f' -> f" + f"' + H++/-- (W+/- + W+/- -> H++/-- as inner process)
38604 KFRES=KFPR(ISUB,1)
38605 KFREC=PYCOMP(KFRES)
38606 SQMH=PMAS(KFREC,1)**2
38607 IF(ISUB.EQ.351) FACNOR=PARP(190)**8*PARP(192)**2
38608 IF(ISUB.EQ.352) FACNOR=PARP(191)**6*2D0*
38609 & PMAS(PYCOMP(9900024),1)**2
38610 FACWW=COMFAC*FACNOR*TAUP*VINT(2)*VINT(219)
38611 FACPRT=1D0/((VINT(204)**2-VINT(215))*
38612 & (VINT(209)**2-VINT(216)))
38613 FACPRU=1D0/((VINT(204)**2+2D0*VINT(217))*
38614 & (VINT(209)**2+2D0*VINT(218)))
38615 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
38616 HS=SHR*WDTP(0)
38617 FACBW=(1D0/PARU(1))*VINT(2)/((SH-SQMH)**2+HS**2)
38618 IF(ABS(SHR-PMAS(KFREC,1)).GT.PARP(48)*PMAS(KFREC,2))
38619 & FACBW=0D0
38620 DO 340 I=MMIN1,MMAX1
38621 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 340
38622 IF(ISUB.EQ.352.AND.IABS(I).GT.10) GOTO 340
38623 KCHWI=(1-2*MOD(IABS(I),2))*ISIGN(1,I)
38624 DO 330 J=MMIN2,MMAX2
38625 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 330
38626 IF(ISUB.EQ.352.AND.IABS(J).GT.10) GOTO 330
38627 KCHWJ=(1-2*MOD(IABS(J),2))*ISIGN(1,J)
38628 KCHH=KCHWI+KCHWJ
38629 IF(IABS(KCHH).NE.2) GOTO 330
38630 FACLR=VINT(180+I)*VINT(180+J)
38631 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHH/2)/2)+WDTE(0,4))
38632 IF(I.EQ.J.AND.IABS(I).GT.10) THEN
38633 FACPRP=0.5D0*(FACPRT+FACPRU)**2
38634 ELSE
38635 FACPRP=FACPRT**2
38636 ENDIF
38637 NCHN=NCHN+1
38638 ISIG(NCHN,1)=I
38639 ISIG(NCHN,2)=J
38640 ISIG(NCHN,3)=1
38641 SIGH(NCHN)=FACLR*FACWW*FACPRP*FACBW*HF
38642 330 CONTINUE
38643 340 CONTINUE
38644
38645 ELSEIF(ISUB.EQ.353) THEN
38646C...f + fbar -> Z_R0
38647 SQMZR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
38648 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
38649 HS=SHR*WDTP(0)
38650 FACBW=4D0*COMFAC/((SH-SQMZR)**2+HS**2)*3D0
38651 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38652 HP=(AEM/(3D0*(1D0-2D0*XW)))*XWC*SH
38653 DO 350 I=MMINA,MMAXA
38654 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 350
38655 IF(IABS(I).LE.8) THEN
38656 EI=KCHG(IABS(I),1)/3D0
38657 AI=SIGN(1D0,EI+0.1D0)*(1D0-2D0*XW)
38658 VI=SIGN(1D0,EI+0.1D0)-4D0*EI*XW
38659 ELSE
38660 AI=-(1D0-2D0*XW)
38661 VI=-1D0+4D0*XW
38662 ENDIF
38663 HI=HP*(VI**2+AI**2)
38664 IF(IABS(I).LE.10) HI=HI*FACA/3D0
38665 NCHN=NCHN+1
38666 ISIG(NCHN,1)=I
38667 ISIG(NCHN,2)=-I
38668 ISIG(NCHN,3)=1
38669 SIGH(NCHN)=HI*FACBW*HF
38670 350 CONTINUE
38671
38672 ELSEIF(ISUB.EQ.354) THEN
38673C...f + fbar' -> W_R+/-
38674 SQMWR=PMAS(PYCOMP(KFPR(ISUB,1)),1)**2
38675 CALL PYWIDT(KFPR(ISUB,1),SH,WDTP,WDTE)
38676 HS=SHR*WDTP(0)
38677 FACBW=4D0*COMFAC/((SH-SQMWR)**2+HS**2)*3D0
38678 HP=AEM/(24D0*XW)*SH
38679 DO 370 I=MMIN1,MMAX1
38680 IF(I.EQ.0.OR.KFAC(1,I).EQ.0) GOTO 370
38681 IA=IABS(I)
38682 DO 360 J=MMIN2,MMAX2
38683 IF(J.EQ.0.OR.KFAC(2,J).EQ.0) GOTO 360
38684 JA=IABS(J)
38685 IF(I*J.GT.0.OR.MOD(IA+JA,2).EQ.0) GOTO 360
38686 IF((IA.LE.10.AND.JA.GT.10).OR.(IA.GT.10.AND.JA.LE.10))
38687 & GOTO 360
38688 KCHW=(KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J))/3
38689 HI=HP*2D0
38690 IF(IA.LE.10) HI=HI*VCKM((IA+1)/2,(JA+1)/2)*FACA/3D0
38691 NCHN=NCHN+1
38692 ISIG(NCHN,1)=I
38693 ISIG(NCHN,2)=J
38694 ISIG(NCHN,3)=1
38695 HF=SHR*(WDTE(0,1)+WDTE(0,(5-KCHW)/2)+WDTE(0,4))
38696 SIGH(NCHN)=HI*FACBW*HF
38697 360 CONTINUE
38698 370 CONTINUE
38699 ENDIF
38700
38701 ELSEIF(ISUB.LE.400) THEN
38702 IF(ISUB.EQ.391) THEN
38703C...f + fbar -> G*.
38704 KFGSTR=KFPR(ISUB,1)
38705 KCGSTR=PYCOMP(KFGSTR)
38706 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38707 HS=SHR*WDTP(0)
38708 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38709 FACG=COMFAC*PARP(50)**2/(16D0*PARU(1))*SH*HF/
38710 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38711C...Modify cross section in wings of peak.
38712 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38713 DO 380 I=MMINA,MMAXA
38714 IF(I.EQ.0.OR.KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 380
38715 HI=1D0
38716 IF(IABS(I).LE.10) HI=HI*FACA/3D0
38717 NCHN=NCHN+1
38718 ISIG(NCHN,1)=I
38719 ISIG(NCHN,2)=-I
38720 ISIG(NCHN,3)=1
38721 SIGH(NCHN)=FACG*HI
38722 380 CONTINUE
38723
38724 ELSEIF(ISUB.EQ.392) THEN
38725C...g + g -> G*.
38726 KFGSTR=KFPR(ISUB,1)
38727 KCGSTR=PYCOMP(KFGSTR)
38728 CALL PYWIDT(KFGSTR,SH,WDTP,WDTE)
38729 HS=SHR*WDTP(0)
38730 HF=SHR*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38731 FACG=COMFAC*PARP(50)**2/(32D0*PARU(1))*SH*HF/
38732 & ((SH-PMAS(KCGSTR,1)**2)**2+HS**2)
38733C...Modify cross section in wings of peak.
38734 FACG = FACG * SH**2 / PMAS(KCGSTR,1)**4
38735 IF(KFAC(1,21)*KFAC(2,21).EQ.0) GOTO 390
38736 NCHN=NCHN+1
38737 ISIG(NCHN,1)=21
38738 ISIG(NCHN,2)=21
38739 ISIG(NCHN,3)=1
38740 SIGH(NCHN)=FACG
38741 390 CONTINUE
38742
38743 ELSEIF(ISUB.EQ.393) THEN
38744C...q + qbar -> g + G*.
38745 KFGSTR=KFPR(ISUB,2)
38746 KCGSTR=PYCOMP(KFGSTR)
38747 FACG=COMFAC*PARP(50)**2*AS*SH/(72D0*PARU(1)*SQM4)*
38748 & (4D0*(TH2+UH2)/SH2+9D0*(TH+UH)/SH+(TH2/UH+UH2/TH)/SH+
38749 & 3D0*(4D0+TH/UH+UH/TH)+4D0*(SH/UH+SH/TH)+
38750 & 2D0*SH2/(TH*UH))
38751C...Propagators: as simulated in PYOFSH and as desired
38752 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38753 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38754 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38755 HS=SQRT(SQM4)*WDTP(0)
38756 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38757 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38758 FACG=FACG*HBW4C/HBW4
38759 DO 400 I=MMINA,MMAXA
38760 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
38761 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 400
38762 NCHN=NCHN+1
38763 ISIG(NCHN,1)=I
38764 ISIG(NCHN,2)=-I
38765 ISIG(NCHN,3)=1
38766 SIGH(NCHN)=FACG
38767 400 CONTINUE
38768
38769 ELSEIF(ISUB.EQ.394) THEN
38770C...q + g -> q + G*.
38771 KFGSTR=KFPR(ISUB,2)
38772 KCGSTR=PYCOMP(KFGSTR)
38773 FACG=-COMFAC*PARP(50)**2*AS*SH/(192D0*PARU(1)*SQM4)*
38774 & (4D0*(SH2+UH2)/(TH*SH)+9D0*(SH+UH)/SH+SH/UH+UH2/SH2+
38775 & 3D0*TH*(4D0+SH/UH+UH/SH)/SH+4D0*TH2*(1D0/UH+1D0/SH)/SH+
38776 & 2D0*TH2*TH/(UH*SH2))
38777C...Propagators: as simulated in PYOFSH and as desired
38778 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38779 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38780 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38781 HS=SQRT(SQM4)*WDTP(0)
38782 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38783 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38784 FACG=FACG*HBW4C/HBW4
38785 DO 420 I=MMINA,MMAXA
38786 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58)) GOTO 420
38787 DO 410 ISDE=1,2
38788 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 410
38789 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 410
38790 NCHN=NCHN+1
38791 ISIG(NCHN,ISDE)=I
38792 ISIG(NCHN,3-ISDE)=21
38793 ISIG(NCHN,3)=1
38794 SIGH(NCHN)=FACG
38795 410 CONTINUE
38796 420 CONTINUE
38797
38798 ELSEIF(ISUB.EQ.395) THEN
38799C...g + g -> g + G*.
38800 KFGSTR=KFPR(ISUB,2)
38801 KCGSTR=PYCOMP(KFGSTR)
38802 FACG=COMFAC*3D0*PARP(50)**2*AS*SH/(32D0*PARU(1)*SQM4)*
38803 & ((TH2+TH*UH+UH2)**2/(SH2*TH*UH)+2D0*(TH2/UH+UH2/TH)/SH+
38804 & 3D0*(TH/UH+UH/TH)+2D0*(SH/UH+SH/TH)+SH2/(TH*UH))
38805C...Propagators: as simulated in PYOFSH and as desired
38806 GMMG=PMAS(KCGSTR,1)*PMAS(KCGSTR,2)
38807 HBW4=GMMG/((SQM4-PMAS(KCGSTR,1)**2)**2+GMMG**2)
38808 CALL PYWIDT(KFGSTR,SQM4,WDTP,WDTE)
38809 HS=SQRT(SQM4)*WDTP(0)
38810 HF=SQRT(SQM4)*(WDTE(0,1)+WDTE(0,2)+WDTE(0,4))
38811 HBW4C=HF/((SQM4-PMAS(KCGSTR,1)**2)**2+HS**2)
38812 FACG=FACG*HBW4C/HBW4
38813 IF(KFAC(1,21)*KFAC(2,21).NE.0) THEN
38814 NCHN=NCHN+1
38815 ISIG(NCHN,1)=21
38816 ISIG(NCHN,2)=21
38817 ISIG(NCHN,3)=1
38818 SIGH(NCHN)=FACG
38819 ENDIF
38820 ENDIF
38821 ELSEIF(ISUB.LE.500) THEN
38822 IF(ISUBSV.EQ.481) ISUB=482
38823c... GENERIC 2->(1)->2
38824 IF(ISUB.EQ.482) THEN
38825 KFRES=9900001
38826 KCRES=PYCOMP(KFRES)
38827 IF(KCRES.EQ.0) RETURN
38828 IDCY=MDCY(KCRES,2)
38829 KCOL=KCHG(KCRES,2)
38830 KCEM=KCHG(KCRES,1)
38831 FACT=COMFAC
38832 KCF1=PYCOMP(KFPR(ISUB,1))
38833 KCF2=PYCOMP(KFPR(ISUB,2))
38834 IF(ISUBSV.EQ.481) THEN
38835 SQMZR=PMAS(KCRES,1)**2
38836 CALL PYWIDT(KFRES,SH,WDTP,WDTE)
38837 HS=SHR*WDTP(0)
38838 FACBW=SH2/((SH-SQMZR)**2+HS**2)
38839 FACT=FACT*FACBW
38840 ELSE
38841 SQMH=PMAS(KCF1,1)**2
38842 GMMH=PMAS(KCF1,1)*PMAS(KCF1,2)
38843C...Propagators: as simulated in PYOFSH and as desired
38844 HBW3=GMMH/((SQM3-SQMH)**2+GMMH**2)
38845 CALL PYWIDT(KFPR(ISUB,1),SQM3,WDTP,WDTE)
38846 GMMH3=SQRT(SQM3)*WDTP(0)
38847 HBW3C=GMMH3/((SQM3-SQMH)**2+GMMH3**2)
38848 SQMH=PMAS(KCF2,1)**2
38849 GMMH=PMAS(KCF2,1)*PMAS(KCF2,2)
38850 HBW4=GMMH/((SQM4-SQMH)**2+GMMH**2)
38851 CALL PYWIDT(KFPR(ISUB,2),SQM4,WDTP,WDTE)
38852 GMMH4=SQRT(SQM4)*WDTP(0)
38853 HBW4C=GMMH4/((SQM4-SQMH)**2+GMMH4**2)
38854 FACT=FACT*(HBW3C/HBW3)*(HBW4C/HBW4)
38855 ENDIF
38856
38857 KCI1=ABS(PYCOMP(KFDP(IDCY,1)))
38858 KCI2=ABS(PYCOMP(KFDP(IDCY,2)))
38859 JCOL1=SIGN(KCHG(KCF1,2),KFPR(ISUB,1))
38860 JCOL2=SIGN(KCHG(KCF2,2),KFPR(ISUB,2))
38861 IF(KCOL.EQ.0) THEN
38862 NCOL=1
38863 ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.KCOL.EQ.2) THEN
38864 IF(JCOL1.EQ.2.AND.JCOL2.EQ.2) THEN
38865 NCOL=3
38866 ELSE
38867 NCOL=2
38868 ENDIF
38869 ELSEIF(KCOL.EQ.-1.OR.KCOL.EQ.1) THEN
38870 NCOL=2
38871 ELSEIF(KCI1.EQ.21.AND.KCI2.EQ.21.AND.JCOL1.EQ.0.AND.
38872 $ JCOL2.EQ.0) THEN
38873 NCOL=1
38874 ELSEIF(KCOL.EQ.2.AND.((JCOL1.EQ.0.AND.JCOL2.EQ.2).OR.
38875 $ (JCOL1.EQ.2.AND.JCOL2.EQ.0))) THEN
38876 NCOL=1
38877 ELSE
38878 NCOL=2
38879 ENDIF
38880 DO 440 I=MMIN1,MMAX1
38881 IF(KFAC(1,I).EQ.0) GOTO 440
38882 IP=I
38883 IF(IP.EQ.0) IP=21
38884 IA=ABS(IP)
38885 DO 430 J=MMIN2,MMAX2
38886 IF(KFAC(2,J).EQ.0) GOTO 430
38887 JP=J
38888 IF(JP.EQ.0) JP=21
38889 JA=ABS(JP)
38890 IF((IA.EQ.KCI1.AND.JA.EQ.KCI2).OR.
38891 $ (JA.EQ.KCI1.AND.IA.EQ.KCI2)) THEN
38892 KCHW=KCHG(IA,1)*ISIGN(1,I)+KCHG(JA,1)*ISIGN(1,J)
38893 IF(ABS(KCHW).EQ.ABS(KCEM)) THEN
38894 DO II=1,NCOL
38895 NCHN=NCHN+1
38896 ISIG(NCHN,1)=IP
38897 ISIG(NCHN,2)=JP
38898 ISIG(NCHN,3)=II
38899 SIGH(NCHN)=FACT/NCOL
38900 ENDDO
38901 ENDIF
38902 ENDIF
38903 430 CONTINUE
38904 440 CONTINUE
38905 ENDIF
38906 ENDIF
38907
38908 RETURN
38909 END
38910
38911C*********************************************************************
38912
38913C...PYPDFU
38914C...Gives electron, muon, tau, photon, pi+, neutron, proton and hyperon
38915C...parton distributions according to a few different parametrizations.
38916C...Note that what is coded is x times the probability distribution,
38917C...i.e. xq(x,Q2) etc.
38918
38919 SUBROUTINE PYPDFU(KF,X,Q2,XPQ)
38920
38921C...Double precision and integer declarations.
38922 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
38923 IMPLICIT INTEGER(I-N)
38924 INTEGER PYK,PYCHGE,PYCOMP
38925C...Commonblocks.
38926 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
38927 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
38928 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
38929 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
38930 COMMON/PYINT1/MINT(400),VINT(400)
38931 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
38932 &XPDIR(-6:6)
38933 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
38934 COMMON/PYINTM/KFIVAL(2,3),NMI(2),IMI(2,800,2),NVC(2,-6:6),
38935 & XASSOC(2,-6:6,240),XPSVC(-6:6,-1:240),PVCTOT(2,-1:1),
38936 & XMI(2,240),PT2MI(240),IMISEP(0:240)
38937 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT8/,
38938 &/PYINT9/,/PYINTM/
38939C...Local arrays.
38940 DIMENSION XPQ(-25:25),XPEL(-25:25),XPGA(-6:6),VXPGA(-6:6),
38941 &XPPI(-6:6),XPPR(-6:6),XPVAL(-6:6),PPAR(6,2)
38942 SAVE PPAR
38943
38944C...Interface to PDFLIB.
38945 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
38946 SAVE /W50513/
38947 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
38948 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
38949 CHARACTER*20 PARM(20)
38950 DATA VALUE/20*0D0/,PARM/20*' '/
38951
38952C...Data related to Schuler-Sjostrand photon distributions.
38953 DATA ALAMGA/0.2D0/, PMCGA/1.3D0/, PMBGA/4.6D0/
38954
38955C...Valence PDF momentum integral parametrizations PER PARTON!
38956 DATA (PPAR(1,IPAR),IPAR=1,2) /0.385D0,1.60D0/
38957 DATA (PPAR(2,IPAR),IPAR=1,2) /0.480D0,1.56D0/
38958 PAVG(IFL,Q2)=PPAR(IFL,1)/(1D0+PPAR(IFL,2)*
38959 &LOG(LOG(MAX(Q2,1D0)/0.04D0)))
38960
38961C...Reset parton distributions.
38962 MINT(92)=0
38963 DO 100 KFL=-25,25
38964 XPQ(KFL)=0D0
38965 100 CONTINUE
38966 DO 110 KFL=-6,6
38967 XPVAL(KFL)=0D0
38968 110 CONTINUE
38969
38970C...Check x and particle species.
38971 IF(X.LE.0D0.OR.X.GE.1D0) THEN
38972 WRITE(MSTU(11),5000) X
38973 GOTO 9999
38974 ENDIF
38975 KFA=IABS(KF)
38976 IF(KFA.NE.11.AND.KFA.NE.13.AND.KFA.NE.15.AND.KFA.NE.22.AND.
38977 &KFA.NE.211.AND.KFA.NE.2112.AND.KFA.NE.2212.AND.KFA.NE.3122.AND.
38978 &KFA.NE.3112.AND.KFA.NE.3212.AND.KFA.NE.3222.AND.KFA.NE.3312.AND.
38979 &KFA.NE.3322.AND.KFA.NE.3334.AND.KFA.NE.111.AND.KFA.NE.321.AND.
38980 &KFA.NE.310.AND.KFA.NE.130) THEN
38981 WRITE(MSTU(11),5100) KF
38982 GOTO 9999
38983 ENDIF
38984
38985C...Electron (or muon or tau) parton distribution call.
38986 IF(KFA.EQ.11.OR.KFA.EQ.13.OR.KFA.EQ.15) THEN
38987 CALL PYPDEL(KFA,X,Q2,XPEL)
38988 DO 120 KFL=-25,25
38989 XPQ(KFL)=XPEL(KFL)
38990 120 CONTINUE
38991
38992C...Photon parton distribution call (VDM+anomalous).
38993 ELSEIF(KFA.EQ.22.AND.MINT(109).LE.1) THEN
38994 IF(MSTP(56).EQ.1.AND.MSTP(55).EQ.1) THEN
38995 CALL PYPDGA(X,Q2,XPGA)
38996 DO 130 KFL=-6,6
38997 XPQ(KFL)=XPGA(KFL)
38998 130 CONTINUE
38999 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
39000 XPVAL(1)=XPVU/4D0
39001 XPVAL(2)=XPVU
39002 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
39003 XPVAL(4)=MIN(XPQ(4),XPVU)
39004 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
39005 XPVAL(-1)=XPVAL(1)
39006 XPVAL(-2)=XPVAL(2)
39007 XPVAL(-3)=XPVAL(3)
39008 XPVAL(-4)=XPVAL(4)
39009 XPVAL(-5)=XPVAL(5)
39010 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
39011 Q2MX=Q2
39012 P2MX=0.36D0
39013 IF(MSTP(55).GE.7) P2MX=4.0D0
39014 IF(MSTP(57).EQ.0) Q2MX=P2MX
39015 P2=0D0
39016 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39017 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39018 DO 140 KFL=-6,6
39019 XPQ(KFL)=XPGA(KFL)
39020 XPVAL(KFL)=VXPDGM(KFL)
39021 140 CONTINUE
39022 VINT(231)=P2MX
39023 ELSEIF(MSTP(56).EQ.1.AND.MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
39024 Q2MX=Q2
39025 P2MX=0.36D0
39026 IF(MSTP(55).GE.11) P2MX=4.0D0
39027 IF(MSTP(57).EQ.0) Q2MX=P2MX
39028 P2=0D0
39029 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39030 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39031 DO 150 KFL=-6,6
39032 XPQ(KFL)=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
39033 XPVAL(KFL)=VXPVMD(KFL)+VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
39034 150 CONTINUE
39035 VINT(231)=P2MX
39036 ELSEIF(MSTP(56).EQ.2) THEN
39037C...Call PDFLIB parton distributions.
39038 PARM(1)='NPTYPE'
39039 VALUE(1)=3
39040 PARM(2)='NGROUP'
39041 VALUE(2)=MSTP(55)/1000
39042 PARM(3)='NSET'
39043 VALUE(3)=MOD(MSTP(55),1000)
39044 IF(MINT(93).NE.3000000+MSTP(55)) THEN
39045 CALL PDFSET_ALICE(PARM,VALUE)
39046 MINT(93)=3000000+MSTP(55)
39047 ENDIF
39048 XX=X
39049 QQ2=MAX(0D0,Q2MIN,Q2)
39050 IF(MSTP(57).EQ.0) QQ2=Q2MIN
39051 P2=0D0
39052 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39053 IP2=MSTP(60)
39054 IF(MSTP(55).EQ.5004) THEN
39055 IF(5D0*P2.LT.QQ2.AND.
39056 & QQ2.GT.0.6D0.AND.QQ2.LT.5D4.AND.
39057 & P2.GE.0D0.AND.P2.LT.10D0.AND.
39058 & XX.GT.1D-4.AND.XX.LT.1D0) THEN
39059 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
39060 & BOT,TOP,GLU)
39061 ELSE
39062 UPV=0D0
39063 DNV=0D0
39064 USEA=0D0
39065 DSEA=0D0
39066 STR=0D0
39067 CHM=0D0
39068 BOT=0D0
39069 TOP=0D0
39070 GLU=0D0
39071 ENDIF
39072 ELSE
39073 IF(P2.LT.QQ2) THEN
39074 CALL STRUCTP(XX,QQ2,P2,IP2,UPV,DNV,USEA,DSEA,STR,CHM,
39075 & BOT,TOP,GLU)
39076 ELSE
39077 UPV=0D0
39078 DNV=0D0
39079 USEA=0D0
39080 DSEA=0D0
39081 STR=0D0
39082 CHM=0D0
39083 BOT=0D0
39084 TOP=0D0
39085 GLU=0D0
39086 ENDIF
39087 ENDIF
39088 VINT(231)=Q2MIN
39089 XPQ(0)=GLU
39090 XPQ(1)=DNV
39091 XPQ(-1)=DNV
39092 XPQ(2)=UPV
39093 XPQ(-2)=UPV
39094 XPQ(3)=STR
39095 XPQ(-3)=STR
39096 XPQ(4)=CHM
39097 XPQ(-4)=CHM
39098 XPQ(5)=BOT
39099 XPQ(-5)=BOT
39100 XPQ(6)=TOP
39101 XPQ(-6)=TOP
39102 XPVU=4D0*(XPQ(2)-XPQ(1))/3D0
39103 XPVAL(1)=XPVU/4D0
39104 XPVAL(2)=XPVU
39105 XPVAL(3)=MIN(XPQ(3),XPVU/4D0)
39106 XPVAL(4)=MIN(XPQ(4),XPVU)
39107 XPVAL(5)=MIN(XPQ(5),XPVU/4D0)
39108 XPVAL(-1)=XPVAL(1)
39109 XPVAL(-2)=XPVAL(2)
39110 XPVAL(-3)=XPVAL(3)
39111 XPVAL(-4)=XPVAL(4)
39112 XPVAL(-5)=XPVAL(5)
39113 ELSE
39114 WRITE(MSTU(11),5200) KF,MSTP(56),MSTP(55)
39115 ENDIF
39116
39117C...Pion/gammaVDM parton distribution call.
39118 ELSEIF(KFA.EQ.211.OR.KFA.EQ.111.OR.KFA.EQ.321.OR.KFA.EQ.130.OR.
39119 &KFA.EQ.310.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
39120 IF(KFA.EQ.22.AND.MSTP(56).EQ.1.AND.MSTP(55).GE.5.AND.
39121 & MSTP(55).LE.12) THEN
39122 ISET=1+MOD(MSTP(55)-1,4)
39123 Q2MX=Q2
39124 P2MX=0.36D0
39125 IF(ISET.GE.3) P2MX=4.0D0
39126 IF(MSTP(57).EQ.0) Q2MX=P2MX
39127 P2=0D0
39128 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39129 CALL PYGGAM(ISET,X,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39130 DO 160 KFL=-6,6
39131 XPQ(KFL)=XPVMD(KFL)
39132 XPVAL(KFL)=VXPVMD(KFL)
39133 160 CONTINUE
39134 VINT(231)=P2MX
39135 ELSEIF(MSTP(54).EQ.1.AND.MSTP(53).GE.1.AND.MSTP(53).LE.3) THEN
39136 CALL PYPDPI(X,Q2,XPPI)
39137 DO 170 KFL=-6,6
39138 XPQ(KFL)=XPPI(KFL)
39139 170 CONTINUE
39140 XPVAL(2)=XPQ(2)-XPQ(-2)
39141 XPVAL(-1)=XPQ(-1)-XPQ(1)
39142 ELSEIF(MSTP(54).EQ.2) THEN
39143C...Call PDFLIB parton distributions.
39144 PARM(1)='NPTYPE'
39145 VALUE(1)=2
39146 PARM(2)='NGROUP'
39147 VALUE(2)=MSTP(53)/1000
39148 PARM(3)='NSET'
39149 VALUE(3)=MOD(MSTP(53),1000)
39150 IF(MINT(93).NE.2000000+MSTP(53)) THEN
39151 CALL PDFSET_ALICE(PARM,VALUE)
39152 MINT(93)=2000000+MSTP(53)
39153 ENDIF
39154 XX=X
39155 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39156 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39157 CALL STRUCTM_ALICE(XX,QQ,UPV,DNV,USEA,
39158 + DSEA,STR,CHM,BOT,TOP,GLU)
39159 VINT(231)=Q2MIN
39160 XPQ(0)=GLU
39161 XPQ(1)=DSEA
39162 XPQ(-1)=UPV+DSEA
39163 XPQ(2)=UPV+USEA
39164 XPQ(-2)=USEA
39165 XPQ(3)=STR
39166 XPQ(-3)=STR
39167 XPQ(4)=CHM
39168 XPQ(-4)=CHM
39169 XPQ(5)=BOT
39170 XPQ(-5)=BOT
39171 XPQ(6)=TOP
39172 XPQ(-6)=TOP
39173 XPVAL(2)=UPV
39174 XPVAL(-1)=UPV
39175 ELSE
39176 WRITE(MSTU(11),5200) KF,MSTP(54),MSTP(53)
39177 ENDIF
39178
39179C...Anomalous photon parton distribution call.
39180 ELSEIF(KFA.EQ.22.AND.MINT(109).EQ.3) THEN
39181 Q2MX=Q2
39182 P2MX=PARP(15)**2
39183 IF(MSTP(56).EQ.1.AND.MSTP(55).LE.8) THEN
39184 IF(MSTP(55).EQ.5.OR.MSTP(55).EQ.6) P2MX=0.36D0
39185 IF(MSTP(55).EQ.7.OR.MSTP(55).EQ.8) P2MX=4.0D0
39186 IF(MSTP(57).EQ.0) Q2MX=P2MX
39187 P2=0D0
39188 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39189 CALL PYGGAM(MSTP(55)-4,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
39190 DO 180 KFL=-6,6
39191 XPQ(KFL)=XPANL(KFL)+XPANH(KFL)
39192 XPVAL(KFL)=VXPANL(KFL)+VXPANH(KFL)
39193 180 CONTINUE
39194 VINT(231)=P2MX
39195 ELSEIF(MSTP(56).EQ.1) THEN
39196 IF(MSTP(55).EQ.9.OR.MSTP(55).EQ.10) P2MX=0.36D0
39197 IF(MSTP(55).EQ.11.OR.MSTP(55).EQ.12) P2MX=4.0D0
39198 IF(MSTP(57).EQ.0) Q2MX=P2MX
39199 P2=0D0
39200 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39201 CALL PYGGAM(MSTP(55)-8,X,Q2MX,P2,MSTP(60),F2GM,XPGA)
39202 DO 190 KFL=-6,6
39203 XPQ(KFL)=MAX(0D0,XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
39204 XPVAL(KFL)=MAX(0D0,VXPANL(KFL)+XPBEH(KFL)+XPDIR(KFL))
39205 190 CONTINUE
39206 VINT(231)=P2MX
39207 ELSEIF(MSTP(56).EQ.2) THEN
39208 IF(MSTP(57).EQ.0) Q2MX=P2MX
39209 CALL PYGANO(0,X,Q2MX,P2MX,ALAMGA,XPGA,VXPGA)
39210 DO 200 KFL=-6,6
39211 XPQ(KFL)=XPGA(KFL)
39212 XPVAL(KFL)=VXPGA(KFL)
39213 200 CONTINUE
39214 VINT(231)=P2MX
39215 ELSEIF(MSTP(55).GE.1.AND.MSTP(55).LE.5) THEN
39216 IF(MSTP(57).EQ.0) Q2MX=P2MX
39217 CALL PYGVMD(0,MSTP(55),X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
39218 DO 210 KFL=-6,6
39219 XPQ(KFL)=XPGA(KFL)
39220 XPVAL(KFL)=VXPGA(KFL)
39221 210 CONTINUE
39222 VINT(231)=P2MX
39223 ELSE
39224 220 RKF=11D0*PYR(0)
39225 KFR=1
39226 IF(RKF.GT.1D0) KFR=2
39227 IF(RKF.GT.5D0) KFR=3
39228 IF(RKF.GT.6D0) KFR=4
39229 IF(RKF.GT.10D0) KFR=5
39230 IF(KFR.EQ.4.AND.Q2.LT.PMCGA**2) GOTO 220
39231 IF(KFR.EQ.5.AND.Q2.LT.PMBGA**2) GOTO 220
39232 IF(MSTP(57).EQ.0) Q2MX=P2MX
39233 CALL PYGVMD(0,KFR,X,Q2MX,P2MX,PARP(1),XPGA,VXPGA)
39234 DO 230 KFL=-6,6
39235 XPQ(KFL)=XPGA(KFL)
39236 XPVAL(KFL)=VXPGA(KFL)
39237 230 CONTINUE
39238 VINT(231)=P2MX
39239 ENDIF
39240
39241C...Proton parton distribution call.
39242 ELSE
39243 IF(MSTP(52).EQ.1.AND.MSTP(51).GE.1.AND.MSTP(51).LE.20) THEN
39244 CALL PYPDPR(X,Q2,XPPR)
39245 DO 240 KFL=-6,6
39246 XPQ(KFL)=XPPR(KFL)
39247 240 CONTINUE
39248C...Force VAL > 0 (can be < 0 at very small Q2 and small x apparently)
39249 XPVAL(1)=MAX(0D0,XPQ(1)-XPQ(-1))
39250 XPVAL(2)=MAX(0D0,XPQ(2)-XPQ(-2))
39251 ELSEIF(MSTP(52).EQ.2) THEN
39252C...Call PDFLIB parton distributions.
39253 PARM(1)='NPTYPE'
39254 VALUE(1)=1
39255 PARM(2)='NGROUP'
39256 VALUE(2)=MSTP(51)/1000
39257 PARM(3)='NSET'
39258 VALUE(3)=MOD(MSTP(51),1000)
39259 IF(MINT(93).NE.1000000+MSTP(51)) THEN
39260 CALL PDFSET_ALICE(PARM,VALUE)
39261 MINT(93)=1000000+MSTP(51)
39262 ENDIF
39263 XX=X
39264 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39265 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39266 CALL STRUCTM_ALICE(XX,QQ,UPV,DNV,USEA,
39267 + DSEA,STR,CHM,BOT,TOP,GLU)
39268 VINT(231)=Q2MIN
39269 XPQ(0)=GLU
39270 XPQ(1)=DNV+DSEA
39271 XPQ(-1)=DSEA
39272 XPQ(2)=UPV+USEA
39273 XPQ(-2)=USEA
39274 XPQ(3)=STR
39275 XPQ(-3)=STR
39276 XPQ(4)=CHM
39277 XPQ(-4)=CHM
39278 XPQ(5)=BOT
39279 XPQ(-5)=BOT
39280 XPQ(6)=TOP
39281 XPQ(-6)=TOP
39282 XPVAL(1)=DNV
39283 XPVAL(2)=UPV
39284 ELSE
39285 WRITE(MSTU(11),5200) KF,MSTP(52),MSTP(51)
39286 ENDIF
39287 ENDIF
39288
39289C...Isospin average for pi0/gammaVDM.
39290 IF(KFA.EQ.111.OR.(KFA.EQ.22.AND.MINT(109).EQ.2)) THEN
39291 IF(KFA.EQ.22.AND.MSTP(55).GE.5.AND.MSTP(55).LE.12) THEN
39292 XPV=XPQ(2)-XPQ(1)
39293 XPQ(2)=XPQ(1)
39294 XPQ(-2)=XPQ(-1)
39295 ELSE
39296 XPS=0.5D0*(XPQ(1)+XPQ(-2))
39297 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
39298 XPQ(2)=XPS
39299 XPQ(-1)=XPS
39300 ENDIF
39301 XPVL=0.5D0*(XPVAL(1)+XPVAL(2)+XPVAL(-1)+XPVAL(-2))+
39302 & XPVAL(3)+XPVAL(4)+XPVAL(5)
39303 DO 250 KFL=-6,6
39304 XPVAL(KFL)=0D0
39305 250 CONTINUE
39306 IF(KFA.EQ.22.AND.MINT(105).LE.223) THEN
39307 XPQ(1)=XPQ(1)+0.2D0*XPV
39308 XPQ(2)=XPQ(2)+0.8D0*XPV
39309 XPVAL(1)=0.2D0*XPVL
39310 XPVAL(2)=0.8D0*XPVL
39311 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.333) THEN
39312 XPQ(3)=XPQ(3)+XPV
39313 XPVAL(3)=XPVL
39314 ELSEIF(KFA.EQ.22.AND.MINT(105).EQ.443) THEN
39315 XPQ(4)=XPQ(4)+XPV
39316 XPVAL(4)=XPVL
39317 IF(MSTP(55).GE.9) THEN
39318 DO 260 KFL=-6,6
39319 XPQ(KFL)=0D0
39320 260 CONTINUE
39321 ENDIF
39322 ELSE
39323 XPQ(1)=XPQ(1)+0.5D0*XPV
39324 XPQ(2)=XPQ(2)+0.5D0*XPV
39325 XPVAL(1)=0.5D0*XPVL
39326 XPVAL(2)=0.5D0*XPVL
39327 ENDIF
39328 DO 270 KFL=1,6
39329 XPQ(-KFL)=XPQ(KFL)
39330 XPVAL(-KFL)=XPVAL(KFL)
39331 270 CONTINUE
39332
39333C...Rescale for gammaVDM by effective gamma -> rho coupling.
39334C+++Do not rescale?
39335 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND..NOT.(MSTP(56).EQ.1
39336 & .AND.MSTP(55).GE.5.AND.MSTP(55).LE.12)) THEN
39337 DO 280 KFL=-6,6
39338 XPQ(KFL)=VINT(281)*XPQ(KFL)
39339 XPVAL(KFL)=VINT(281)*XPVAL(KFL)
39340 280 CONTINUE
39341 VINT(232)=VINT(281)*XPV
39342 ENDIF
39343
39344C...Simple recipes for kaons.
39345 ELSEIF(KFA.EQ.321) THEN
39346 XPQ(-3)=XPQ(-3)+XPQ(-1)-XPQ(1)
39347 XPQ(-1)=XPQ(1)
39348 XPVAL(-3)=XPVAL(-1)
39349 XPVAL(-1)=0D0
39350 ELSEIF(KFA.EQ.130.OR.KFA.EQ.310) THEN
39351 XPS=0.5D0*(XPQ(1)+XPQ(-2))
39352 XPV=0.5D0*(XPQ(2)+XPQ(-1))-XPS
39353 XPQ(2)=XPS
39354 XPQ(-1)=XPS
39355 XPQ(1)=XPQ(1)+0.5D0*XPV
39356 XPQ(-1)=XPQ(-1)+0.5D0*XPV
39357 XPQ(3)=XPQ(3)+0.5D0*XPV
39358 XPQ(-3)=XPQ(-3)+0.5D0*XPV
39359 XPV=0.5D0*(XPVAL(2)+XPVAL(-1))
39360 XPVAL(2)=0D0
39361 XPVAL(-1)=0D0
39362 XPVAL(1)=0.5D0*XPV
39363 XPVAL(-1)=0.5D0*XPV
39364 XPVAL(3)=0.5D0*XPV
39365 XPVAL(-3)=0.5D0*XPV
39366
39367C...Isospin conjugation for neutron.
39368 ELSEIF(KFA.EQ.2112) THEN
39369 XPSV=XPQ(1)
39370 XPQ(1)=XPQ(2)
39371 XPQ(2)=XPSV
39372 XPSV=XPQ(-1)
39373 XPQ(-1)=XPQ(-2)
39374 XPQ(-2)=XPSV
39375 XPSV=XPVAL(1)
39376 XPVAL(1)=XPVAL(2)
39377 XPVAL(2)=XPSV
39378
39379C...Simple recipes for hyperon (average valence parton distribution).
39380 ELSEIF(KFA.EQ.3122.OR.KFA.EQ.3112.OR.KFA.EQ.3212.OR.KFA.EQ.3222
39381 & .OR.KFA.EQ.3312.OR.KFA.EQ.3322.OR.KFA.EQ.3334) THEN
39382 XPV=(XPQ(1)+XPQ(2)-XPQ(-1)-XPQ(-2))/3D0
39383 XPS=0.5D0*(XPQ(-1)+XPQ(-2))
39384 XPQ(1)=XPS
39385 XPQ(2)=XPS
39386 XPQ(-1)=XPS
39387 XPQ(-2)=XPS
39388 XPQ(KFA/1000)=XPQ(KFA/1000)+XPV
39389 XPQ(MOD(KFA/100,10))=XPQ(MOD(KFA/100,10))+XPV
39390 XPQ(MOD(KFA/10,10))=XPQ(MOD(KFA/10,10))+XPV
39391 XPV=(XPVAL(1)+XPVAL(2))/3D0
39392 XPVAL(1)=0D0
39393 XPVAL(2)=0D0
39394 XPVAL(KFA/1000)=XPVAL(KFA/1000)+XPV
39395 XPVAL(MOD(KFA/100,10))=XPVAL(MOD(KFA/100,10))+XPV
39396 XPVAL(MOD(KFA/10,10))=XPVAL(MOD(KFA/10,10))+XPV
39397 ENDIF
39398
39399C...Charge conjugation for antiparticle.
39400 IF(KF.LT.0) THEN
39401 DO 290 KFL=1,25
39402 IF(KFL.EQ.21.OR.KFL.EQ.22.OR.KFL.EQ.23.OR.KFL.EQ.25) GOTO 290
39403 XPSV=XPQ(KFL)
39404 XPQ(KFL)=XPQ(-KFL)
39405 XPQ(-KFL)=XPSV
39406 290 CONTINUE
39407 DO 300 KFL=1,6
39408 XPSV=XPVAL(KFL)
39409 XPVAL(KFL)=XPVAL(-KFL)
39410 XPVAL(-KFL)=XPSV
39411 300 CONTINUE
39412 ENDIF
39413
39414C...MULTIPLE INTERACTIONS - PDF RESHAPING.
39415C...Set side.
39416 JS=MINT(30)
39417C...Only reshape PDFs for the non-first interactions;
39418C...But need valence/sea separation already from first interaction.
39419 IF ((JS.EQ.1.OR.JS.EQ.2).AND.MINT(35).GE.2) THEN
39420 KFVSEL=KFIVAL(JS,1)
39421C...If valence quark kicked out of pi0 or gamma then that decides
39422C...whether we should consider state as d dbar, u ubar, s sbar, etc.
39423 IF(KFVSEL.NE.0.AND.(KFA.EQ.111.OR.KFA.EQ.22)) THEN
39424 XPVL=0D0
39425 DO 310 KFL=1,6
39426 XPVL=XPVL+XPVAL(KFL)
39427 XPQ(KFL)=MAX(0D0,XPQ(KFL)-XPVAL(KFL))
39428 XPVAL(KFL)=0D0
39429 310 CONTINUE
39430 XPQ(IABS(KFVSEL))=XPQ(IABS(KFVSEL))+XPVL
39431 XPVAL(IABS(KFVSEL))=XPVL
39432 DO 320 KFL=1,6
39433 XPQ(-KFL)=XPQ(KFL)
39434 XPVAL(-KFL)=XPVAL(KFL)
39435 320 CONTINUE
39436
39437C...If valence quark kicked out of K0S or K0S then that decides whether
39438C...we should consider state as d sbar or s dbar.
39439 ELSEIF(KFVSEL.NE.0.AND.(KFA.EQ.130.OR.KFA.EQ.310)) THEN
39440 KFS=1
39441 IF(KFVSEL.EQ.-1.OR.KFVSEL.EQ.3) KFS=-1
39442 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
39443 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
39444 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
39445 XPVAL(-KFS)=0D0
39446 KFS=-3*KFS
39447 XPQ(KFS)=XPQ(KFS)+XPVAL(-KFS)
39448 XPVAL(KFS)=XPVAL(KFS)+XPVAL(-KFS)
39449 XPQ(-KFS)=MAX(0D0,XPQ(-KFS)-XPVAL(-KFS))
39450 XPVAL(-KFS)=0D0
39451 ENDIF
39452
39453C...XPQ distributions are nominal for a (signed) beam particle
39454C...of KF type, with 1-Sum(x_prev) rescaled to 1.
39455 CMPFAC=1D0
39456 NRESC=0
39457 345 NRESC=NRESC+1
39458 PVCTOT(JS,-1)=0D0
39459 PVCTOT(JS, 0)=0D0
39460 PVCTOT(JS, 1)=0D0
39461 DO 350 IFL=-6,6
39462 IF(IFL.EQ.0) GOTO 350
39463
39464C...Count up number of original IFL valence quarks.
39465 IVORG=0
39466 IF(KFIVAL(JS,1).EQ.IFL) IVORG=IVORG+1
39467 IF(KFIVAL(JS,2).EQ.IFL) IVORG=IVORG+1
39468 IF(KFIVAL(JS,3).EQ.IFL) IVORG=IVORG+1
39469C...For pi0/gamma/K0S/K0L without valence flavour decided yet, here
39470C...bookkeep as if d dbar (for total momentum sum in valence sector).
39471 IF(KFIVAL(JS,1).EQ.0.AND.IABS(IFL).EQ.1) IVORG=1
39472C...Count down number of remaining IFL valence quarks. Skip current
39473C...interaction initiator.
39474 IVREM=IVORG
39475 DO 330 I1=1,NMI(JS)
39476 IF (I1.EQ.MINT(36)) GOTO 330
39477 IF (K(IMI(JS,I1,1),2).EQ.IFL.AND.IMI(JS,I1,2).EQ.0)
39478 & IVREM=IVREM-1
39479 330 CONTINUE
39480
39481C...Separate out original VALENCE and SEA content.
39482 VAL=XPVAL(IFL)
39483 SEA=MAX(0D0,XPQ(IFL)-VAL)
39484 XPSVC(IFL,0)=VAL
39485 XPSVC(IFL,-1)=SEA
39486
39487C...Rescale valence content if changed.
39488 IF (IVORG.NE.0.AND.IVREM.NE.IVORG) XPSVC(IFL,0)=
39489 & (VAL*IVREM)/IVORG
39490
39491C...Momentum integrals of original and removed valence quarks.
39492 IF(IVORG.NE.0) THEN
39493C...For p/n/pbar/nbar beams can split into d_val and u_val.
39494C...Isospin conjugation for neutrons
39495 IF(KFA.EQ.2212.OR.KFA.EQ.2112) THEN
39496 IAFLP=IABS(IFL)
39497 IF (KFA.EQ.2112) IAFLP=3-IAFLP
39498 VPAVG=PAVG(IAFLP,Q2)
39499C...For other baryons average d_val and u_val, like for PDFs.
39500 ELSEIF(KFA.GT.1000) THEN
39501 VPAVG=(PAVG(1,Q2)+2D0*PAVG(2,Q2))/3D0
39502C...For mesons and photon average d_val and u_val and scale by 3/2.
39503C...Very crude, especially for photon.
39504 ELSE
39505 VPAVG=0.5D0*(PAVG(1,Q2)+2D0*PAVG(2,Q2))
39506 ENDIF
39507 PVCTOT(JS,-1)=PVCTOT(JS,-1)+IVORG*VPAVG
39508 PVCTOT(JS, 0)=PVCTOT(JS, 0)+(IVORG-IVREM)*VPAVG
39509 ENDIF
39510
39511C...Now add companions (at X with partner having been at Z=XASSOC).
39512C...NOTE: due to the assumed simple x scaling, the partner was at what
39513C...corresponds to a higher Z than XASSOC, if there were intermediate
39514C...scatterings. Nothing done about that for the moment.
39515 DO 340 IVC=1,NVC(JS,IFL)
39516C...Skip companions that have been kicked out
39517 IF (XASSOC(JS,IFL,IVC).LE.0D0) THEN
39518 XPSVC(IFL,IVC)=0D0
39519 GOTO 340
39520 ELSE
39521C...Momentum fraction of the partner quark.
39522C...Use rescaled YS = XS/(1-Sum_rest) where X and XS are not in "rest".
39523 XS=XASSOC(JS,IFL,IVC)
39524 XREM=VINT(142+JS)
39525 YS=XS/(XREM+XS)
39526C...Momentum fraction of the companion quark.
39527C...Rescale from X = x/XREM to Y = x/(1-Sum_rest) -> factor (1-YS).
39528 Y=X*(1D0-YS)
39529 XPSVC(IFL,IVC)=PYFCMP(Y/CMPFAC,YS/CMPFAC,MSTP(87))
39530C...Add to momentum sum, with rescaling compensation factor.
39531 XCFAC=(XREM+XS)/XREM*CMPFAC
39532 PVCTOT(JS,1)=PVCTOT(JS,1)+XCFAC*PYPCMP(YS/CMPFAC,MSTP(87))
39533 ENDIF
39534 340 CONTINUE
39535 350 CONTINUE
39536
39537C...Wait until all flavours treated, then rescale seas and gluon.
39538 XPSVC(0,-1)=XPQ(0)
39539 XPSVC(0,0)=0D0
39540 RSFAC=1D0+(PVCTOT(JS,0)-PVCTOT(JS,1))/(1D0-PVCTOT(JS,-1))
39541 IF (RSFAC.LE.0D0) THEN
39542C...First calculate factor needed to exactly restore pz cons.
39543 IF (NRESC.EQ.1) CMPFAC =
39544 & (1D0-(PVCTOT(JS,-1)-PVCTOT(JS,0)))/PVCTOT(JS,1)
39545C...Add a bit of headroom
39546 CMPFAC=0.99*CMPFAC
39547C...Try a few times if more headroom is needed, then print error message.
39548 IF (NRESC.LE.10) GOTO 345
39549 CALL PYERRM(15,
39550 & '(PYPDFU:) Negative reshaping factor persists!')
39551 WRITE(MSTU(11),5300) (PVCTOT(JS,ITMP),ITMP=-1,1), RSFAC
39552 RSFAC=0D0
39553 ENDIF
39554 DO 370 IFL=-6,6
39555 XPSVC(IFL,-1)=RSFAC*XPSVC(IFL,-1)
39556C...Also store resulting distributions in XPQ
39557 XPQ(IFL)=0D0
39558 DO 360 ISVC=-1,NVC(JS,IFL)
39559 XPQ(IFL)=XPQ(IFL)+XPSVC(IFL,ISVC)
39560 360 CONTINUE
39561 370 CONTINUE
39562C...Save companion reweighting factor for PYPTIS.
39563 VINT(140)=CMPFAC
39564 ENDIF
39565
39566
39567C...Allow gluon also in position 21.
39568 XPQ(21)=XPQ(0)
39569
39570C...Check positivity and reset above maximum allowed flavour.
39571 DO 380 KFL=-25,25
39572 XPQ(KFL)=MAX(0D0,XPQ(KFL))
39573 IF(IABS(KFL).GT.MSTP(58).AND.IABS(KFL).LE.8) XPQ(KFL)=0D0
39574 380 CONTINUE
39575
39576C...Formats for error printouts.
39577 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
39578 5100 FORMAT(' Error: illegal particle code for parton distribution;',
39579 &' KF =',I5)
39580 5200 FORMAT(' Error: unknown parton distribution; KF, library, set =',
39581 &3I5)
39582 5300 FORMAT(' Original valence momentum fraction : ',F6.3/
39583 & ' Removed valence momentum fraction : ',F6.3/
39584 & ' Added companion momentum fraction : ',F6.3/
39585 & ' Resulting rescale factor : ',F6.3)
39586
39587C...Reset side pointer and return
39588 9999 MINT(30)=0
39589
39590 RETURN
39591 END
39592
39593C*********************************************************************
39594
39595C...PYPDFL
39596C...Gives proton parton distribution at small x and/or Q^2 according to
39597C...correct limiting behaviour.
39598
39599 SUBROUTINE PYPDFL(KF,X,Q2,XPQ)
39600
39601C...Double precision and integer declarations.
39602 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39603 IMPLICIT INTEGER(I-N)
39604 INTEGER PYK,PYCHGE,PYCOMP
39605C...Commonblocks.
39606 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39607 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39608 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39609 COMMON/PYINT1/MINT(400),VINT(400)
39610 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39611C...Local arrays.
39612 DIMENSION XPQ(-25:25),XPA(-25:25),XPB(-25:25),WTSB(-3:3)
39613 DATA RMR/0.92D0/,RMP/0.38D0/,WTSB/0.5D0,1D0,1D0,5D0,1D0,1D0,0.5D0/
39614
39615C...Send everything but protons/neutrons/VMD pions directly to PYPDFU.
39616 MINT(92)=0
39617 KFA=IABS(KF)
39618 IACC=0
39619 IF((KFA.EQ.2212.OR.KFA.EQ.2112).AND.MSTP(57).GE.2) IACC=1
39620 IF(KFA.EQ.211.AND.MSTP(57).GE.3) IACC=1
39621 IF(KFA.EQ.22.AND.MINT(109).EQ.2.AND.MSTP(57).GE.3) IACC=1
39622 IF(IACC.EQ.0) THEN
39623 CALL PYPDFU(KF,X,Q2,XPQ)
39624 RETURN
39625 ENDIF
39626
39627C...Reset. Check x.
39628 DO 100 KFL=-25,25
39629 XPQ(KFL)=0D0
39630 100 CONTINUE
39631 IF(X.LE.0D0.OR.X.GE.1D0) THEN
39632 WRITE(MSTU(11),5000) X
39633 RETURN
39634 ENDIF
39635
39636C...Define valence content.
39637 KFC=KF
39638 NV1=2
39639 NV2=1
39640 IF(KF.EQ.2212) THEN
39641 KFV1=2
39642 KFV2=1
39643 ELSEIF(KF.EQ.-2212) THEN
39644 KFV1=-2
39645 KFV2=-1
39646 ELSEIF(KF.EQ.2112) THEN
39647 KFV1=1
39648 KFV2=2
39649 ELSEIF(KF.EQ.-2112) THEN
39650 KFV1=-1
39651 KFV2=-2
39652 ELSEIF(KF.EQ.211) THEN
39653 NV1=1
39654 KFV1=2
39655 KFV2=-1
39656 ELSEIF(KF.EQ.-211) THEN
39657 NV1=1
39658 KFV1=-2
39659 KFV2=1
39660 ELSEIF(MINT(105).LE.223) THEN
39661 KFV1=1
39662 WTV1=0.2D0
39663 KFV2=2
39664 WTV2=0.8D0
39665 ELSEIF(MINT(105).EQ.333) THEN
39666 KFV1=3
39667 WTV1=1.0D0
39668 KFV2=1
39669 WTV2=0.0D0
39670 ELSEIF(MINT(105).EQ.443) THEN
39671 KFV1=4
39672 WTV1=1.0D0
39673 KFV2=1
39674 WTV2=0.0D0
39675 ENDIF
39676
39677C...Do naive evaluation and find min Q^2, boundary Q^2 and x_0.
39678 MINT30=MINT(30)
39679 CALL PYPDFU(KFC,X,Q2,XPA)
39680 Q2MN=MAX(3D0,VINT(231))
39681 Q2B=2D0+0.052D0**2*EXP(3.56D0*SQRT(MAX(0D0,-LOG(3D0*X))))
39682 XMN=EXP(-(LOG((Q2MN-2D0)/0.052D0**2)/3.56D0)**2)/3D0
39683
39684C...Large Q2 and large x: naive call is enough.
39685 IF(Q2.GT.Q2MN.AND.Q2.GT.Q2B) THEN
39686 DO 110 KFL=-25,25
39687 XPQ(KFL)=XPA(KFL)
39688 110 CONTINUE
39689 MINT(92)=1
39690
39691C...Small Q2 and large x: dampen boundary value.
39692 ELSEIF(X.GT.XMN) THEN
39693
39694C...Evaluate at boundary and define dampening factors.
39695 MINT(30)=MINT30
39696 CALL PYPDFU(KFC,X,Q2MN,XPA)
39697 FV=(Q2*(Q2MN+RMR)/(Q2MN*(Q2+RMR)))**(0.55D0*(1D0-X)/(1D0-XMN))
39698 FS=(Q2*(Q2MN+RMP)/(Q2MN*(Q2+RMP)))**1.08D0
39699
39700C...Separate valence and sea parts of parton distribution.
39701 IF(KFA.NE.22) THEN
39702 XFV1=XPA(KFV1)-XPA(-KFV1)
39703 XPA(KFV1)=XPA(-KFV1)
39704 XFV2=XPA(KFV2)-XPA(-KFV2)
39705 XPA(KFV2)=XPA(-KFV2)
39706 ELSE
39707 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
39708 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
39709 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
39710 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
39711 ENDIF
39712
39713C...Dampen valence and sea separately. Put back together.
39714 DO 120 KFL=-25,25
39715 XPQ(KFL)=FS*XPA(KFL)
39716 120 CONTINUE
39717 IF(KFA.NE.22) THEN
39718 XPQ(KFV1)=XPQ(KFV1)+FV*XFV1
39719 XPQ(KFV2)=XPQ(KFV2)+FV*XFV2
39720 ELSE
39721 XPQ(KFV1)=XPQ(KFV1)+FV*WTV1*VINT(232)
39722 XPQ(-KFV1)=XPQ(-KFV1)+FV*WTV1*VINT(232)
39723 XPQ(KFV2)=XPQ(KFV2)+FV*WTV2*VINT(232)
39724 XPQ(-KFV2)=XPQ(-KFV2)+FV*WTV2*VINT(232)
39725 ENDIF
39726 MINT(92)=2
39727
39728C...Large Q2 and small x: interpolate behaviour.
39729 ELSEIF(Q2.GT.Q2MN) THEN
39730
39731C...Evaluate at extremes and define coefficients for interpolation.
39732 MINT(30)=MINT30
39733 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
39734 VI232A=VINT(232)
39735 MINT(30)=MINT30
39736 CALL PYPDFU(KFC,X,Q2B,XPB)
39737 VI232B=VINT(232)
39738 FLA=LOG(Q2B/Q2)/LOG(Q2B/Q2MN)
39739 FVA=(X/XMN)**0.45D0*FLA
39740 FSA=(X/XMN)**(-0.08D0)*FLA
39741 FB=1D0-FLA
39742
39743C...Separate valence and sea parts of parton distribution.
39744 IF(KFA.NE.22) THEN
39745 XFVA1=XPA(KFV1)-XPA(-KFV1)
39746 XPA(KFV1)=XPA(-KFV1)
39747 XFVA2=XPA(KFV2)-XPA(-KFV2)
39748 XPA(KFV2)=XPA(-KFV2)
39749 XFVB1=XPB(KFV1)-XPB(-KFV1)
39750 XPB(KFV1)=XPB(-KFV1)
39751 XFVB2=XPB(KFV2)-XPB(-KFV2)
39752 XPB(KFV2)=XPB(-KFV2)
39753 ELSE
39754 XPA(KFV1)=XPA(KFV1)-WTV1*VI232A
39755 XPA(-KFV1)=XPA(-KFV1)-WTV1*VI232A
39756 XPA(KFV2)=XPA(KFV2)-WTV2*VI232A
39757 XPA(-KFV2)=XPA(-KFV2)-WTV2*VI232A
39758 XPB(KFV1)=XPB(KFV1)-WTV1*VI232B
39759 XPB(-KFV1)=XPB(-KFV1)-WTV1*VI232B
39760 XPB(KFV2)=XPB(KFV2)-WTV2*VI232B
39761 XPB(-KFV2)=XPB(-KFV2)-WTV2*VI232B
39762 ENDIF
39763
39764C...Interpolate for valence and sea. Put back together.
39765 DO 130 KFL=-25,25
39766 XPQ(KFL)=FSA*XPA(KFL)+FB*XPB(KFL)
39767 130 CONTINUE
39768 IF(KFA.NE.22) THEN
39769 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFVA1+FB*XFVB1)
39770 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFVA2+FB*XFVB2)
39771 ELSE
39772 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39773 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VI232A+FB*VI232B)
39774 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39775 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VI232A+FB*VI232B)
39776 ENDIF
39777 MINT(92)=3
39778
39779C...Small Q2 and small x: dampen boundary value and add term.
39780 ELSE
39781
39782C...Evaluate at boundary and define dampening factors.
39783 MINT(30)=MINT30
39784 CALL PYPDFU(KFC,XMN,Q2MN,XPA)
39785 FB=(XMN-X)*(Q2MN-Q2)/(XMN*Q2MN)
39786 FA=1D0-FB
39787 FVC=(X/XMN)**0.45D0*(Q2/(Q2+RMR))**0.55D0
39788 FVA=FVC*FA*((Q2MN+RMR)/Q2MN)**0.55D0
39789 FVB=FVC*FB*1.10D0*XMN**0.45D0*0.11D0
39790 FSC=(X/XMN)**(-0.08D0)*(Q2/(Q2+RMP))**1.08D0
39791 FSA=FSC*FA*((Q2MN+RMP)/Q2MN)**1.08D0
39792 FSB=FSC*FB*0.21D0*XMN**(-0.08D0)*0.21D0
39793
39794C...Separate valence and sea parts of parton distribution.
39795 IF(KFA.NE.22) THEN
39796 XFV1=XPA(KFV1)-XPA(-KFV1)
39797 XPA(KFV1)=XPA(-KFV1)
39798 XFV2=XPA(KFV2)-XPA(-KFV2)
39799 XPA(KFV2)=XPA(-KFV2)
39800 ELSE
39801 XPA(KFV1)=XPA(KFV1)-WTV1*VINT(232)
39802 XPA(-KFV1)=XPA(-KFV1)-WTV1*VINT(232)
39803 XPA(KFV2)=XPA(KFV2)-WTV2*VINT(232)
39804 XPA(-KFV2)=XPA(-KFV2)-WTV2*VINT(232)
39805 ENDIF
39806
39807C...Dampen valence and sea separately. Add constant terms.
39808C...Put back together.
39809 DO 140 KFL=-25,25
39810 XPQ(KFL)=FSA*XPA(KFL)
39811 140 CONTINUE
39812 IF(KFA.NE.22) THEN
39813 DO 150 KFL=-3,3
39814 XPQ(KFL)=XPQ(KFL)+FSB*WTSB(KFL)
39815 150 CONTINUE
39816 XPQ(KFV1)=XPQ(KFV1)+(FVA*XFV1+FVB*NV1)
39817 XPQ(KFV2)=XPQ(KFV2)+(FVA*XFV2+FVB*NV2)
39818 ELSE
39819 DO 160 KFL=-3,3
39820 XPQ(KFL)=XPQ(KFL)+VINT(281)*FSB*WTSB(KFL)
39821 160 CONTINUE
39822 XPQ(KFV1)=XPQ(KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39823 XPQ(-KFV1)=XPQ(-KFV1)+WTV1*(FVA*VINT(232)+FVB*VINT(281))
39824 XPQ(KFV2)=XPQ(KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39825 XPQ(-KFV2)=XPQ(-KFV2)+WTV2*(FVA*VINT(232)+FVB*VINT(281))
39826 ENDIF
39827 XPQ(21)=XPQ(0)
39828 MINT(92)=4
39829 ENDIF
39830
39831C...Format for error printout.
39832 5000 FORMAT(' Error: x value outside physical range; x =',1P,D12.3)
39833
39834 RETURN
39835 END
39836
39837C*********************************************************************
39838
39839C...PYPDEL
39840C...Gives electron (or muon, or tau) parton distribution.
39841
39842 SUBROUTINE PYPDEL(KFA,X,Q2,XPEL)
39843
39844C...Double precision and integer declarations.
39845 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
39846 IMPLICIT INTEGER(I-N)
39847 INTEGER PYK,PYCHGE,PYCOMP
39848C...Commonblocks.
39849 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
39850 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
39851 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
39852 COMMON/PYINT1/MINT(400),VINT(400)
39853 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
39854C...Local arrays.
39855 DIMENSION XPEL(-25:25),XPGA(-6:6),SXP(0:6)
39856
39857C...Interface to PDFLIB.
39858 COMMON/W50513/XMIN,XMAX,Q2MIN,Q2MAX
39859 SAVE /W50513/
39860 DOUBLE PRECISION XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GLU,
39861 &VALUE(20),XMIN,XMAX,Q2MIN,Q2MAX
39862 CHARACTER*20 PARM(20)
39863 DATA VALUE/20*0D0/,PARM/20*' '/
39864
39865C...Some common constants.
39866 DO 100 KFL=-25,25
39867 XPEL(KFL)=0D0
39868 100 CONTINUE
39869 AEM=PARU(101)
39870 PME=PMAS(11,1)
39871 IF(KFA.EQ.13) PME=PMAS(13,1)
39872 IF(KFA.EQ.15) PME=PMAS(15,1)
39873 XL=LOG(MAX(1D-10,X))
39874 X1L=LOG(MAX(1D-10,1D0-X))
39875 HLE=LOG(MAX(3D0,Q2/PME**2))
39876 HBE2=(AEM/PARU(1))*(HLE-1D0)
39877
39878C...Electron inside electron, see R. Kleiss et al., in Z physics at
39879C...LEP 1, CERN 89-08, p. 34
39880 IF(MSTP(59).LE.1) THEN
39881 HDE=1D0+(AEM/PARU(1))*(1.5D0*HLE+1.289868D0)+(AEM/PARU(1))**2*
39882 & (-2.164868D0*HLE**2+9.840808D0*HLE-10.130464D0)
39883 HEE=HBE2*(1D0-X)**(HBE2-1D0)*SQRT(MAX(0D0,HDE))-
39884 & 0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*(-4D0*X1L+3D0*XL)-
39885 & 4D0*XL/(1D0-X)-5D0-X)
39886 ELSE
39887 HEE=HBE2*(1D0-X)**(HBE2-1D0)*EXP(0.172784D0*HBE2)/
39888 & PYGAMM(1D0+HBE2)-0.5D0*HBE2*(1D0+X)+HBE2**2/8D0*((1D0+X)*
39889 & (-4D0*X1L+3D0*XL)-4D0*XL/(1D0-X)-5D0-X)
39890 ENDIF
39891C...Zero distribution for very large x and rescale it for intermediate.
39892 IF(X.GT.1D0-1D-10) THEN
39893 HEE=0D0
39894 ELSEIF(X.GT.1D0-1D-7) THEN
39895 HEE=HEE*1000D0**HBE2/(1000D0**HBE2-1D0)
39896 ENDIF
39897 XPEL(KFA)=X*HEE
39898
39899C...Photon and (transverse) W- inside electron.
39900 AEMP=PYALEM(PME*SQRT(MAX(0D0,Q2)))/PARU(2)
39901 IF(MSTP(13).LE.1) THEN
39902 HLG=HLE
39903 ELSE
39904 HLG=LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-X)/X**2))
39905 ENDIF
39906 XPEL(22)=AEMP*HLG*(1D0+(1D0-X)**2)
39907 HLW=LOG(1D0+Q2/PMAS(24,1)**2)/(4D0*PARU(102))
39908 XPEL(-24)=AEMP*HLW*(1D0+(1D0-X)**2)
39909
39910C...Electron or positron inside photon inside electron.
39911 IF(KFA.EQ.11.AND.MSTP(12).EQ.1) THEN
39912 XFSEA=0.5D0*(AEMP*(HLE-1D0))**2*(4D0/3D0+X-X**2-4D0*X**3/3D0+
39913 & 2D0*X*(1D0+X)*XL)
39914 XPEL(11)=XPEL(11)+XFSEA
39915 XPEL(-11)=XFSEA
39916
39917C...Initialize PDFLIB photon parton distributions.
39918 IF(MSTP(56).EQ.2) THEN
39919 PARM(1)='NPTYPE'
39920 VALUE(1)=3
39921 PARM(2)='NGROUP'
39922 VALUE(2)=MSTP(55)/1000
39923 PARM(3)='NSET'
39924 VALUE(3)=MOD(MSTP(55),1000)
39925 IF(MINT(93).NE.3000000+MSTP(55)) THEN
39926 CALL PDFSET_ALICE(PARM,VALUE)
39927 MINT(93)=3000000+MSTP(55)
39928 ENDIF
39929 ENDIF
39930
39931C...Quarks and gluons inside photon inside electron:
39932C...numerical convolution required.
39933 DO 110 KFL=0,6
39934 SXP(KFL)=0D0
39935 110 CONTINUE
39936 SUMXPP=0D0
39937 ITER=-1
39938 120 ITER=ITER+1
39939 SUMXP=SUMXPP
39940 NSTP=2**(ITER-1)
39941 IF(ITER.EQ.0) NSTP=2
39942 DO 130 KFL=0,6
39943 SXP(KFL)=0.5D0*SXP(KFL)
39944 130 CONTINUE
39945 WTSTP=0.5D0/NSTP
39946 IF(ITER.EQ.0) WTSTP=0.5D0
39947C...Pick grid of x_{gamma} values logarithmically even.
39948 DO 150 ISTP=1,NSTP
39949 IF(ITER.EQ.0) THEN
39950 XLE=XL*(ISTP-1)
39951 ELSE
39952 XLE=XL*(ISTP-0.5D0)/NSTP
39953 ENDIF
39954 XE=MIN(1D0-1D-10,EXP(XLE))
39955 XG=MIN(1D0-1D-10,X/XE)
39956C...Evaluate photon inside electron parton distribution for convolution.
39957 XPGP=1D0+(1D0-XE)**2
39958 IF(MSTP(13).LE.1) THEN
39959 XPGP=XPGP*HLE
39960 ELSE
39961 XPGP=XPGP*LOG(MAX(1D0,(PARP(13)/PME**2)*(1D0-XE)/XE**2))
39962 ENDIF
39963C...Evaluate photon parton distributions for convolution.
39964 IF(MSTP(56).EQ.1) THEN
39965 IF(MSTP(55).EQ.1) THEN
39966 CALL PYPDGA(XG,Q2,XPGA)
39967 ELSEIF(MSTP(55).GE.5.AND.MSTP(55).LE.8) THEN
39968 Q2MX=Q2
39969 P2MX=0.36D0
39970 IF(MSTP(55).GE.7) P2MX=4.0D0
39971 IF(MSTP(57).EQ.0) Q2MX=P2MX
39972 P2=0D0
39973 IF(VINT(120).LT.0D0) P2=VINT(120)**2
39974 CALL PYGGAM(MSTP(55)-4,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39975 VINT(231)=P2MX
39976 ELSEIF(MSTP(55).GE.9.AND.MSTP(55).LE.12) THEN
39977 Q2MX=Q2
39978 P2MX=0.36D0
39979 IF(MSTP(55).GE.11) 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)-8,XG,Q2MX,P2,MSTP(60),F2GAM,XPGA)
39984 VINT(231)=P2MX
39985 ENDIF
39986 DO 140 KFL=0,5
39987 SXP(KFL)=SXP(KFL)+WTSTP*XPGP*XPGA(KFL)
39988 140 CONTINUE
39989 ELSEIF(MSTP(56).EQ.2) THEN
39990C...Call PDFLIB parton distributions.
39991 XX=XG
39992 QQ=SQRT(MAX(0D0,Q2MIN,Q2))
39993 IF(MSTP(57).EQ.0) QQ=SQRT(Q2MIN)
39994 CALL STRUCTM_ALICE(XX,QQ,UPV,DNV,USEA,
39995 + DSEA,STR,CHM,BOT,TOP,GLU)
39996 SXP(0)=SXP(0)+WTSTP*XPGP*GLU
39997 SXP(1)=SXP(1)+WTSTP*XPGP*DNV
39998 SXP(2)=SXP(2)+WTSTP*XPGP*UPV
39999 SXP(3)=SXP(3)+WTSTP*XPGP*STR
40000 SXP(4)=SXP(4)+WTSTP*XPGP*CHM
40001 SXP(5)=SXP(5)+WTSTP*XPGP*BOT
40002 SXP(6)=SXP(6)+WTSTP*XPGP*TOP
40003 ENDIF
40004 150 CONTINUE
40005 SUMXPP=SXP(0)+2D0*SXP(1)+2D0*SXP(2)
40006 IF(ITER.LE.2.OR.(ITER.LE.7.AND.ABS(SUMXPP-SUMXP).GT.
40007 & PARP(14)*(SUMXPP+SUMXP))) GOTO 120
40008
40009C...Put convolution into output arrays.
40010 FCONV=AEMP*(-XL)
40011 XPEL(0)=FCONV*SXP(0)
40012 DO 160 KFL=1,6
40013 XPEL(KFL)=FCONV*SXP(KFL)
40014 XPEL(-KFL)=XPEL(KFL)
40015 160 CONTINUE
40016 ENDIF
40017
40018 RETURN
40019 END
40020
40021C*********************************************************************
40022
40023C...PYPDGA
40024C...Gives photon parton distribution.
40025
40026 SUBROUTINE PYPDGA(X,Q2,XPGA)
40027
40028C...Double precision and integer declarations.
40029 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40030 IMPLICIT INTEGER(I-N)
40031 INTEGER PYK,PYCHGE,PYCOMP
40032C...Commonblocks.
40033 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40034 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40035 COMMON/PYINT1/MINT(400),VINT(400)
40036 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40037C...Local arrays.
40038 DIMENSION XPGA(-6:6),DGAG(4,3),DGBG(4,3),DGCG(4,3),DGAN(4,3),
40039 &DGBN(4,3),DGCN(4,3),DGDN(4,3),DGEN(4,3),DGAS(4,3),DGBS(4,3),
40040 &DGCS(4,3),DGDS(4,3),DGES(4,3)
40041
40042C...The following data lines are coefficients needed in the
40043C...Drees and Grassie photon parton distribution parametrization.
40044 DATA DGAG/-.207D0,.6158D0,1.074D0,0.D0,.8926D-2,.6594D0,
40045 &.4766D0,.1975D-1,.03197D0,1.018D0,.2461D0,.2707D-1/
40046 DATA DGBG/-.1987D0,.6257D0,8.352D0,5.024D0,.5085D-1,.2774D0,
40047 &-.3906D0,-.3212D0,-.618D-2,.9476D0,-.6094D0,-.1067D-1/
40048 DATA DGCG/5.119D0,-.2752D0,-6.993D0,2.298D0,-.2313D0,.1382D0,
40049 &6.542D0,.5162D0,-.1216D0,.9047D0,2.653D0,.2003D-2/
40050 DATA DGAN/2.285D0,-.1526D-1,1330.D0,4.219D0,-.3711D0,1.061D0,
40051 &4.758D0,-.1503D-1,15.8D0,-.9464D0,-.5D0,-.2118D0/
40052 DATA DGBN/6.073D0,-.8132D0,-41.31D0,3.165D0,-.1717D0,.7815D0,
40053 &1.535D0,.7067D-2,2.742D0,-.7332D0,.7148D0,3.287D0/
40054 DATA DGCN/-.4202D0,.1778D-1,.9216D0,.18D0,.8766D-1,.2197D-1,
40055 &.1096D0,.204D0,.2917D-1,.4657D-1,.1785D0,.4811D-1/
40056 DATA DGDN/-.8083D-1,.6346D0,1.208D0,.203D0,-.8915D0,.2857D0,
40057 &2.973D0,.1185D0,-.342D-1,.7196D0,.7338D0,.8139D-1/
40058 DATA DGEN/.5526D-1,1.136D0,.9512D0,.1163D-1,-.1816D0,.5866D0,
40059 &2.421D0,.4059D0,-.2302D-1,.9229D0,.5873D0,-.79D-4/
40060 DATA DGAS/16.69D0,-.7916D0,1099.D0,4.428D0,-.1207D0,1.071D0,
40061 &1.977D0,-.8625D-2,6.734D0,-1.008D0,-.8594D-1,.7625D-1/
40062 DATA DGBS/.176D0,.4794D-1,1.047D0,.25D-1,25.D0,-1.648D0,
40063 &-.1563D-1,6.438D0,59.88D0,-2.983D0,4.48D0,.9686D0/
40064 DATA DGCS/-.208D-1,.3386D-2,4.853D0,.8404D0,-.123D-1,1.162D0,
40065 &.4824D0,-.11D-1,-.3226D-2,.8432D0,.3616D0,.1383D-2/
40066 DATA DGDS/-.1685D-1,1.353D0,1.426D0,1.239D0,-.9194D-1,.7912D0,
40067 &.6397D0,2.327D0,-.3321D-1,.9475D0,-.3198D0,.2132D-1/
40068 DATA DGES/-.1986D0,1.1D0,1.136D0,-.2779D0,.2015D-1,.9869D0,
40069 &-.7036D-1,.1694D-1,.1059D0,.6954D0,-.6663D0,.3683D0/
40070
40071C...Photon parton distribution from Drees and Grassie.
40072C...Allowed variable range: 1 GeV^2 < Q^2 < 10000 GeV^2.
40073 DO 100 KFL=-6,6
40074 XPGA(KFL)=0D0
40075 100 CONTINUE
40076 VINT(231)=1D0
40077 IF(MSTP(57).LE.0) THEN
40078 T=LOG(1D0/0.16D0)
40079 ELSE
40080 T=LOG(MIN(1D4,MAX(1D0,Q2))/0.16D0)
40081 ENDIF
40082 X1=1D0-X
40083 NF=3
40084 IF(Q2.GT.25D0) NF=4
40085 IF(Q2.GT.300D0) NF=5
40086 NFE=NF-2
40087 AEM=PARU(101)
40088
40089C...Evaluate gluon content.
40090 DGA=DGAG(1,NFE)*T**DGAG(2,NFE)+DGAG(3,NFE)*T**(-DGAG(4,NFE))
40091 DGB=DGBG(1,NFE)*T**DGBG(2,NFE)+DGBG(3,NFE)*T**(-DGBG(4,NFE))
40092 DGC=DGCG(1,NFE)*T**DGCG(2,NFE)+DGCG(3,NFE)*T**(-DGCG(4,NFE))
40093 XPGL=DGA*X**DGB*X1**DGC
40094
40095C...Evaluate up- and down-type quark content.
40096 DGA=DGAN(1,NFE)*T**DGAN(2,NFE)+DGAN(3,NFE)*T**(-DGAN(4,NFE))
40097 DGB=DGBN(1,NFE)*T**DGBN(2,NFE)+DGBN(3,NFE)*T**(-DGBN(4,NFE))
40098 DGC=DGCN(1,NFE)*T**DGCN(2,NFE)+DGCN(3,NFE)*T**(-DGCN(4,NFE))
40099 DGD=DGDN(1,NFE)*T**DGDN(2,NFE)+DGDN(3,NFE)*T**(-DGDN(4,NFE))
40100 DGE=DGEN(1,NFE)*T**DGEN(2,NFE)+DGEN(3,NFE)*T**(-DGEN(4,NFE))
40101 XPQN=X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
40102 DGA=DGAS(1,NFE)*T**DGAS(2,NFE)+DGAS(3,NFE)*T**(-DGAS(4,NFE))
40103 DGB=DGBS(1,NFE)*T**DGBS(2,NFE)+DGBS(3,NFE)*T**(-DGBS(4,NFE))
40104 DGC=DGCS(1,NFE)*T**DGCS(2,NFE)+DGCS(3,NFE)*T**(-DGCS(4,NFE))
40105 DGD=DGDS(1,NFE)*T**DGDS(2,NFE)+DGDS(3,NFE)*T**(-DGDS(4,NFE))
40106 DGE=DGES(1,NFE)*T**DGES(2,NFE)+DGES(3,NFE)*T**(-DGES(4,NFE))
40107 DGF=9D0
40108 IF(NF.EQ.4) DGF=10D0
40109 IF(NF.EQ.5) DGF=55D0/6D0
40110 XPQS=DGF*X*(X**2+X1**2)/(DGA-DGB*LOG(X1))+DGC*X**DGD*X1**DGE
40111 IF(NF.LE.3) THEN
40112 XPQU=(XPQS+9D0*XPQN)/6D0
40113 XPQD=(XPQS-4.5D0*XPQN)/6D0
40114 ELSEIF(NF.EQ.4) THEN
40115 XPQU=(XPQS+6D0*XPQN)/8D0
40116 XPQD=(XPQS-6D0*XPQN)/8D0
40117 ELSE
40118 XPQU=(XPQS+7.5D0*XPQN)/10D0
40119 XPQD=(XPQS-5D0*XPQN)/10D0
40120 ENDIF
40121
40122C...Put into output arrays.
40123 XPGA(0)=AEM*XPGL
40124 XPGA(1)=AEM*XPQD
40125 XPGA(2)=AEM*XPQU
40126 XPGA(3)=AEM*XPQD
40127 IF(NF.GE.4) XPGA(4)=AEM*XPQU
40128 IF(NF.GE.5) XPGA(5)=AEM*XPQD
40129 DO 110 KFL=1,6
40130 XPGA(-KFL)=XPGA(KFL)
40131 110 CONTINUE
40132
40133 RETURN
40134 END
40135
40136C*********************************************************************
40137
40138C...PYGGAM
40139C...Constructs the F2 and parton distributions of the photon
40140C...by summing homogeneous (VMD) and inhomogeneous (anomalous) terms.
40141C...For F2, c and b are included by the Bethe-Heitler formula;
40142C...in the 'MSbar' scheme additionally a Cgamma term is added.
40143C...Contains the SaS sets 1D, 1M, 2D and 2M.
40144C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40145
40146 SUBROUTINE PYGGAM(ISET,X,Q2,P2,IP2,F2GM,XPDFGM)
40147
40148C...Double precision and integer declarations.
40149 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40150 IMPLICIT INTEGER(I-N)
40151 INTEGER PYK,PYCHGE,PYCOMP
40152C...Commonblocks.
40153 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
40154 &XPDIR(-6:6)
40155 COMMON/PYINT9/VXPVMD(-6:6),VXPANL(-6:6),VXPANH(-6:6),VXPDGM(-6:6)
40156 SAVE /PYINT8/,/PYINT9/
40157C...Local arrays.
40158 DIMENSION XPDFGM(-6:6),XPGA(-6:6), VXPGA(-6:6)
40159C...Charm and bottom masses (low to compensate for J/psi etc.).
40160 DATA PMC/1.3D0/, PMB/4.6D0/
40161C...alpha_em and alpha_em/(2*pi).
40162 DATA AEM/0.007297D0/, AEM2PI/0.0011614D0/
40163C...Lambda value for 4 flavours.
40164 DATA ALAM/0.20D0/
40165C...Mixture u/(u+d), = 0.5 for incoherent and = 0.8 for coherent sum.
40166 DATA FRACU/0.8D0/
40167C...VMD couplings f_V**2/(4*pi).
40168 DATA FRHO/2.20D0/, FOMEGA/23.6D0/, FPHI/18.4D0/
40169C...Masses for rho (=omega) and phi.
40170 DATA PMRHO/0.770D0/, PMPHI/1.020D0/
40171C...Number of points in integration for IP2=1.
40172 DATA NSTEP/100/
40173
40174C...Reset output.
40175 F2GM=0D0
40176 DO 100 KFL=-6,6
40177 XPDFGM(KFL)=0D0
40178 XPVMD(KFL)=0D0
40179 XPANL(KFL)=0D0
40180 XPANH(KFL)=0D0
40181 XPBEH(KFL)=0D0
40182 XPDIR(KFL)=0D0
40183 VXPVMD(KFL)=0D0
40184 VXPANL(KFL)=0D0
40185 VXPANH(KFL)=0D0
40186 VXPDGM(KFL)=0D0
40187 100 CONTINUE
40188
40189C...Set Q0 cut-off parameter as function of set used.
40190 IF(ISET.LE.2) THEN
40191 Q0=0.6D0
40192 ELSE
40193 Q0=2D0
40194 ENDIF
40195 Q02=Q0**2
40196
40197C...Scale choice for off-shell photon; common factors.
40198 Q2A=Q2
40199 FACNOR=1D0
40200 IF(IP2.EQ.1) THEN
40201 P2MX=P2+Q02
40202 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40203 FACNOR=LOG(Q2/Q02)/NSTEP
40204 ELSEIF(IP2.EQ.2) THEN
40205 P2MX=MAX(P2,Q02)
40206 ELSEIF(IP2.EQ.3) THEN
40207 P2MX=P2+Q02
40208 Q2A=Q2+P2*Q02/MAX(Q02,Q2)
40209 ELSEIF(IP2.EQ.4) THEN
40210 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40211 & ((Q2+P2)*(Q02+P2)))
40212 ELSEIF(IP2.EQ.5) THEN
40213 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40214 & ((Q2+P2)*(Q02+P2)))
40215 P2MX=Q0*SQRT(P2MXA)
40216 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MX)
40217 ELSEIF(IP2.EQ.6) THEN
40218 P2MX=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40219 & ((Q2+P2)*(Q02+P2)))
40220 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
40221 ELSE
40222 P2MXA=Q2*(Q02+P2)/(Q2+P2)*EXP(P2*(Q2-Q02)/
40223 & ((Q2+P2)*(Q02+P2)))
40224 P2MX=Q0*SQRT(P2MXA)
40225 P2MXB=P2MX
40226 P2MX=MAX(0D0,1D0-P2/Q2)*P2MX+MIN(1D0,P2/Q2)*MAX(P2,Q02)
40227 P2MXB=MAX(0D0,1D0-P2/Q2)*P2MXB+MIN(1D0,P2/Q2)*P2MXA
40228 IF(ABS(Q2-Q02).GT.1D-6) THEN
40229 FACNOR=LOG(Q2/P2MXA)/LOG(Q2/P2MXB)
40230 ELSEIF(P2.LT.Q02) THEN
40231 FACNOR=Q02**3/(Q02+P2)/(Q02**2-P2**2/2D0)
40232 ELSE
40233 FACNOR=1D0
40234 ENDIF
40235 ENDIF
40236
40237C...Call VMD parametrization for d quark and use to give rho, omega,
40238C...phi. Note dipole dampening for off-shell photon.
40239 CALL PYGVMD(ISET,1,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40240 XFVAL=VXPGA(1)
40241 XPGA(1)=XPGA(2)
40242 XPGA(-1)=XPGA(-2)
40243 FACUD=AEM*(1D0/FRHO+1D0/FOMEGA)*(PMRHO**2/(PMRHO**2+P2))**2
40244 FACS=AEM*(1D0/FPHI)*(PMPHI**2/(PMPHI**2+P2))**2
40245 DO 110 KFL=-5,5
40246 XPVMD(KFL)=(FACUD+FACS)*XPGA(KFL)
40247 110 CONTINUE
40248 XPVMD(1)=XPVMD(1)+(1D0-FRACU)*FACUD*XFVAL
40249 XPVMD(2)=XPVMD(2)+FRACU*FACUD*XFVAL
40250 XPVMD(3)=XPVMD(3)+FACS*XFVAL
40251 XPVMD(-1)=XPVMD(-1)+(1D0-FRACU)*FACUD*XFVAL
40252 XPVMD(-2)=XPVMD(-2)+FRACU*FACUD*XFVAL
40253 XPVMD(-3)=XPVMD(-3)+FACS*XFVAL
40254 VXPVMD(1)=(1D0-FRACU)*FACUD*XFVAL
40255 VXPVMD(2)=FRACU*FACUD*XFVAL
40256 VXPVMD(3)=FACS*XFVAL
40257 VXPVMD(-1)=(1D0-FRACU)*FACUD*XFVAL
40258 VXPVMD(-2)=FRACU*FACUD*XFVAL
40259 VXPVMD(-3)=FACS*XFVAL
40260
40261 IF(IP2.NE.1) THEN
40262C...Anomalous parametrizations for different strategies
40263C...for off-shell photons; except full integration.
40264
40265C...Call anomalous parametrization for d + u + s.
40266 CALL PYGANO(-3,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40267 DO 120 KFL=-5,5
40268 XPANL(KFL)=FACNOR*XPGA(KFL)
40269 VXPANL(KFL)=FACNOR*VXPGA(KFL)
40270 120 CONTINUE
40271
40272C...Call anomalous parametrization for c and b.
40273 CALL PYGANO(4,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40274 DO 130 KFL=-5,5
40275 XPANH(KFL)=FACNOR*XPGA(KFL)
40276 VXPANH(KFL)=FACNOR*VXPGA(KFL)
40277 130 CONTINUE
40278 CALL PYGANO(5,X,Q2A,P2MX,ALAM,XPGA,VXPGA)
40279 DO 140 KFL=-5,5
40280 XPANH(KFL)=XPANH(KFL)+FACNOR*XPGA(KFL)
40281 VXPANH(KFL)=VXPANH(KFL)+FACNOR*VXPGA(KFL)
40282 140 CONTINUE
40283
40284 ELSE
40285C...Special option: loop over flavours and integrate over k2.
40286 DO 170 KF=1,5
40287 DO 160 ISTEP=1,NSTEP
40288 Q2STEP=Q02*(Q2/Q02)**((ISTEP-0.5D0)/NSTEP)
40289 IF((KF.EQ.4.AND.Q2STEP.LT.PMC**2).OR.
40290 & (KF.EQ.5.AND.Q2STEP.LT.PMB**2)) GOTO 160
40291 CALL PYGVMD(0,KF,X,Q2,Q2STEP,ALAM,XPGA,VXPGA)
40292 FACQ=AEM2PI*(Q2STEP/(Q2STEP+P2))**2*FACNOR
40293 IF(MOD(KF,2).EQ.0) FACQ=FACQ*(8D0/9D0)
40294 IF(MOD(KF,2).EQ.1) FACQ=FACQ*(2D0/9D0)
40295 DO 150 KFL=-5,5
40296 IF(KF.LE.3) XPANL(KFL)=XPANL(KFL)+FACQ*XPGA(KFL)
40297 IF(KF.GE.4) XPANH(KFL)=XPANH(KFL)+FACQ*XPGA(KFL)
40298 IF(KF.LE.3) VXPANL(KFL)=VXPANL(KFL)+FACQ*VXPGA(KFL)
40299 IF(KF.GE.4) VXPANH(KFL)=VXPANH(KFL)+FACQ*VXPGA(KFL)
40300 150 CONTINUE
40301 160 CONTINUE
40302 170 CONTINUE
40303 ENDIF
40304
40305C...Call Bethe-Heitler term expression for charm and bottom.
40306 CALL PYGBEH(4,X,Q2,P2,PMC**2,XPBH)
40307 XPBEH(4)=XPBH
40308 XPBEH(-4)=XPBH
40309 CALL PYGBEH(5,X,Q2,P2,PMB**2,XPBH)
40310 XPBEH(5)=XPBH
40311 XPBEH(-5)=XPBH
40312
40313C...For MSbar subtraction call C^gamma term expression for d, u, s.
40314 IF(ISET.EQ.2.OR.ISET.EQ.4) THEN
40315 CALL PYGDIR(X,Q2,P2,Q02,XPGA)
40316 DO 180 KFL=-5,5
40317 XPDIR(KFL)=XPGA(KFL)
40318 180 CONTINUE
40319 ENDIF
40320
40321C...Store result in output array.
40322 DO 190 KFL=-5,5
40323 CHSQ=1D0/9D0
40324 IF(IABS(KFL).EQ.2.OR.IABS(KFL).EQ.4) CHSQ=4D0/9D0
40325 XPF2=XPVMD(KFL)+XPANL(KFL)+XPBEH(KFL)+XPDIR(KFL)
40326 IF(KFL.NE.0) F2GM=F2GM+CHSQ*XPF2
40327 XPDFGM(KFL)=XPVMD(KFL)+XPANL(KFL)+XPANH(KFL)
40328 VXPDGM(KFL)=VXPVMD(KFL)+VXPANL(KFL)+VXPANH(KFL)
40329 190 CONTINUE
40330
40331 RETURN
40332 END
40333
40334C*********************************************************************
40335
40336C...PYGVMD
40337C...Evaluates the VMD parton distributions of a photon,
40338C...evolved homogeneously from an initial scale P2 to Q2.
40339C...Does not include dipole suppression factor.
40340C...ISET is parton distribution set, see above;
40341C...additionally ISET=0 is used for the evolution of an anomalous photon
40342C...which branched at a scale P2 and then evolved homogeneously to Q2.
40343C...ALAM is the 4-flavour Lambda, which is automatically converted
40344C...to 3- and 5-flavour equivalents as needed.
40345C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40346
40347 SUBROUTINE PYGVMD(ISET,KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40348
40349C...Double precision and integer declarations.
40350 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40351 IMPLICIT INTEGER(I-N)
40352 INTEGER PYK,PYCHGE,PYCOMP
40353C...Local arrays and data.
40354 DIMENSION XPGA(-6:6), VXPGA(-6:6)
40355 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
40356
40357C...Reset output.
40358 DO 100 KFL=-6,6
40359 XPGA(KFL)=0D0
40360 VXPGA(KFL)=0D0
40361 100 CONTINUE
40362 KFA=IABS(KF)
40363
40364C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40365 ALAM3=ALAM*(PMC/ALAM)**(2D0/27D0)
40366 ALAM5=ALAM*(ALAM/PMB)**(2D0/23D0)
40367 P2EFF=MAX(P2,1.2D0*ALAM3**2)
40368 IF(KFA.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40369 IF(KFA.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40370 Q2EFF=MAX(Q2,P2EFF)
40371
40372C...Find number of flavours at lower and upper scale.
40373 NFP=4
40374 IF(P2EFF.LT.PMC**2) NFP=3
40375 IF(P2EFF.GT.PMB**2) NFP=5
40376 NFQ=4
40377 IF(Q2EFF.LT.PMC**2) NFQ=3
40378 IF(Q2EFF.GT.PMB**2) NFQ=5
40379
40380C...Find s as sum of 3-, 4- and 5-flavour parts.
40381 S=0D0
40382 IF(NFP.EQ.3) THEN
40383 Q2DIV=PMC**2
40384 IF(NFQ.EQ.3) Q2DIV=Q2EFF
40385 S=S+(6D0/27D0)*LOG(LOG(Q2DIV/ALAM3**2)/LOG(P2EFF/ALAM3**2))
40386 ENDIF
40387 IF(NFP.LE.4.AND.NFQ.GE.4) THEN
40388 P2DIV=P2EFF
40389 IF(NFP.EQ.3) P2DIV=PMC**2
40390 Q2DIV=Q2EFF
40391 IF(NFQ.EQ.5) Q2DIV=PMB**2
40392 S=S+(6D0/25D0)*LOG(LOG(Q2DIV/ALAM**2)/LOG(P2DIV/ALAM**2))
40393 ENDIF
40394 IF(NFQ.EQ.5) THEN
40395 P2DIV=PMB**2
40396 IF(NFP.EQ.5) P2DIV=P2EFF
40397 S=S+(6D0/23D0)*LOG(LOG(Q2EFF/ALAM5**2)/LOG(P2DIV/ALAM5**2))
40398 ENDIF
40399
40400C...Calculate frequent combinations of x and s.
40401 X1=1D0-X
40402 XL=-LOG(X)
40403 S2=S**2
40404 S3=S**3
40405 S4=S**4
40406
40407C...Evaluate homogeneous anomalous parton distributions below or
40408C...above threshold.
40409 IF(ISET.EQ.0) THEN
40410 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40411 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40412 XVAL = X * 1.5D0 * (X**2+X1**2)
40413 XGLU = 0D0
40414 XSEA = 0D0
40415 ELSE
40416 XVAL = (1.5D0/(1D0-0.197D0*S+4.33D0*S2)*X**2 +
40417 & (1.5D0+2.10D0*S)/(1D0+3.29D0*S)*X1**2 +
40418 & 5.23D0*S/(1D0+1.17D0*S+19.9D0*S3)*X*X1) *
40419 & X**(1D0/(1D0+1.5D0*S)) * (1D0-X**2)**(2.667D0*S)
40420 XGLU = 4D0*S/(1D0+4.76D0*S+15.2D0*S2+29.3D0*S4) *
40421 & X**(-2.03D0*S/(1D0+2.44D0*S)) * (X1*XL)**(1.333D0*S) *
40422 & ((4D0*X**2+7D0*X+4D0)*X1/3D0 - 2D0*X*(1D0+X)*XL)
40423 XSEA = S2/(1D0+4.54D0*S+8.19D0*S2+8.05D0*S3) *
40424 & X**(-1.54D0*S/(1D0+1.29D0*S)) * X1**(2.667D0*S) *
40425 & ((8D0-73D0*X+62D0*X**2)*X1/9D0 + (3D0-8D0*X**2/3D0)*X*XL +
40426 & (2D0*X-1D0)*X*XL**2)
40427 ENDIF
40428
40429C...Evaluate set 1D parton distributions below or above threshold.
40430 ELSEIF(ISET.EQ.1) THEN
40431 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40432 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40433 XVAL = 1.294D0 * X**0.80D0 * X1**0.76D0
40434 XGLU = 1.273D0 * X**0.40D0 * X1**1.76D0
40435 XSEA = 0.100D0 * X1**3.76D0
40436 ELSE
40437 XVAL = 1.294D0/(1D0+0.252D0*S+3.079D0*S2) *
40438 & X**(0.80D0-0.13D0*S) * X1**(0.76D0+0.667D0*S) * XL**(2D0*S)
40439 XGLU = 7.90D0*S/(1D0+5.50D0*S) * EXP(-5.16D0*S) *
40440 & X**(-1.90D0*S/(1D0+3.60D0*S)) * X1**1.30D0 *
40441 & XL**(0.50D0+3D0*S) + 1.273D0 * EXP(-10D0*S) *
40442 & X**0.40D0 * X1**(1.76D0+3D0*S)
40443 XSEA = (0.1D0-0.397D0*S2+1.121D0*S3)/
40444 & (1D0+5.61D0*S2+5.26D0*S3) * X**(-7.32D0*S2/(1D0+10.3D0*S2)) *
40445 & X1**((3.76D0+15D0*S+12D0*S2)/(1D0+4D0*S))
40446 XSEA0 = 0.100D0 * X1**3.76D0
40447 ENDIF
40448
40449C...Evaluate set 1M parton distributions below or above threshold.
40450 ELSEIF(ISET.EQ.2) THEN
40451 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40452 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40453 XVAL = 0.8477D0 * X**0.51D0 * X1**1.37D0
40454 XGLU = 3.42D0 * X**0.255D0 * X1**2.37D0
40455 XSEA = 0D0
40456 ELSE
40457 XVAL = 0.8477D0/(1D0+1.37D0*S+2.18D0*S2+3.73D0*S3) *
40458 & X**(0.51D0+0.21D0*S) * X1**1.37D0 * XL**(2.667D0*S)
40459 XGLU = 24D0*S/(1D0+9.6D0*S+0.92D0*S2+14.34D0*S3) *
40460 & EXP(-5.94D0*S) * X**((-0.013D0-1.80D0*S)/(1D0+3.14D0*S)) *
40461 & X1**(2.37D0+0.4D0*S) * XL**(0.32D0+3.6D0*S) + 3.42D0 *
40462 & EXP(-12D0*S) * X**0.255D0 * X1**(2.37D0+3D0*S)
40463 XSEA = 0.842D0*S/(1D0+21.3D0*S-33.2D0*S2+229D0*S3) *
40464 & X**((0.13D0-2.90D0*S)/(1D0+5.44D0*S)) * X1**(3.45D0+0.5D0*S) *
40465 & XL**(2.8D0*S)
40466 XSEA0 = 0D0
40467 ENDIF
40468
40469C...Evaluate set 2D parton distributions below or above threshold.
40470 ELSEIF(ISET.EQ.3) THEN
40471 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40472 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40473 XVAL = X**0.46D0 * X1**0.64D0 + 0.76D0 * X
40474 XGLU = 1.925D0 * X1**2
40475 XSEA = 0.242D0 * X1**4
40476 ELSE
40477 XVAL = (1D0+0.186D0*S)/(1D0-0.209D0*S+1.495D0*S2) *
40478 & X**(0.46D0+0.25D0*S) *
40479 & X1**((0.64D0+0.14D0*S+5D0*S2)/(1D0+S)) * XL**(1.9D0*S) +
40480 & (0.76D0+0.4D0*S) * X * X1**(2.667D0*S)
40481 XGLU = (1.925D0+5.55D0*S+147D0*S2)/(1D0-3.59D0*S+3.32D0*S2) *
40482 & EXP(-18.67D0*S) *
40483 & X**((-5.81D0*S-5.34D0*S2)/(1D0+29D0*S-4.26D0*S2))
40484 & * X1**((2D0-5.9D0*S)/(1D0+1.7D0*S)) *
40485 & XL**(9.3D0*S/(1D0+1.7D0*S))
40486 XSEA = (0.242D0-0.252D0*S+1.19D0*S2)/
40487 & (1D0-0.607D0*S+21.95D0*S2) *
40488 & X**(-12.1D0*S2/(1D0+2.62D0*S+16.7D0*S2)) * X1**4 * XL**S
40489 XSEA0 = 0.242D0 * X1**4
40490 ENDIF
40491
40492C...Evaluate set 2M parton distributions below or above threshold.
40493 ELSEIF(ISET.EQ.4) THEN
40494 IF(Q2.LE.P2.OR.(KFA.EQ.4.AND.Q2.LT.PMC**2).OR.
40495 & (KFA.EQ.5.AND.Q2.LT.PMB**2)) THEN
40496 XVAL = 1.168D0 * X**0.50D0 * X1**2.60D0 + 0.965D0 * X
40497 XGLU = 1.808D0 * X1**2
40498 XSEA = 0.209D0 * X1**4
40499 ELSE
40500 XVAL = (1.168D0+1.771D0*S+29.35D0*S2) * EXP(-5.776D0*S) *
40501 & X**((0.5D0+0.208D0*S)/(1D0-0.794D0*S+1.516D0*S2)) *
40502 & X1**((2.6D0+7.6D0*S)/(1D0+5D0*S)) *
40503 & XL**(5.15D0*S/(1D0+2D0*S)) +
40504 & (0.965D0+22.35D0*S)/(1D0+18.4D0*S) * X * X1**(2.667D0*S)
40505 XGLU = (1.808D0+29.9D0*S)/(1D0+26.4D0*S) * EXP(-5.28D0*S) *
40506 & X**((-5.35D0*S-10.11D0*S2)/(1D0+31.71D0*S)) *
40507 & X1**((2D0-7.3D0*S+4D0*S2)/(1D0+2.5D0*S)) *
40508 & XL**(10.9D0*S/(1D0+2.5D0*S))
40509 XSEA = (0.209D0+0.644D0*S2)/(1D0+0.319D0*S+17.6D0*S2) *
40510 & X**((-0.373D0*S-7.71D0*S2)/(1D0+0.815D0*S+11.0D0*S2)) *
40511 & X1**(4D0+S) * XL**(0.45D0*S)
40512 XSEA0 = 0.209D0 * X1**4
40513 ENDIF
40514 ENDIF
40515
40516C...Threshold factors for c and b sea.
40517 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40518 XCHM=0D0
40519 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40520 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40521 IF(ISET.EQ.0) THEN
40522 XCHM=XSEA*(1D0-(SCH/SLL)**2)
40523 ELSE
40524 XCHM=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SCH/SLL)
40525 ENDIF
40526 ENDIF
40527 XBOT=0D0
40528 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40529 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40530 IF(ISET.EQ.0) THEN
40531 XBOT=XSEA*(1D0-(SBT/SLL)**2)
40532 ELSE
40533 XBOT=MAX(0D0,XSEA-XSEA0*X1**(2.667D0*S))*(1D0-SBT/SLL)
40534 ENDIF
40535 ENDIF
40536
40537C...Fill parton distributions.
40538 XPGA(0)=XGLU
40539 XPGA(1)=XSEA
40540 XPGA(2)=XSEA
40541 XPGA(3)=XSEA
40542 XPGA(4)=XCHM
40543 XPGA(5)=XBOT
40544 XPGA(KFA)=XPGA(KFA)+XVAL
40545 DO 110 KFL=1,5
40546 XPGA(-KFL)=XPGA(KFL)
40547 110 CONTINUE
40548 VXPGA(KFA)=XVAL
40549 VXPGA(-KFA)=XVAL
40550
40551 RETURN
40552 END
40553
40554C*********************************************************************
40555
40556C...PYGANO
40557C...Evaluates the parton distributions of the anomalous photon,
40558C...inhomogeneously evolved from a scale P2 (where it vanishes) to Q2.
40559C...KF=0 gives the sum over (up to) 5 flavours,
40560C...KF<0 limits to flavours up to abs(KF),
40561C...KF>0 is for flavour KF only.
40562C...ALAM is the 4-flavour Lambda, which is automatically converted
40563C...to 3- and 5-flavour equivalents as needed.
40564C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40565
40566 SUBROUTINE PYGANO(KF,X,Q2,P2,ALAM,XPGA,VXPGA)
40567
40568C...Double precision and integer declarations.
40569 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40570 IMPLICIT INTEGER(I-N)
40571 INTEGER PYK,PYCHGE,PYCOMP
40572C...Local arrays and data.
40573 DIMENSION XPGA(-6:6), VXPGA(-6:6), ALAMSQ(3:5)
40574 DATA PMC/1.3D0/, PMB/4.6D0/, AEM/0.007297D0/, AEM2PI/0.0011614D0/
40575
40576C...Reset output.
40577 DO 100 KFL=-6,6
40578 XPGA(KFL)=0D0
40579 VXPGA(KFL)=0D0
40580 100 CONTINUE
40581 IF(Q2.LE.P2) RETURN
40582 KFA=IABS(KF)
40583
40584C...Calculate Lambda; protect against unphysical Q2 and P2 input.
40585 ALAMSQ(3)=(ALAM*(PMC/ALAM)**(2D0/27D0))**2
40586 ALAMSQ(4)=ALAM**2
40587 ALAMSQ(5)=(ALAM*(ALAM/PMB)**(2D0/23D0))**2
40588 P2EFF=MAX(P2,1.2D0*ALAMSQ(3))
40589 IF(KF.EQ.4) P2EFF=MAX(P2EFF,PMC**2)
40590 IF(KF.EQ.5) P2EFF=MAX(P2EFF,PMB**2)
40591 Q2EFF=MAX(Q2,P2EFF)
40592 XL=-LOG(X)
40593
40594C...Find number of flavours at lower and upper scale.
40595 NFP=4
40596 IF(P2EFF.LT.PMC**2) NFP=3
40597 IF(P2EFF.GT.PMB**2) NFP=5
40598 NFQ=4
40599 IF(Q2EFF.LT.PMC**2) NFQ=3
40600 IF(Q2EFF.GT.PMB**2) NFQ=5
40601
40602C...Define range of flavour loop.
40603 IF(KF.EQ.0) THEN
40604 KFLMN=1
40605 KFLMX=5
40606 ELSEIF(KF.LT.0) THEN
40607 KFLMN=1
40608 KFLMX=KFA
40609 ELSE
40610 KFLMN=KFA
40611 KFLMX=KFA
40612 ENDIF
40613
40614C...Loop over flavours the photon can branch into.
40615 DO 110 KFL=KFLMN,KFLMX
40616
40617C...Light flavours: calculate t range and (approximate) s range.
40618 IF(KFL.LE.3.AND.(KFL.EQ.1.OR.KFL.EQ.KF)) THEN
40619 TDIFF=LOG(Q2EFF/P2EFF)
40620 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
40621 & LOG(P2EFF/ALAMSQ(NFQ)))
40622 IF(NFQ.GT.NFP) THEN
40623 Q2DIV=PMB**2
40624 IF(NFQ.EQ.4) Q2DIV=PMC**2
40625 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
40626 & LOG(P2EFF/ALAMSQ(NFQ)))
40627 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
40628 & LOG(P2EFF/ALAMSQ(NFQ-1)))
40629 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
40630 ENDIF
40631 IF(NFQ.EQ.5.AND.NFP.EQ.3) THEN
40632 Q2DIV=PMC**2
40633 SNF4=(6D0/(33D0-2D0*4))*LOG(LOG(Q2DIV/ALAMSQ(4))/
40634 & LOG(P2EFF/ALAMSQ(4)))
40635 SNF3=(6D0/(33D0-2D0*3))*LOG(LOG(Q2DIV/ALAMSQ(3))/
40636 & LOG(P2EFF/ALAMSQ(3)))
40637 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNF3-SNF4)
40638 ENDIF
40639
40640C...u and s quark do not need a separate treatment when d has been done.
40641 ELSEIF(KFL.EQ.2.OR.KFL.EQ.3) THEN
40642
40643C...Charm: as above, but only include range above c threshold.
40644 ELSEIF(KFL.EQ.4) THEN
40645 IF(Q2.LE.PMC**2) GOTO 110
40646 P2EFF=MAX(P2EFF,PMC**2)
40647 Q2EFF=MAX(Q2EFF,P2EFF)
40648 TDIFF=LOG(Q2EFF/P2EFF)
40649 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
40650 & LOG(P2EFF/ALAMSQ(NFQ)))
40651 IF(NFQ.EQ.5.AND.NFP.EQ.4) THEN
40652 Q2DIV=PMB**2
40653 SNFQ=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2DIV/ALAMSQ(NFQ))/
40654 & LOG(P2EFF/ALAMSQ(NFQ)))
40655 SNFP=(6D0/(33D0-2D0*(NFQ-1)))*LOG(LOG(Q2DIV/ALAMSQ(NFQ-1))/
40656 & LOG(P2EFF/ALAMSQ(NFQ-1)))
40657 S=S+(LOG(Q2DIV/P2EFF)/LOG(Q2EFF/P2EFF))*(SNFP-SNFQ)
40658 ENDIF
40659
40660C...Bottom: as above, but only include range above b threshold.
40661 ELSEIF(KFL.EQ.5) THEN
40662 IF(Q2.LE.PMB**2) GOTO 110
40663 P2EFF=MAX(P2EFF,PMB**2)
40664 Q2EFF=MAX(Q2,P2EFF)
40665 TDIFF=LOG(Q2EFF/P2EFF)
40666 S=(6D0/(33D0-2D0*NFQ))*LOG(LOG(Q2EFF/ALAMSQ(NFQ))/
40667 & LOG(P2EFF/ALAMSQ(NFQ)))
40668 ENDIF
40669
40670C...Evaluate flavour-dependent prefactor (charge^2 etc.).
40671 CHSQ=1D0/9D0
40672 IF(KFL.EQ.2.OR.KFL.EQ.4) CHSQ=4D0/9D0
40673 FAC=AEM2PI*2D0*CHSQ*TDIFF
40674
40675C...Evaluate parton distributions (normalized to unit momentum sum).
40676 IF(KFL.EQ.1.OR.KFL.EQ.4.OR.KFL.EQ.5.OR.KFL.EQ.KF) THEN
40677 XVAL= ((1.5D0+2.49D0*S+26.9D0*S**2)/(1D0+32.3D0*S**2)*X**2 +
40678 & (1.5D0-0.49D0*S+7.83D0*S**2)/(1D0+7.68D0*S**2)*(1D0-X)**2 +
40679 & 1.5D0*S/(1D0-3.2D0*S+7D0*S**2)*X*(1D0-X)) *
40680 & X**(1D0/(1D0+0.58D0*S)) * (1D0-X**2)**(2.5D0*S/(1D0+10D0*S))
40681 XGLU= 2D0*S/(1D0+4D0*S+7D0*S**2) *
40682 & X**(-1.67D0*S/(1D0+2D0*S)) * (1D0-X**2)**(1.2D0*S) *
40683 & ((4D0*X**2+7D0*X+4D0)*(1D0-X)/3D0 - 2D0*X*(1D0+X)*XL)
40684 XSEA= 0.333D0*S**2/(1D0+4.90D0*S+4.69D0*S**2+21.4D0*S**3) *
40685 & X**(-1.18D0*S/(1D0+1.22D0*S)) * (1D0-X)**(1.2D0*S) *
40686 & ((8D0-73D0*X+62D0*X**2)*(1D0-X)/9D0 +
40687 & (3D0-8D0*X**2/3D0)*X*XL + (2D0*X-1D0)*X*XL**2)
40688
40689C...Threshold factors for c and b sea.
40690 SLL=LOG(LOG(Q2EFF/ALAM**2)/LOG(P2EFF/ALAM**2))
40691 XCHM=0D0
40692 IF(Q2.GT.PMC**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40693 SCH=MAX(0D0,LOG(LOG(PMC**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40694 XCHM=XSEA*(1D0-(SCH/SLL)**3)
40695 ENDIF
40696 XBOT=0D0
40697 IF(Q2.GT.PMB**2.AND.Q2.GT.1.001D0*P2EFF) THEN
40698 SBT=MAX(0D0,LOG(LOG(PMB**2/ALAM**2)/LOG(P2EFF/ALAM**2)))
40699 XBOT=XSEA*(1D0-(SBT/SLL)**3)
40700 ENDIF
40701 ENDIF
40702
40703C...Add contribution of each valence flavour.
40704 XPGA(0)=XPGA(0)+FAC*XGLU
40705 XPGA(1)=XPGA(1)+FAC*XSEA
40706 XPGA(2)=XPGA(2)+FAC*XSEA
40707 XPGA(3)=XPGA(3)+FAC*XSEA
40708 XPGA(4)=XPGA(4)+FAC*XCHM
40709 XPGA(5)=XPGA(5)+FAC*XBOT
40710 XPGA(KFL)=XPGA(KFL)+FAC*XVAL
40711 VXPGA(KFL)=VXPGA(KFL)+FAC*XVAL
40712 110 CONTINUE
40713 DO 120 KFL=1,5
40714 XPGA(-KFL)=XPGA(KFL)
40715 VXPGA(-KFL)=VXPGA(KFL)
40716 120 CONTINUE
40717
40718 RETURN
40719 END
40720
40721
40722C*********************************************************************
40723
40724C...PYGBEH
40725C...Evaluates the Bethe-Heitler cross section for heavy flavour
40726C...production.
40727C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40728
40729 SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)
40730
40731C...Double precision and integer declarations.
40732 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40733 IMPLICIT INTEGER(I-N)
40734 INTEGER PYK,PYCHGE,PYCOMP
40735
40736C...Local data.
40737 DATA AEM2PI/0.0011614D0/
40738
40739C...Reset output.
40740 XPBH=0D0
40741 SIGBH=0D0
40742
40743C...Check kinematics limits.
40744 IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
40745 W2=Q2*(1D0-X)/X-P2
40746 BETA2=1D0-4D0*PM2/W2
40747 IF(BETA2.LT.1D-10) RETURN
40748 BETA=SQRT(BETA2)
40749 RMQ=4D0*PM2/Q2
40750
40751C...Simple case: P2 = 0.
40752 IF(P2.LT.1D-4) THEN
40753 IF(BETA.LT.0.99D0) THEN
40754 XBL=LOG((1D0+BETA)/(1D0-BETA))
40755 ELSE
40756 XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
40757 ENDIF
40758 SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
40759 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)
40760
40761C...Complicated case: P2 > 0, based on approximation of
40762C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
40763 ELSE
40764 RPQ=1D0-4D0*X**2*P2/Q2
40765 IF(RPQ.GT.1D-10) THEN
40766 RPBE=SQRT(RPQ*BETA2)
40767 IF(RPBE.LT.0.99D0) THEN
40768 XBL=LOG((1D0+RPBE)/(1D0-RPBE))
40769 XBI=2D0*RPBE/(1D0-RPBE**2)
40770 ELSE
40771 RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
40772 XBL=LOG((1D0+RPBE)**2/RPBESN)
40773 XBI=2D0*RPBE/RPBESN
40774 ENDIF
40775 SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
40776 & XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
40777 & XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
40778 ENDIF
40779 ENDIF
40780
40781C...Multiply by charge-squared etc. to get parton distribution.
40782 CHSQ=1D0/9D0
40783 IF(IABS(KF).EQ.2.OR.IABS(KF).EQ.4) CHSQ=4D0/9D0
40784 XPBH=3D0*CHSQ*AEM2PI*X*SIGBH
40785
40786 RETURN
40787 END
40788
40789C*********************************************************************
40790
40791C...PYGDIR
40792C...Evaluates the direct contribution, i.e. the C^gamma term,
40793C...as needed in MSbar parametrizations.
40794C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.
40795
40796 SUBROUTINE PYGDIR(X,Q2,P2,Q02,XPGA)
40797
40798C...Double precision and integer declarations.
40799 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40800 IMPLICIT INTEGER(I-N)
40801 INTEGER PYK,PYCHGE,PYCOMP
40802C...Local array and data.
40803 DIMENSION XPGA(-6:6)
40804 DATA PMC/1.3D0/, PMB/4.6D0/, AEM2PI/0.0011614D0/
40805
40806C...Reset output.
40807 DO 100 KFL=-6,6
40808 XPGA(KFL)=0D0
40809 100 CONTINUE
40810
40811C...Evaluate common x-dependent expression.
40812 XTMP = (X**2+(1D0-X)**2) * (-LOG(X)) - 1D0
40813 CGAM = 3D0*AEM2PI*X * (XTMP*(1D0+P2/(P2+Q02)) + 6D0*X*(1D0-X))
40814
40815C...d, u, s part by simple charge factor.
40816 XPGA(1)=(1D0/9D0)*CGAM
40817 XPGA(2)=(4D0/9D0)*CGAM
40818 XPGA(3)=(1D0/9D0)*CGAM
40819
40820C...Also fill for antiquarks.
40821 DO 110 KF=1,5
40822 XPGA(-KF)=XPGA(KF)
40823 110 CONTINUE
40824
40825 RETURN
40826 END
40827
40828C*********************************************************************
40829
40830C...PYPDPI
40831C...Gives pi+ parton distribution according to two different
40832C...parametrizations.
40833
40834 SUBROUTINE PYPDPI(X,Q2,XPPI)
40835
40836C...Double precision and integer declarations.
40837 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
40838 IMPLICIT INTEGER(I-N)
40839 INTEGER PYK,PYCHGE,PYCOMP
40840C...Commonblocks.
40841 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
40842 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
40843 COMMON/PYINT1/MINT(400),VINT(400)
40844 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
40845C...Local arrays.
40846 DIMENSION XPPI(-6:6),COW(3,5,4,2),XQ(9),TS(6)
40847
40848C...The following data lines are coefficients needed in the
40849C...Owens pion parton distribution parametrizations, see below.
40850C...Expansion coefficients for up and down valence quark distributions.
40851 DATA ((COW(IP,IS,1,1),IS=1,5),IP=1,3)/
40852 &4.0000D-01, 7.0000D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40853 &-6.2120D-02, 6.4780D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40854 &-7.1090D-03, 1.3350D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40855 DATA ((COW(IP,IS,1,2),IS=1,5),IP=1,3)/
40856 &4.0000D-01, 6.2800D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40857 &-5.9090D-02, 6.4360D-01, 0.0000D+00, 0.0000D+00, 0.0000D+00,
40858 &-6.5240D-03, 1.4510D-02, 0.0000D+00, 0.0000D+00, 0.0000D+00/
40859C...Expansion coefficients for gluon distribution.
40860 DATA ((COW(IP,IS,2,1),IS=1,5),IP=1,3)/
40861 &8.8800D-01, 0.0000D+00, 3.1100D+00, 6.0000D+00, 0.0000D+00,
40862 &-1.8020D+00, -1.5760D+00, -1.3170D-01, 2.8010D+00, -1.7280D+01,
40863 &1.8120D+00, 1.2000D+00, 5.0680D-01, -1.2160D+01, 2.0490D+01/
40864 DATA ((COW(IP,IS,2,2),IS=1,5),IP=1,3)/
40865 &7.9400D-01, 0.0000D+00, 2.8900D+00, 6.0000D+00, 0.0000D+00,
40866 &-9.1440D-01, -1.2370D+00, 5.9660D-01, -3.6710D+00, -8.1910D+00,
40867 &5.9660D-01, 6.5820D-01, -2.5500D-01, -2.3040D+00, 7.7580D+00/
40868C...Expansion coefficients for (up+down+strange) quark sea distribution.
40869 DATA ((COW(IP,IS,3,1),IS=1,5),IP=1,3)/
40870 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40871 &-2.4280D-01, -2.1200D-01, 8.6730D-01, 1.2660D+00, 2.3820D+00,
40872 &1.3860D-01, 3.6710D-03, 4.7470D-02, -2.2150D+00, 3.4820D-01/
40873 DATA ((COW(IP,IS,3,2),IS=1,5),IP=1,3)/
40874 &9.0000D-01, 0.0000D+00, 5.0000D+00, 0.0000D+00, 0.0000D+00,
40875 &-1.4170D-01, -1.6970D-01, -2.4740D+00, -2.5340D+00, 5.6210D-01,
40876 &-1.7400D-01, -9.6230D-02, 1.5750D+00, 1.3780D+00, -2.7010D-01/
40877C...Expansion coefficients for charm quark sea distribution.
40878 DATA ((COW(IP,IS,4,1),IS=1,5),IP=1,3)/
40879 &0.0000D+00, -2.2120D-02, 2.8940D+00, 0.0000D+00, 0.0000D+00,
40880 &7.9280D-02, -3.7850D-01, 9.4330D+00, 5.2480D+00, 8.3880D+00,
40881 &-6.1340D-02, -1.0880D-01, -1.0852D+01, -7.1870D+00, -1.1610D+01/
40882 DATA ((COW(IP,IS,4,2),IS=1,5),IP=1,3)/
40883 &0.0000D+00, -8.8200D-02, 1.9240D+00, 0.0000D+00, 0.0000D+00,
40884 &6.2290D-02, -2.8920D-01, 2.4240D-01, -4.4630D+00, -8.3670D-01,
40885 &-4.0990D-02, -1.0820D-01, 2.0360D+00, 5.2090D+00, -4.8400D-02/
40886
40887C...Euler's beta function, requires ordinary Gamma function
40888 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
40889
40890C...Reset output array.
40891 DO 100 KFL=-6,6
40892 XPPI(KFL)=0D0
40893 100 CONTINUE
40894
40895 IF(MSTP(53).LE.2) THEN
40896C...Pion parton distributions from Owens.
40897C...Allowed variable range: 4 GeV^2 < Q^2 < approx 2000 GeV^2.
40898
40899C...Determine set, Lambda and s expansion variable.
40900 NSET=MSTP(53)
40901 IF(NSET.EQ.1) ALAM=0.2D0
40902 IF(NSET.EQ.2) ALAM=0.4D0
40903 VINT(231)=4D0
40904 IF(MSTP(57).LE.0) THEN
40905 SD=0D0
40906 ELSE
40907 Q2IN=MIN(2D3,MAX(4D0,Q2))
40908 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
40909 ENDIF
40910
40911C...Calculate parton distributions.
40912 DO 120 KFL=1,4
40913 DO 110 IS=1,5
40914 TS(IS)=COW(1,IS,KFL,NSET)+COW(2,IS,KFL,NSET)*SD+
40915 & COW(3,IS,KFL,NSET)*SD**2
40916 110 CONTINUE
40917 IF(KFL.EQ.1) THEN
40918 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)/EULBET(TS(1),TS(2)+1D0)
40919 ELSE
40920 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
40921 & TS(5)*X**2)
40922 ENDIF
40923 120 CONTINUE
40924
40925C...Put into output array.
40926 XPPI(0)=XQ(2)
40927 XPPI(1)=XQ(3)/6D0
40928 XPPI(2)=XQ(1)+XQ(3)/6D0
40929 XPPI(3)=XQ(3)/6D0
40930 XPPI(4)=XQ(4)
40931 XPPI(-1)=XQ(1)+XQ(3)/6D0
40932 XPPI(-2)=XQ(3)/6D0
40933 XPPI(-3)=XQ(3)/6D0
40934 XPPI(-4)=XQ(4)
40935
40936C...Leading order pion parton distributions from Glueck, Reya and Vogt.
40937C...Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
40938C...10^-5 < x < 1.
40939 ELSE
40940
40941C...Determine s expansion variable and some x expressions.
40942 VINT(231)=0.25D0
40943 IF(MSTP(57).LE.0) THEN
40944 SD=0D0
40945 ELSE
40946 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
40947 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
40948 ENDIF
40949 SD2=SD**2
40950 XL=-LOG(X)
40951 XS=SQRT(X)
40952
40953C...Evaluate valence, gluon and sea distributions.
40954 XFVAL=(0.519D0+0.180D0*SD-0.011D0*SD2)*X**(0.499D0-0.027D0*SD)*
40955 & (1D0+(0.381D0-0.419D0*SD)*XS)*(1D0-X)**(0.367D0+0.563D0*SD)
40956 XFGLU=(X**(0.482D0+0.341D0*SQRT(SD))*((0.678D0+0.877D0*
40957 & SD-0.175D0*SD2)+
40958 & (0.338D0-1.597D0*SD)*XS+(-0.233D0*SD+0.406D0*SD2)*X)+
40959 & SD**0.599D0*EXP(-(0.618D0+2.070D0*SD)+SQRT(3.676D0*SD**1.263D0*
40960 & XL)))*
40961 & (1D0-X)**(0.390D0+1.053D0*SD)
40962 XFSEA=SD**0.55D0*(1D0-0.748D0*XS+(0.313D0+0.935D0*SD)*X)*(1D0-
40963 & X)**3.359D0*
40964 & EXP(-(4.433D0+1.301D0*SD)+SQRT((9.30D0-0.887D0*SD)*SD**0.56D0*
40965 & XL))/
40966 & XL**(2.538D0-0.763D0*SD)
40967 IF(SD.LE.0.888D0) THEN
40968 XFCHM=0D0
40969 ELSE
40970 XFCHM=(SD-0.888D0)**1.02D0*(1D0+1.008D0*X)*(1D0-X)**(1.208D0+
40971 & 0.771D0*SD)*
40972 & EXP(-(4.40D0+1.493D0*SD)+SQRT((2.032D0+1.901D0*SD)*SD**0.39D0*
40973 & XL))
40974 ENDIF
40975 IF(SD.LE.1.351D0) THEN
40976 XFBOT=0D0
40977 ELSE
40978 XFBOT=(SD-1.351D0)**1.03D0*(1D0-X)**(0.697D0+0.855D0*SD)*
40979 & EXP(-(4.51D0+1.490D0*SD)+SQRT((3.056D0+1.694D0*SD)*SD**0.39D0*
40980 & XL))
40981 ENDIF
40982
40983C...Put into output array.
40984 XPPI(0)=XFGLU
40985 XPPI(1)=XFSEA
40986 XPPI(2)=XFSEA
40987 XPPI(3)=XFSEA
40988 XPPI(4)=XFCHM
40989 XPPI(5)=XFBOT
40990 DO 130 KFL=1,5
40991 XPPI(-KFL)=XPPI(KFL)
40992 130 CONTINUE
40993 XPPI(2)=XPPI(2)+XFVAL
40994 XPPI(-1)=XPPI(-1)+XFVAL
40995 ENDIF
40996
40997 RETURN
40998 END
40999
41000C*********************************************************************
41001
41002C...PYPDPR
41003C...Gives proton parton distributions according to a few different
41004C...parametrizations.
41005
41006 SUBROUTINE PYPDPR(X,Q2,XPPR)
41007
41008C...Double precision and integer declarations.
41009 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41010 IMPLICIT INTEGER(I-N)
41011 INTEGER PYK,PYCHGE,PYCOMP
41012C...Commonblocks.
41013 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
41014 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
41015 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
41016 COMMON/PYINT1/MINT(400),VINT(400)
41017 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
41018C...Arrays and data.
41019 DIMENSION XPPR(-6:6),Q2MIN(16)
41020 DATA Q2MIN/ 2.56D0, 2.56D0, 2.56D0, 0.4D0, 0.4D0, 0.4D0,
41021 &1.0D0, 1.0D0, 2*0D0, 0.25D0, 5D0, 5D0, 4D0, 4D0, 0D0/
41022
41023C...Reset output array.
41024 DO 100 KFL=-6,6
41025 XPPR(KFL)=0D0
41026 100 CONTINUE
41027
41028C...Common preliminaries.
41029 NSET=MAX(1,MIN(16,MSTP(51)))
41030 IF(NSET.EQ.9.OR.NSET.EQ.10) NSET=6
41031 VINT(231)=Q2MIN(NSET)
41032 IF(MSTP(57).EQ.0) THEN
41033 Q2L=Q2MIN(NSET)
41034 ELSE
41035 Q2L=MAX(Q2MIN(NSET),Q2)
41036 ENDIF
41037
41038 IF(NSET.GE.1.AND.NSET.LE.3) THEN
41039C...Interface to the CTEQ 3 parton distributions.
41040 QRT=SQRT(MAX(1D0,Q2L))
41041
41042C...Loop over flavours.
41043 DO 110 I=-6,6
41044 IF(I.LE.0) THEN
41045 XPPR(I)=PYCTEQ(NSET,I,X,QRT)
41046 ELSEIF(I.LE.2) THEN
41047 XPPR(I)=PYCTEQ(NSET,I,X,QRT)+XPPR(-I)
41048 ELSE
41049 XPPR(I)=XPPR(-I)
41050 ENDIF
41051 110 CONTINUE
41052
41053 ELSEIF(NSET.GE.4.AND.NSET.LE.6) THEN
41054C...Interface to the GRV 94 distributions.
41055 IF(NSET.EQ.4) THEN
41056 CALL PYGRVL (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41057 ELSEIF(NSET.EQ.5) THEN
41058 CALL PYGRVM (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41059 ELSE
41060 CALL PYGRVD (X, Q2L, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41061 ENDIF
41062
41063C...Put into output array.
41064 XPPR(0)=GL
41065 XPPR(-1)=0.5D0*(UDB+DEL)
41066 XPPR(-2)=0.5D0*(UDB-DEL)
41067 XPPR(-3)=SB
41068 XPPR(-4)=CHM
41069 XPPR(-5)=BOT
41070 XPPR(1)=DV+XPPR(-1)
41071 XPPR(2)=UV+XPPR(-2)
41072 XPPR(3)=SB
41073 XPPR(4)=CHM
41074 XPPR(5)=BOT
41075
41076 ELSEIF(NSET.EQ.7) THEN
41077C...Interface to the CTEQ 5L parton distributions.
41078C...Range of validity 10^-6 < x < 1, 1 < Q < 10^4 extended by
41079C...freezing x*f(x,Q2) at borders.
41080 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
41081 XIN=MAX(1D-6,MIN(1D0,X))
41082
41083C...Loop over flavours (with u <-> d notation mismatch).
41084 SUMUDB=PYCT5L(-1,XIN,QRT)
41085 RATUDB=PYCT5L(-2,XIN,QRT)
41086 DO 120 I=-5,2
41087 IF(I.EQ.1) THEN
41088 XPPR(I)=XIN*PYCT5L(2,XIN,QRT)
41089 ELSEIF(I.EQ.2) THEN
41090 XPPR(I)=XIN*PYCT5L(1,XIN,QRT)
41091 ELSEIF(I.EQ.-1) THEN
41092 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
41093 ELSEIF(I.EQ.-2) THEN
41094 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
41095 ELSE
41096 XPPR(I)=XIN*PYCT5L(I,XIN,QRT)
41097 IF(I.LT.0) XPPR(-I)=XPPR(I)
41098 ENDIF
41099 120 CONTINUE
41100
41101 ELSEIF(NSET.EQ.8) THEN
41102C...Interface to the CTEQ 5M1 parton distributions.
41103 QRT=SQRT(MAX(1D0,MIN(1D8,Q2L)))
41104 XIN=MAX(1D-6,MIN(1D0,X))
41105
41106C...Loop over flavours (with u <-> d notation mismatch).
41107 SUMUDB=PYCT5M(-1,XIN,QRT)
41108 RATUDB=PYCT5M(-2,XIN,QRT)
41109 DO 130 I=-5,2
41110 IF(I.EQ.1) THEN
41111 XPPR(I)=XIN*PYCT5M(2,XIN,QRT)
41112 ELSEIF(I.EQ.2) THEN
41113 XPPR(I)=XIN*PYCT5M(1,XIN,QRT)
41114 ELSEIF(I.EQ.-1) THEN
41115 XPPR(I)=XIN*SUMUDB*RATUDB/(1D0+RATUDB)
41116 ELSEIF(I.EQ.-2) THEN
41117 XPPR(I)=XIN*SUMUDB/(1D0+RATUDB)
41118 ELSE
41119 XPPR(I)=XIN*PYCT5M(I,XIN,QRT)
41120 IF(I.LT.0) XPPR(-I)=XPPR(I)
41121 ENDIF
41122 130 CONTINUE
41123
41124 ELSEIF(NSET.GE.11.AND.NSET.LE.15) THEN
41125C...GRV92LO, EHLQ1, EHLQ2, DO1 AND DO2 distributions:
41126C...obsolete but offers backwards compatibility.
41127 CALL PYPDPO(X,Q2L,XPPR)
41128
41129C...Symmetric choice for debugging only
41130 ELSEIF(NSET.EQ.16) THEN
41131 XPPR(0)=.5D0/X
41132 XPPR(1)=.05D0/X
41133 XPPR(2)=.05D0/X
41134 XPPR(3)=.05D0/X
41135 XPPR(4)=.05D0/X
41136 XPPR(5)=.05D0/X
41137 XPPR(-1)=.05D0/X
41138 XPPR(-2)=.05D0/X
41139 XPPR(-3)=.05D0/X
41140 XPPR(-4)=.05D0/X
41141 XPPR(-5)=.05D0/X
41142
41143 ENDIF
41144
41145 RETURN
41146 END
41147
41148C*********************************************************************
41149
41150C...PYCTEQ
41151C...Gives the CTEQ 3 parton distribution function sets in
41152C...parametrized form, of October 24, 1994.
41153C...Authors: H.L. Lai, J. Botts, J. Huston, J.G. Morfin, J.F. Owens,
41154C...J. Qiu, W.K. Tung and H. Weerts.
41155
41156 FUNCTION PYCTEQ (ISET, IPRT, X, Q)
41157
41158C...Double precision declaration.
41159 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41160 IMPLICIT INTEGER(I-N)
41161
41162C...Data on Lambda values of fits, minimum Q and quark masses.
41163 DIMENSION ALM(3), QMS(4:6)
41164 DATA ALM / 0.177D0, 0.239D0, 0.247D0 /
41165 DATA QMN / 1.60D0 /, (QMS(I), I=4,6) / 1.60D0, 5.00D0, 180.0D0 /
41166
41167C....Check flavour thresholds. Set up QI for SB.
41168 IP = IABS(IPRT)
41169 IF(IP .GE. 4) THEN
41170 IF(Q .LE. QMS(IP)) THEN
41171 PYCTEQ = 0D0
41172 RETURN
41173 ENDIF
41174 QI = QMS(IP)
41175 ELSE
41176 QI = QMN
41177 ENDIF
41178
41179C...Use "standard lambda" of parametrization program for expansion.
41180 ALAM = ALM (ISET)
41181 SBL = LOG(Q/ALAM) / LOG(QI/ALAM)
41182 SB = LOG (SBL)
41183 SB2 = SB*SB
41184 SB3 = SB2*SB
41185
41186C...Expansion for CTEQ3L.
41187 IF(ISET .EQ. 1) THEN
41188 IF(IPRT .EQ. 2) THEN
41189 A0=Exp( 0.1907D+00+0.4205D-01*SB +0.2752D+00*SB2-
41190 & 0.3171D+00*SB3)
41191 A1= 0.4611D+00+0.2331D-01*SB -0.3403D-01*SB2+0.3174D-01*SB3
41192 A2= 0.3504D+01+0.5739D+00*SB +0.2676D+00*SB2-0.1553D+00*SB3
41193 A3= 0.7452D+01-0.6742D+01*SB +0.2849D+01*SB2-0.1964D+00*SB3
41194 A4= 0.1116D+01-0.3435D+00*SB +0.2865D+00*SB2-0.1288D+00*SB3
41195 A5= 0.6659D-01+0.2714D+00*SB -0.2688D+00*SB2+0.2763D+00*SB3
41196 ELSEIF(IPRT .EQ. 1) THEN
41197 A0=Exp( 0.1141D+00+0.4764D+00*SB -0.1745D+01*SB2+
41198 & 0.7728D+00*SB3)
41199 A1= 0.4275D+00-0.1290D+00*SB +0.3609D+00*SB2-0.1689D+00*SB3
41200 A2= 0.3000D+01+0.2946D+01*SB -0.4117D+01*SB2+0.1989D+01*SB3
41201 A3=-0.1302D+01+0.2322D+01*SB -0.4258D+01*SB2+0.2109D+01*SB3
41202 A4= 0.2586D+01-0.1920D+00*SB -0.3754D+00*SB2+0.2731D+00*SB3
41203 A5=-0.2251D+00-0.5374D+00*SB +0.2245D+01*SB2-0.1034D+01*SB3
41204 ELSEIF(IPRT .EQ. 0) THEN
41205 A0=Exp(-0.7631D+00-0.7241D+00*SB -0.1170D+01*SB2+
41206 & 0.5343D+00*SB3)
41207 A1=-0.3573D+00+0.3469D+00*SB -0.3396D+00*SB2+0.9188D-01*SB3
41208 A2= 0.5604D+01+0.7458D+00*SB -0.5082D+00*SB2+0.1844D+00*SB3
41209 A3= 0.1549D+02-0.1809D+02*SB +0.1162D+02*SB2-0.3483D+01*SB3
41210 A4= 0.9881D+00+0.1364D+00*SB -0.4421D+00*SB2+0.2051D+00*SB3
41211 A5=-0.9505D-01+0.3259D+01*SB -0.1547D+01*SB2+0.2918D+00*SB3
41212 ELSEIF(IPRT .EQ. -1) THEN
41213 A0=Exp(-0.2449D+01-0.3513D+01*SB +0.4529D+01*SB2-
41214 & 0.2031D+01*SB3)
41215 A1=-0.4050D+00+0.3411D+00*SB -0.3669D+00*SB2+0.1109D+00*SB3
41216 A2= 0.7470D+01-0.2982D+01*SB +0.5503D+01*SB2-0.2419D+01*SB3
41217 A3= 0.1503D+02+0.1638D+01*SB -0.8772D+01*SB2+0.3852D+01*SB3
41218 A4= 0.1137D+01-0.1006D+01*SB +0.1485D+01*SB2-0.6389D+00*SB3
41219 A5=-0.5299D+00+0.3160D+01*SB -0.3104D+01*SB2+0.1219D+01*SB3
41220 ELSEIF(IPRT .EQ. -2) THEN
41221 A0=Exp(-0.2740D+01-0.7987D-01*SB -0.9015D+00*SB2-
41222 & 0.9872D-01*SB3)
41223 A1=-0.3909D+00+0.1244D+00*SB -0.4487D-01*SB2+0.1277D-01*SB3
41224 A2= 0.9163D+01+0.2823D+00*SB -0.7720D+00*SB2-0.9360D-02*SB3
41225 A3= 0.1080D+02-0.3915D+01*SB -0.1153D+01*SB2+0.2649D+01*SB3
41226 A4= 0.9894D+00-0.1647D+00*SB -0.9426D-02*SB2+0.2945D-02*SB3
41227 A5=-0.3395D+00+0.6998D+00*SB +0.7000D+00*SB2-0.6730D-01*SB3
41228 ELSEIF(IPRT .EQ. -3) THEN
41229 A0=Exp(-0.3640D+01+0.1250D+01*SB -0.2914D+01*SB2+
41230 & 0.8390D+00*SB3)
41231 A1=-0.3595D+00-0.5259D-01*SB +0.3122D+00*SB2-0.1642D+00*SB3
41232 A2= 0.7305D+01+0.9727D+00*SB -0.9788D+00*SB2-0.5193D-01*SB3
41233 A3= 0.1198D+02-0.1799D+02*SB +0.2614D+02*SB2-0.1091D+02*SB3
41234 A4= 0.9882D+00-0.6101D+00*SB +0.9737D+00*SB2-0.4935D+00*SB3
41235 A5=-0.1186D+00-0.3231D+00*SB +0.3074D+01*SB2-0.1274D+01*SB3
41236 ELSEIF(IPRT .EQ. -4) THEN
41237 A0=SB** 0.1122D+01*Exp(-0.3718D+01-0.1335D+01*SB +
41238 & 0.1651D-01*SB2)
41239 A1=-0.4719D+00+0.7509D+00*SB -0.8420D+00*SB2+0.2901D+00*SB3
41240 A2= 0.6194D+01-0.1641D+01*SB +0.4907D+01*SB2-0.2523D+01*SB3
41241 A3= 0.4426D+01-0.4270D+01*SB +0.6581D+01*SB2-0.3474D+01*SB3
41242 A4= 0.2683D+00+0.9876D+00*SB -0.7612D+00*SB2+0.1780D+00*SB3
41243 A5=-0.4547D+00+0.4410D+01*SB -0.3712D+01*SB2+0.1245D+01*SB3
41244 ELSEIF(IPRT .EQ. -5) THEN
41245 A0=SB** 0.9838D+00*Exp(-0.2548D+01-0.7660D+01*SB +
41246 & 0.3702D+01*SB2)
41247 A1=-0.3122D+00-0.2120D+00*SB +0.5716D+00*SB2-0.3773D+00*SB3
41248 A2= 0.6257D+01-0.8214D-01*SB -0.2537D+01*SB2+0.2981D+01*SB3
41249 A3=-0.6723D+00+0.2131D+01*SB +0.9599D+01*SB2-0.7910D+01*SB3
41250 A4= 0.9169D-01+0.4295D-01*SB -0.5017D+00*SB2+0.3811D+00*SB3
41251 A5= 0.2402D+00+0.2656D+01*SB -0.1586D+01*SB2+0.2880D+00*SB3
41252 ELSEIF(IPRT .EQ. -6) THEN
41253 A0=SB** 0.1001D+01*Exp(-0.6934D+01+0.3050D+01*SB -
41254 & 0.6943D+00*SB2)
41255 A1=-0.1713D+00-0.5167D+00*SB +0.1241D+01*SB2-0.1703D+01*SB3
41256 A2= 0.6169D+01+0.3023D+01*SB -0.1972D+02*SB2+0.1069D+02*SB3
41257 A3= 0.4439D+01-0.1746D+02*SB +0.1225D+02*SB2+0.8350D+00*SB3
41258 A4= 0.5458D+00-0.4586D+00*SB +0.9089D+00*SB2-0.4049D+00*SB3
41259 A5= 0.3207D+01-0.3362D+01*SB +0.5877D+01*SB2-0.7659D+01*SB3
41260 ENDIF
41261
41262C...Expansion for CTEQ3M.
41263 ELSEIF(ISET .EQ. 2) THEN
41264 IF(IPRT .EQ. 2) THEN
41265 A0=Exp( 0.2259D+00+0.1237D+00*SB +0.3035D+00*SB2-
41266 & 0.2935D+00*SB3)
41267 A1= 0.5085D+00+0.1651D-01*SB -0.3592D-01*SB2+0.2782D-01*SB3
41268 A2= 0.3732D+01+0.4901D+00*SB +0.2218D+00*SB2-0.1116D+00*SB3
41269 A3= 0.7011D+01-0.6620D+01*SB +0.2557D+01*SB2-0.1360D+00*SB3
41270 A4= 0.8969D+00-0.2429D+00*SB +0.1811D+00*SB2-0.6888D-01*SB3
41271 A5= 0.8636D-01+0.2558D+00*SB -0.3082D+00*SB2+0.2535D+00*SB3
41272 ELSEIF(IPRT .EQ. 1) THEN
41273 A0=Exp(-0.7266D+00-0.1584D+01*SB +0.1259D+01*SB2-
41274 & 0.4305D-01*SB3)
41275 A1= 0.5285D+00-0.3721D+00*SB +0.5150D+00*SB2-0.1697D+00*SB3
41276 A2= 0.4075D+01+0.8282D+00*SB -0.4496D+00*SB2+0.2107D+00*SB3
41277 A3= 0.3279D+01+0.5066D+01*SB -0.9134D+01*SB2+0.2897D+01*SB3
41278 A4= 0.4399D+00-0.5888D+00*SB +0.4802D+00*SB2-0.1664D+00*SB3
41279 A5= 0.3678D+00-0.8929D+00*SB +0.1592D+01*SB2-0.5713D+00*SB3
41280 ELSEIF(IPRT .EQ. 0) THEN
41281 A0=Exp(-0.2318D+00-0.9779D+00*SB -0.3783D+00*SB2+
41282 & 0.1037D-01*SB3)
41283 A1=-0.2916D+00+0.1754D+00*SB -0.1884D+00*SB2+0.6116D-01*SB3
41284 A2= 0.5349D+01+0.7460D+00*SB +0.2319D+00*SB2-0.2622D+00*SB3
41285 A3= 0.6920D+01-0.3454D+01*SB +0.2027D+01*SB2-0.7626D+00*SB3
41286 A4= 0.1013D+01+0.1423D+00*SB -0.1798D+00*SB2+0.1872D-01*SB3
41287 A5=-0.5465D-01+0.2303D+01*SB -0.9584D+00*SB2+0.3098D+00*SB3
41288 ELSEIF(IPRT .EQ. -1) THEN
41289 A0=Exp(-0.2328D+01-0.3061D+01*SB +0.3620D+01*SB2-
41290 & 0.1602D+01*SB3)
41291 A1=-0.3358D+00+0.3198D+00*SB -0.4210D+00*SB2+0.1571D+00*SB3
41292 A2= 0.8478D+01-0.3112D+01*SB +0.5243D+01*SB2-0.2255D+01*SB3
41293 A3= 0.1971D+02+0.3389D+00*SB -0.5268D+01*SB2+0.2099D+01*SB3
41294 A4= 0.1128D+01-0.4701D+00*SB +0.7779D+00*SB2-0.3506D+00*SB3
41295 A5=-0.4708D+00+0.3341D+01*SB -0.3375D+01*SB2+0.1353D+01*SB3
41296 ELSEIF(IPRT .EQ. -2) THEN
41297 A0=Exp(-0.2906D+01-0.1069D+00*SB -0.1055D+01*SB2+
41298 & 0.2496D+00*SB3)
41299 A1=-0.2875D+00+0.6571D-01*SB -0.1987D-01*SB2-0.1800D-02*SB3
41300 A2= 0.9854D+01-0.2715D+00*SB -0.7407D+00*SB2+0.2888D+00*SB3
41301 A3= 0.1583D+02-0.7687D+01*SB +0.3428D+01*SB2-0.3327D+00*SB3
41302 A4= 0.9763D+00+0.7599D-01*SB -0.2128D+00*SB2+0.6852D-01*SB3
41303 A5=-0.8444D-02+0.9434D+00*SB +0.4152D+00*SB2-0.1481D+00*SB3
41304 ELSEIF(IPRT .EQ. -3) THEN
41305 A0=Exp(-0.3780D+01+0.2499D+01*SB -0.4962D+01*SB2+
41306 & 0.1936D+01*SB3)
41307 A1=-0.2639D+00-0.1575D+00*SB +0.3584D+00*SB2-0.1646D+00*SB3
41308 A2= 0.8082D+01+0.2794D+01*SB -0.5438D+01*SB2+0.2321D+01*SB3
41309 A3= 0.1811D+02-0.2000D+02*SB +0.1951D+02*SB2-0.6904D+01*SB3
41310 A4= 0.9822D+00+0.4972D+00*SB -0.8690D+00*SB2+0.3415D+00*SB3
41311 A5= 0.1772D+00-0.6078D+00*SB +0.3341D+01*SB2-0.1473D+01*SB3
41312 ELSEIF(IPRT .EQ. -4) THEN
41313 A0=SB** 0.1122D+01*Exp(-0.4232D+01-0.1808D+01*SB +
41314 & 0.5348D+00*SB2)
41315 A1=-0.2824D+00+0.5846D+00*SB -0.7230D+00*SB2+0.2419D+00*SB3
41316 A2= 0.5683D+01-0.2948D+01*SB +0.5916D+01*SB2-0.2560D+01*SB3
41317 A3= 0.2051D+01+0.4795D+01*SB -0.4271D+01*SB2+0.4174D+00*SB3
41318 A4= 0.1737D+00+0.1717D+01*SB -0.1978D+01*SB2+0.6643D+00*SB3
41319 A5= 0.8689D+00+0.3500D+01*SB -0.3283D+01*SB2+0.1026D+01*SB3
41320 ELSEIF(IPRT .EQ. -5) THEN
41321 A0=SB** 0.9906D+00*Exp(-0.1496D+01-0.6576D+01*SB +
41322 & 0.1569D+01*SB2)
41323 A1=-0.2140D+00-0.6419D-01*SB -0.2741D-02*SB2+0.3185D-02*SB3
41324 A2= 0.5781D+01+0.1049D+00*SB -0.3930D+00*SB2+0.5174D+00*SB3
41325 A3=-0.9420D+00+0.5511D+00*SB +0.8817D+00*SB2+0.1903D+01*SB3
41326 A4= 0.2418D-01+0.4232D-01*SB -0.1244D-01*SB2-0.2365D-01*SB3
41327 A5= 0.7664D+00+0.1794D+01*SB -0.4917D+00*SB2-0.1284D+00*SB3
41328 ELSEIF(IPRT .EQ. -6) THEN
41329 A0=SB** 0.1000D+01*Exp(-0.8460D+01+0.1154D+01*SB +
41330 & 0.8838D+01*SB2)
41331 A1=-0.4316D-01-0.2976D+00*SB +0.3174D+00*SB2-0.1429D+01*SB3
41332 A2= 0.4910D+01+0.2273D+01*SB +0.5631D+01*SB2-0.1994D+02*SB3
41333 A3= 0.1190D+02-0.2000D+02*SB -0.2000D+02*SB2+0.1292D+02*SB3
41334 A4= 0.5771D+00-0.2552D+00*SB +0.7510D+00*SB2+0.6923D+00*SB3
41335 A5= 0.4402D+01-0.1627D+01*SB -0.2085D+01*SB2-0.6737D+01*SB3
41336 ENDIF
41337
41338C...Expansion for CTEQ3D.
41339 ELSEIF(ISET .EQ. 3) THEN
41340 IF(IPRT .EQ. 2) THEN
41341 A0=Exp( 0.2148D+00+0.5814D-01*SB +0.2734D+00*SB2-
41342 & 0.2902D+00*SB3)
41343 A1= 0.4810D+00+0.1657D-01*SB -0.3800D-01*SB2+0.3125D-01*SB3
41344 A2= 0.3509D+01+0.3923D+00*SB +0.4010D+00*SB2-0.1932D+00*SB3
41345 A3= 0.7055D+01-0.6552D+01*SB +0.3466D+01*SB2-0.5657D+00*SB3
41346 A4= 0.1061D+01-0.3453D+00*SB +0.4089D+00*SB2-0.1817D+00*SB3
41347 A5= 0.8687D-01+0.2548D+00*SB -0.2967D+00*SB2+0.2647D+00*SB3
41348 ELSEIF(IPRT .EQ. 1) THEN
41349 A0=Exp( 0.3961D+00+0.4914D+00*SB -0.1728D+01*SB2+
41350 & 0.7257D+00*SB3)
41351 A1= 0.4162D+00-0.1419D+00*SB +0.3680D+00*SB2-0.1618D+00*SB3
41352 A2= 0.3248D+01+0.3028D+01*SB -0.4307D+01*SB2+0.1920D+01*SB3
41353 A3=-0.1100D+01+0.2184D+01*SB -0.3820D+01*SB2+0.1717D+01*SB3
41354 A4= 0.2082D+01-0.2756D+00*SB +0.3043D+00*SB2-0.1260D+00*SB3
41355 A5=-0.4822D+00-0.5706D+00*SB +0.2243D+01*SB2-0.9760D+00*SB3
41356 ELSEIF(IPRT .EQ. 0) THEN
41357 A0=Exp(-0.4665D+00-0.7554D+00*SB -0.3323D+00*SB2-
41358 & 0.2734D-04*SB3)
41359 A1=-0.3359D+00+0.2395D+00*SB -0.2377D+00*SB2+0.7059D-01*SB3
41360 A2= 0.5451D+01+0.6086D+00*SB +0.8606D-01*SB2-0.1425D+00*SB3
41361 A3= 0.1026D+02-0.9352D+01*SB +0.4879D+01*SB2-0.1150D+01*SB3
41362 A4= 0.9935D+00-0.5017D-01*SB -0.1707D-01*SB2-0.1464D-02*SB3
41363 A5=-0.4160D-01+0.2305D+01*SB -0.1063D+01*SB2+0.3211D+00*SB3
41364 ELSEIF(IPRT .EQ. -1) THEN
41365 A0=Exp(-0.2714D+01-0.2868D+01*SB +0.3700D+01*SB2-
41366 & 0.1671D+01*SB3)
41367 A1=-0.3893D+00+0.3341D+00*SB -0.3897D+00*SB2+0.1420D+00*SB3
41368 A2= 0.8359D+01-0.3267D+01*SB +0.5327D+01*SB2-0.2245D+01*SB3
41369 A3= 0.2359D+02-0.5669D+01*SB -0.4602D+01*SB2+0.3153D+01*SB3
41370 A4= 0.1106D+01-0.4745D+00*SB +0.7739D+00*SB2-0.3417D+00*SB3
41371 A5=-0.5557D+00+0.3433D+01*SB -0.3390D+01*SB2+0.1354D+01*SB3
41372 ELSEIF(IPRT .EQ. -2) THEN
41373 A0=Exp(-0.3323D+01+0.2296D+00*SB -0.1109D+01*SB2+
41374 & 0.2223D+00*SB3)
41375 A1=-0.3410D+00+0.8847D-01*SB -0.1111D-01*SB2-0.5927D-02*SB3
41376 A2= 0.9753D+01-0.5182D+00*SB -0.4670D+00*SB2+0.1921D+00*SB3
41377 A3= 0.1977D+02-0.1600D+02*SB +0.9481D+01*SB2-0.1864D+01*SB3
41378 A4= 0.9818D+00+0.2839D-02*SB -0.1188D+00*SB2+0.3584D-01*SB3
41379 A5=-0.7934D-01+0.1004D+01*SB +0.3704D+00*SB2-0.1220D+00*SB3
41380 ELSEIF(IPRT .EQ. -3) THEN
41381 A0=Exp(-0.3985D+01+0.2855D+01*SB -0.5208D+01*SB2+
41382 & 0.1937D+01*SB3)
41383 A1=-0.3337D+00-0.1150D+00*SB +0.3691D+00*SB2-0.1709D+00*SB3
41384 A2= 0.7968D+01+0.3641D+01*SB -0.6599D+01*SB2+0.2642D+01*SB3
41385 A3= 0.1873D+02-0.1999D+02*SB +0.1734D+02*SB2-0.5813D+01*SB3
41386 A4= 0.9731D+00+0.5082D+00*SB -0.8780D+00*SB2+0.3231D+00*SB3
41387 A5=-0.5542D-01-0.4189D+00*SB +0.3309D+01*SB2-0.1439D+01*SB3
41388 ELSEIF(IPRT .EQ. -4) THEN
41389 A0=SB** 0.1105D+01*Exp(-0.3952D+01-0.1901D+01*SB +
41390 & 0.5137D+00*SB2)
41391 A1=-0.3543D+00+0.6055D+00*SB -0.6941D+00*SB2+0.2278D+00*SB3
41392 A2= 0.5955D+01-0.2629D+01*SB +0.5337D+01*SB2-0.2300D+01*SB3
41393 A3= 0.1933D+01+0.4882D+01*SB -0.3810D+01*SB2+0.2290D+00*SB3
41394 A4= 0.1806D+00+0.1655D+01*SB -0.1893D+01*SB2+0.6395D+00*SB3
41395 A5= 0.4790D+00+0.3612D+01*SB -0.3152D+01*SB2+0.9684D+00*SB3
41396 ELSEIF(IPRT .EQ. -5) THEN
41397 A0=SB** 0.9818D+00*Exp(-0.1825D+01-0.7464D+01*SB +
41398 & 0.2143D+01*SB2)
41399 A1=-0.2604D+00-0.1400D+00*SB +0.1702D+00*SB2-0.8476D-01*SB3
41400 A2= 0.6005D+01+0.6275D+00*SB -0.2535D+01*SB2+0.2219D+01*SB3
41401 A3=-0.9067D+00+0.1149D+01*SB +0.1974D+01*SB2+0.4716D+01*SB3
41402 A4= 0.3915D-01+0.5945D-01*SB -0.9844D-01*SB2+0.2783D-01*SB3
41403 A5= 0.5500D+00+0.1994D+01*SB -0.6727D+00*SB2-0.1510D+00*SB3
41404 ELSEIF(IPRT .EQ. -6) THEN
41405 A0=SB** 0.1002D+01*Exp(-0.8553D+01+0.3793D+00*SB +
41406 & 0.9998D+01*SB2)
41407 A1=-0.5870D-01-0.2792D+00*SB +0.6526D+00*SB2-0.1984D+01*SB3
41408 A2= 0.4716D+01+0.4473D+00*SB +0.1128D+02*SB2-0.1937D+02*SB3
41409 A3= 0.1289D+02-0.1742D+02*SB -0.1983D+02*SB2-0.9274D+00*SB3
41410 A4= 0.5647D+00-0.2732D+00*SB +0.1074D+01*SB2+0.5981D+00*SB3
41411 A5= 0.4390D+01-0.1262D+01*SB -0.9026D+00*SB2-0.9394D+01*SB3
41412 ENDIF
41413 ENDIF
41414
41415C...Calculation of x * f(x, Q).
41416 PYCTEQ = MAX(0D0, A0 *(X**A1) *((1D0-X)**A2) *(1D0+A3*(X**A4))
41417 & *(LOG(1D0+1D0/X))**A5 )
41418
41419 RETURN
41420 END
41421
41422C*********************************************************************
41423
41424C...PYGRVL
41425C...Gives the GRV 94 L (leading order) parton distribution function set
41426C...in parametrized form.
41427C...Authors: M. Glueck, E. Reya and A. Vogt.
41428
41429 SUBROUTINE PYGRVL (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41430
41431C...Double precision declaration.
41432 IMPLICIT DOUBLE PRECISION (A - Z)
41433
41434C...Common expressions.
41435 MU2 = 0.23D0
41436 LAM2 = 0.2322D0 * 0.2322D0
41437 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
41438 DS = SQRT (S)
41439 S2 = S * S
41440 S3 = S2 * S
41441
41442C...uv :
41443 NU = 2.284D0 + 0.802D0 * S + 0.055D0 * S2
41444 AKU = 0.590D0 - 0.024D0 * S
41445 BKU = 0.131D0 + 0.063D0 * S
41446 AU = -0.449D0 - 0.138D0 * S - 0.076D0 * S2
41447 BU = 0.213D0 + 2.669D0 * S - 0.728D0 * S2
41448 CU = 8.854D0 - 9.135D0 * S + 1.979D0 * S2
41449 DU = 2.997D0 + 0.753D0 * S - 0.076D0 * S2
41450 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
41451
41452C...dv :
41453 ND = 0.371D0 + 0.083D0 * S + 0.039D0 * S2
41454 AKD = 0.376D0
41455 BKD = 0.486D0 + 0.062D0 * S
41456 AD = -0.509D0 + 3.310D0 * S - 1.248D0 * S2
41457 BD = 12.41D0 - 10.52D0 * S + 2.267D0 * S2
41458 CD = 6.373D0 - 6.208D0 * S + 1.418D0 * S2
41459 DD = 3.691D0 + 0.799D0 * S - 0.071D0 * S2
41460 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
41461
41462C...del :
41463 NE = 0.082D0 + 0.014D0 * S + 0.008D0 * S2
41464 AKE = 0.409D0 - 0.005D0 * S
41465 BKE = 0.799D0 + 0.071D0 * S
41466 AE = -38.07D0 + 36.13D0 * S - 0.656D0 * S2
41467 BE = 90.31D0 - 74.15D0 * S + 7.645D0 * S2
41468 CE = 0.0D0
41469 DE = 7.486D0 + 1.217D0 * S - 0.159D0 * S2
41470 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
41471
41472C...udb :
41473 ALX = 1.451D0
41474 BEX = 0.271D0
41475 AKX = 0.410D0 - 0.232D0 * S
41476 BKX = 0.534D0 - 0.457D0 * S
41477 AGX = 0.890D0 - 0.140D0 * S
41478 BGX = -0.981D0
41479 CX = 0.320D0 + 0.683D0 * S
41480 DX = 4.752D0 + 1.164D0 * S + 0.286D0 * S2
41481 EX = 4.119D0 + 1.713D0 * S
41482 ESX = 0.682D0 + 2.978D0 * S
41483 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
41484 & DX, EX, ESX)
41485
41486C...sb :
41487 STS = 0D0
41488 ALS = 0.914D0
41489 BES = 0.577D0
41490 AKS = 1.798D0 - 0.596D0 * S
41491 AS = -5.548D0 + 3.669D0 * DS - 0.616D0 * S
41492 BS = 18.92D0 - 16.73D0 * DS + 5.168D0 * S
41493 DST = 6.379D0 - 0.350D0 * S + 0.142D0 * S2
41494 EST = 3.981D0 + 1.638D0 * S
41495 ESS = 6.402D0
41496 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
41497
41498C...cb :
41499 STC = 0.888D0
41500 ALC = 1.01D0
41501 BEC = 0.37D0
41502 AKC = 0D0
41503 AC = 0D0
41504 BC = 4.24D0 - 0.804D0 * S
41505 DCT = 3.46D0 - 1.076D0 * S
41506 ECT = 4.61D0 + 1.49D0 * S
41507 ESC = 2.555D0 + 1.961D0 * S
41508 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
41509
41510C...bb :
41511 STB = 1.351D0
41512 ALB = 1.00D0
41513 BEB = 0.51D0
41514 AKB = 0D0
41515 AB = 0D0
41516 BB = 1.848D0
41517 DBT = 2.929D0 + 1.396D0 * S
41518 EBT = 4.71D0 + 1.514D0 * S
41519 ESB = 4.02D0 + 1.239D0 * S
41520 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
41521
41522C...gl :
41523 ALG = 0.524D0
41524 BEG = 1.088D0
41525 AKG = 1.742D0 - 0.930D0 * S
41526 BKG = - 0.399D0 * S2
41527 AG = 7.486D0 - 2.185D0 * S
41528 BG = 16.69D0 - 22.74D0 * S + 5.779D0 * S2
41529 CG = -25.59D0 + 29.71D0 * S - 7.296D0 * S2
41530 DG = 2.792D0 + 2.215D0 * S + 0.422D0 * S2 - 0.104D0 * S3
41531 EG = 0.807D0 + 2.005D0 * S
41532 ESG = 3.841D0 + 0.316D0 * S
41533 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG,
41534 & DG, EG, ESG)
41535
41536 RETURN
41537 END
41538
41539C*********************************************************************
41540
41541C...PYGRVM
41542C...Gives the GRV 94 M (MSbar) parton distribution function set
41543C...in parametrized form.
41544C...Authors: M. Glueck, E. Reya and A. Vogt.
41545
41546 SUBROUTINE PYGRVM (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41547
41548C...Double precision declaration.
41549 IMPLICIT DOUBLE PRECISION (A - Z)
41550
41551C...Common expressions.
41552 MU2 = 0.34D0
41553 LAM2 = 0.248D0 * 0.248D0
41554 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
41555 DS = SQRT (S)
41556 S2 = S * S
41557 S3 = S2 * S
41558
41559C...uv :
41560 NU = 1.304D0 + 0.863D0 * S
41561 AKU = 0.558D0 - 0.020D0 * S
41562 BKU = 0.183D0 * S
41563 AU = -0.113D0 + 0.283D0 * S - 0.321D0 * S2
41564 BU = 6.843D0 - 5.089D0 * S + 2.647D0 * S2 - 0.527D0 * S3
41565 CU = 7.771D0 - 10.09D0 * S + 2.630D0 * S2
41566 DU = 3.315D0 + 1.145D0 * S - 0.583D0 * S2 + 0.154D0 * S3
41567 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
41568
41569C...dv :
41570 ND = 0.102D0 - 0.017D0 * S + 0.005D0 * S2
41571 AKD = 0.270D0 - 0.019D0 * S
41572 BKD = 0.260D0
41573 AD = 2.393D0 + 6.228D0 * S - 0.881D0 * S2
41574 BD = 46.06D0 + 4.673D0 * S - 14.98D0 * S2 + 1.331D0 * S3
41575 CD = 17.83D0 - 53.47D0 * S + 21.24D0 * S2
41576 DD = 4.081D0 + 0.976D0 * S - 0.485D0 * S2 + 0.152D0 * S3
41577 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
41578
41579C...del :
41580 NE = 0.070D0 + 0.042D0 * S - 0.011D0 * S2 + 0.004D0 * S3
41581 AKE = 0.409D0 - 0.007D0 * S
41582 BKE = 0.782D0 + 0.082D0 * S
41583 AE = -29.65D0 + 26.49D0 * S + 5.429D0 * S2
41584 BE = 90.20D0 - 74.97D0 * S + 4.526D0 * S2
41585 CE = 0.0D0
41586 DE = 8.122D0 + 2.120D0 * S - 1.088D0 * S2 + 0.231D0 * S3
41587 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
41588
41589C...udb :
41590 ALX = 0.877D0
41591 BEX = 0.561D0
41592 AKX = 0.275D0
41593 BKX = 0.0D0
41594 AGX = 0.997D0
41595 BGX = 3.210D0 - 1.866D0 * S
41596 CX = 7.300D0
41597 DX = 9.010D0 + 0.896D0 * DS + 0.222D0 * S2
41598 EX = 3.077D0 + 1.446D0 * S
41599 ESX = 3.173D0 - 2.445D0 * DS + 2.207D0 * S
41600 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
41601 & DX, EX, ESX)
41602
41603C...sb :
41604 STS = 0D0
41605 ALS = 0.756D0
41606 BES = 0.216D0
41607 AKS = 1.690D0 + 0.650D0 * DS - 0.922D0 * S
41608 AS = -4.329D0 + 1.131D0 * S
41609 BS = 9.568D0 - 1.744D0 * S
41610 DST = 9.377D0 + 1.088D0 * DS - 1.320D0 * S + 0.130D0 * S2
41611 EST = 3.031D0 + 1.639D0 * S
41612 ESS = 5.837D0 + 0.815D0 * S
41613 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
41614
41615C...cb :
41616 STC = 0.820D0
41617 ALC = 0.98D0
41618 BEC = 0D0
41619 AKC = -0.625D0 - 0.523D0 * S
41620 AC = 0D0
41621 BC = 1.896D0 + 1.616D0 * S
41622 DCT = 4.12D0 + 0.683D0 * S
41623 ECT = 4.36D0 + 1.328D0 * S
41624 ESC = 0.677D0 + 0.679D0 * S
41625 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
41626
41627C...bb :
41628 STB = 1.297D0
41629 ALB = 0.99D0
41630 BEB = 0D0
41631 AKB = - 0.193D0 * S
41632 AB = 0D0
41633 BB = 0D0
41634 DBT = 3.447D0 + 0.927D0 * S
41635 EBT = 4.68D0 + 1.259D0 * S
41636 ESB = 1.892D0 + 2.199D0 * S
41637 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
41638
41639C...gl :
41640 ALG = 1.014D0
41641 BEG = 1.738D0
41642 AKG = 1.724D0 + 0.157D0 * S
41643 BKG = 0.800D0 + 1.016D0 * S
41644 AG = 7.517D0 - 2.547D0 * S
41645 BG = 34.09D0 - 52.21D0 * DS + 17.47D0 * S
41646 CG = 4.039D0 + 1.491D0 * S
41647 DG = 3.404D0 + 0.830D0 * S
41648 EG = -1.112D0 + 3.438D0 * S - 0.302D0 * S2
41649 ESG = 3.256D0 - 0.436D0 * S
41650 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
41651
41652 RETURN
41653 END
41654
41655C*********************************************************************
41656
41657C...PYGRVD
41658C...Gives the GRV 94 D (DIS) parton distribution function set
41659C...in parametrized form.
41660C...Authors: M. Glueck, E. Reya and A. Vogt.
41661
41662 SUBROUTINE PYGRVD (X, Q2, UV, DV, DEL, UDB, SB, CHM, BOT, GL)
41663
41664C...Double precision declaration.
41665 IMPLICIT DOUBLE PRECISION (A - Z)
41666
41667C...Common expressions.
41668 MU2 = 0.34D0
41669 LAM2 = 0.248D0 * 0.248D0
41670 S = LOG (LOG(Q2/LAM2) / LOG(MU2/LAM2))
41671 DS = SQRT (S)
41672 S2 = S * S
41673 S3 = S2 * S
41674
41675C...uv :
41676 NU = 2.484D0 + 0.116D0 * S + 0.093D0 * S2
41677 AKU = 0.563D0 - 0.025D0 * S
41678 BKU = 0.054D0 + 0.154D0 * S
41679 AU = -0.326D0 - 0.058D0 * S - 0.135D0 * S2
41680 BU = -3.322D0 + 8.259D0 * S - 3.119D0 * S2 + 0.291D0 * S3
41681 CU = 11.52D0 - 12.99D0 * S + 3.161D0 * S2
41682 DU = 2.808D0 + 1.400D0 * S - 0.557D0 * S2 + 0.119D0 * S3
41683 UV = PYGRVV (X, NU, AKU, BKU, AU, BU, CU, DU)
41684
41685C...dv :
41686 ND = 0.156D0 - 0.017D0 * S
41687 AKD = 0.299D0 - 0.022D0 * S
41688 BKD = 0.259D0 - 0.015D0 * S
41689 AD = 3.445D0 + 1.278D0 * S + 0.326D0 * S2
41690 BD = -6.934D0 + 37.45D0 * S - 18.95D0 * S2 + 1.463D0 * S3
41691 CD = 55.45D0 - 69.92D0 * S + 20.78D0 * S2
41692 DD = 3.577D0 + 1.441D0 * S - 0.683D0 * S2 + 0.179D0 * S3
41693 DV = PYGRVV (X, ND, AKD, BKD, AD, BD, CD, DD)
41694
41695C...del :
41696 NE = 0.099D0 + 0.019D0 * S + 0.002D0 * S2
41697 AKE = 0.419D0 - 0.013D0 * S
41698 BKE = 1.064D0 - 0.038D0 * S
41699 AE = -44.00D0 + 98.70D0 * S - 14.79D0 * S2
41700 BE = 28.59D0 - 40.94D0 * S - 13.66D0 * S2 + 2.523D0 * S3
41701 CE = 84.57D0 - 108.8D0 * S + 31.52D0 * S2
41702 DE = 7.469D0 + 2.480D0 * S - 0.866D0 * S2
41703 DEL = PYGRVV (X, NE, AKE, BKE, AE, BE, CE, DE)
41704
41705C...udb :
41706 ALX = 1.215D0
41707 BEX = 0.466D0
41708 AKX = 0.326D0 + 0.150D0 * S
41709 BKX = 0.956D0 + 0.405D0 * S
41710 AGX = 0.272D0
41711 BGX = 3.794D0 - 2.359D0 * DS
41712 CX = 2.014D0
41713 DX = 7.941D0 + 0.534D0 * DS - 0.940D0 * S + 0.410D0 * S2
41714 EX = 3.049D0 + 1.597D0 * S
41715 ESX = 4.396D0 - 4.594D0 * DS + 3.268D0 * S
41716 UDB = PYGRVW (X, S, ALX, BEX, AKX, BKX, AGX, BGX, CX,
41717 & DX, EX, ESX)
41718
41719C...sb :
41720 STS = 0D0
41721 ALS = 0.175D0
41722 BES = 0.344D0
41723 AKS = 1.415D0 - 0.641D0 * DS
41724 AS = 0.580D0 - 9.763D0 * DS + 6.795D0 * S - 0.558D0 * S2
41725 BS = 5.617D0 + 5.709D0 * DS - 3.972D0 * S
41726 DST = 13.78D0 - 9.581D0 * S + 5.370D0 * S2 - 0.996D0 * S3
41727 EST = 4.546D0 + 0.372D0 * S2
41728 ESS = 5.053D0 - 1.070D0 * S + 0.805D0 * S2
41729 SB = PYGRVS (X, S, STS, ALS, BES, AKS, AS, BS, DST, EST, ESS)
41730
41731C...cb :
41732 STC = 0.820D0
41733 ALC = 0.98D0
41734 BEC = 0D0
41735 AKC = -0.625D0 - 0.523D0 * S
41736 AC = 0D0
41737 BC = 1.896D0 + 1.616D0 * S
41738 DCT = 4.12D0 + 0.683D0 * S
41739 ECT = 4.36D0 + 1.328D0 * S
41740 ESC = 0.677D0 + 0.679D0 * S
41741 CHM = PYGRVS (X, S, STC, ALC, BEC, AKC, AC, BC, DCT, ECT, ESC)
41742
41743C...bb :
41744 STB = 1.297D0
41745 ALB = 0.99D0
41746 BEB = 0D0
41747 AKB = - 0.193D0 * S
41748 AB = 0D0
41749 BB = 0D0
41750 DBT = 3.447D0 + 0.927D0 * S
41751 EBT = 4.68D0 + 1.259D0 * S
41752 ESB = 1.892D0 + 2.199D0 * S
41753 BOT = PYGRVS (X, S, STB, ALB, BEB, AKB, AB, BB, DBT, EBT, ESB)
41754
41755C...gl :
41756 ALG = 1.258D0
41757 BEG = 1.846D0
41758 AKG = 2.423D0
41759 BKG = 2.427D0 + 1.311D0 * S - 0.153D0 * S2
41760 AG = 25.09D0 - 7.935D0 * S
41761 BG = -14.84D0 - 124.3D0 * DS + 72.18D0 * S
41762 CG = 590.3D0 - 173.8D0 * S
41763 DG = 5.196D0 + 1.857D0 * S
41764 EG = -1.648D0 + 3.988D0 * S - 0.432D0 * S2
41765 ESG = 3.232D0 - 0.542D0 * S
41766 GL = PYGRVW (X, S, ALG, BEG, AKG, BKG, AG, BG, CG, DG, EG, ESG)
41767
41768 RETURN
41769 END
41770
41771C*********************************************************************
41772
41773C...PYGRVV
41774C...Auxiliary for the GRV 94 parton distribution functions
41775C...for u and d valence and d-u sea.
41776C...Authors: M. Glueck, E. Reya and A. Vogt.
41777
41778 FUNCTION PYGRVV (X, N, AK, BK, A, B, C, D)
41779
41780C...Double precision declaration.
41781 IMPLICIT DOUBLE PRECISION (A - Z)
41782
41783C...Evaluation.
41784 DX = SQRT (X)
41785 PYGRVV = N * X**AK * (1D0+ A*X**BK + X * (B + C*DX)) *
41786 & (1D0- X)**D
41787
41788 RETURN
41789 END
41790
41791C*********************************************************************
41792
41793C...PYGRVW
41794C...Auxiliary for the GRV 94 parton distribution functions
41795C...for d+u sea and gluon.
41796C...Authors: M. Glueck, E. Reya and A. Vogt.
41797
41798 FUNCTION PYGRVW (X, S, AL, BE, AK, BK, A, B, C, D, E, ES)
41799
41800C...Double precision declaration.
41801 IMPLICIT DOUBLE PRECISION (A - Z)
41802
41803C...Evaluation.
41804 LX = LOG (1D0/X)
41805 PYGRVW = (X**AK * (A + X * (B + X*C)) * LX**BK + S**AL
41806 & * EXP (-E + SQRT (ES * S**BE * LX))) * (1D0- X)**D
41807
41808 RETURN
41809 END
41810
41811C*********************************************************************
41812
41813C...PYGRVS
41814C...Auxiliary for the GRV 94 parton distribution functions
41815C...for s, c and b sea.
41816C...Authors: M. Glueck, E. Reya and A. Vogt.
41817
41818 FUNCTION PYGRVS (X, S, STH, AL, BE, AK, AG, B, D, E, ES)
41819
41820C...Double precision declaration.
41821 IMPLICIT DOUBLE PRECISION (A - Z)
41822
41823C...Evaluation.
41824 IF(S.LE.STH) THEN
41825 PYGRVS = 0D0
41826 ELSE
41827 DX = SQRT (X)
41828 LX = LOG (1D0/X)
41829 PYGRVS = (S - STH)**AL / LX**AK * (1D0+ AG*DX + B*X) *
41830 & (1D0- X)**D * EXP (-E + SQRT (ES * S**BE * LX))
41831 ENDIF
41832
41833 RETURN
41834 END
41835
41836C*********************************************************************
41837
41838C...PYCT5L
41839C...Auxiliary function for parametrization of CTEQ5L.
41840C...Author: J. Pumplin 9/99.
41841
41842C...CTEQ5M1 and CTEQ5L Parton Distribution Functions
41843C...in Parametrized Form
41844C... September 15, 1999
41845C
41846C...Ref: "GLOBAL QCD ANALYSIS OF PARTON STRUCTURE OF THE NUCLEON:
41847C... CTEQ5 PPARTON DISTRIBUTIONS"
41848C...hep-ph/9903282
41849
41850C...The CTEQ5M1 set given here is an updated version of the original
41851C...CTEQ5M set posted, in the table version, on the Web page of CTEQ.
41852C...The differences between CTEQ5M and CTEQ5M1 are insignificant for
41853C...almost all applications.
41854C...The improvement is in the QCD evolution which is now more
41855C...accurate, and which agrees completely with the benchmark work
41856C...of the HERA 96/97 Workshop.
41857C...The differences between the parametrized and the corresponding
41858C...table versions (on which it is based) are of similar order as
41859C...between the two version.
41860
41861C...!! Because accurate parametrizations over a wide range of (x,Q)
41862C...is hard to obtain, only the most widely used sets CTEQ5M and
41863C...CTEQ5L are available in parametrized form for now.
41864
41865C...These parametrizations were obtained by Jon Pumplin.
41866
41867C Iset PDF Description Alpha_s(Mz) Lam4 Lam5
41868C -------------------------------------------------------------------
41869C 1 CTEQ5M1 Standard NLO MSbar scheme 0.118 326 226
41870C 3 CTEQ5L Leading Order 0.127 192 146
41871C -------------------------------------------------------------------
41872C...Note the Qcd-lambda values given for CTEQ5L is for the leading
41873C...order form of Alpha_s!! Alpha_s(Mz) gives the absolute
41874C...calibration.
41875
41876C...The two Iset value are adopted to agree with the standard table
41877C...versions.
41878
41879C...Range of validity:
41880C...The range of (x, Q) covered by this parametrization of the QCD
41881C...evolved parton distributions is 1E-6 < x < 1 ;
41882C...1.1 GeV < Q < 10 TeV. Of course, the PDFs are constrained by
41883C...data only in a subset of that region; and the assumed DGLAP
41884C...evolution is unlikely to be valid for all of it either.
41885
41886C...The range of (x, Q) used in the CTEQ5 round of global analysis is
41887C...approximately 0.01 < x < 0.75 ; and 4 GeV^2 < Q^2 < 400 GeV^2 for
41888C...fixed target experiments; 0.0001 < x < 0.3 from HERA data; and
41889C...Q^2 up to 40,000 GeV^2 from Tevatron inclusive Jet data.
41890
41891 FUNCTION PYCT5L(IFL,X,Q)
41892
41893C...Double precision declaration.
41894 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
41895 IMPLICIT INTEGER(I-N)
41896
41897 PARAMETER (NEX=8, NLF=2)
41898 DIMENSION AM(0:NEX,0:NLF,-5:2)
41899 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
41900 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
41901 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
41902 DIMENSION AF(0:NEX)
41903
41904 DATA MEXVEC( 2) / 8 /
41905 DATA MLFVEC( 2) / 2 /
41906 DATA UT1VEC( 2) / 0.4971265E+01 /
41907 DATA UT2VEC( 2) / -0.1105128E+01 /
41908 DATA ALFVEC( 2) / 0.2987216E+00 /
41909 DATA QMAVEC( 2) / 0.0000000E+00 /
41910 DATA (AM( 0,K, 2),K=0, 2)
41911 & / 0.5292616E+01, -0.2751910E+01, -0.2488990E+01 /
41912 DATA (AM( 1,K, 2),K=0, 2)
41913 & / 0.9714424E+00, 0.1011827E-01, -0.1023660E-01 /
41914 DATA (AM( 2,K, 2),K=0, 2)
41915 & / -0.1651006E+02, 0.7959721E+01, 0.8810563E+01 /
41916 DATA (AM( 3,K, 2),K=0, 2)
41917 & / -0.1643394E+02, 0.5892854E+01, 0.9348874E+01 /
41918 DATA (AM( 4,K, 2),K=0, 2)
41919 & / 0.3067422E+02, 0.4235796E+01, -0.5112136E+00 /
41920 DATA (AM( 5,K, 2),K=0, 2)
41921 & / 0.2352526E+02, -0.5305168E+01, -0.1169174E+02 /
41922 DATA (AM( 6,K, 2),K=0, 2)
41923 & / -0.1095451E+02, 0.3006577E+01, 0.5638136E+01 /
41924 DATA (AM( 7,K, 2),K=0, 2)
41925 & / -0.1172251E+02, -0.2183624E+01, 0.4955794E+01 /
41926 DATA (AM( 8,K, 2),K=0, 2)
41927 & / 0.1662533E-01, 0.7622870E-02, -0.4895887E-03 /
41928
41929 DATA MEXVEC( 1) / 8 /
41930 DATA MLFVEC( 1) / 2 /
41931 DATA UT1VEC( 1) / 0.2612618E+01 /
41932 DATA UT2VEC( 1) / -0.1258304E+06 /
41933 DATA ALFVEC( 1) / 0.3407552E+00 /
41934 DATA QMAVEC( 1) / 0.0000000E+00 /
41935 DATA (AM( 0,K, 1),K=0, 2)
41936 & / 0.9905300E+00, -0.4502235E+00, 0.1624441E+00 /
41937 DATA (AM( 1,K, 1),K=0, 2)
41938 & / 0.8867534E+00, 0.1630829E-01, -0.4049085E-01 /
41939 DATA (AM( 2,K, 1),K=0, 2)
41940 & / 0.8547974E+00, 0.3336301E+00, 0.1371388E+00 /
41941 DATA (AM( 3,K, 1),K=0, 2)
41942 & / 0.2941113E+00, -0.1527905E+01, 0.2331879E+00 /
41943 DATA (AM( 4,K, 1),K=0, 2)
41944 & / 0.3384235E+02, 0.3715315E+01, 0.8276930E+00 /
41945 DATA (AM( 5,K, 1),K=0, 2)
41946 & / 0.6230115E+01, 0.3134639E+01, -0.1729099E+01 /
41947 DATA (AM( 6,K, 1),K=0, 2)
41948 & / -0.1186928E+01, -0.3282460E+00, 0.1052020E+00 /
41949 DATA (AM( 7,K, 1),K=0, 2)
41950 & / -0.8545702E+01, -0.6247947E+01, 0.3692561E+01 /
41951 DATA (AM( 8,K, 1),K=0, 2)
41952 & / 0.1724598E-01, 0.7120465E-02, 0.4003646E-04 /
41953
41954 DATA MEXVEC( 0) / 8 /
41955 DATA MLFVEC( 0) / 2 /
41956 DATA UT1VEC( 0) / -0.4656819E+00 /
41957 DATA UT2VEC( 0) / -0.2742390E+03 /
41958 DATA ALFVEC( 0) / 0.4491863E+00 /
41959 DATA QMAVEC( 0) / 0.0000000E+00 /
41960 DATA (AM( 0,K, 0),K=0, 2)
41961 & / 0.1193572E+03, -0.3886845E+01, -0.1133965E+01 /
41962 DATA (AM( 1,K, 0),K=0, 2)
41963 & / -0.9421449E+02, 0.3995885E+01, 0.1607363E+01 /
41964 DATA (AM( 2,K, 0),K=0, 2)
41965 & / 0.4206383E+01, 0.2485954E+00, 0.2497468E+00 /
41966 DATA (AM( 3,K, 0),K=0, 2)
41967 & / 0.1210557E+03, -0.3015765E+01, -0.1423651E+01 /
41968 DATA (AM( 4,K, 0),K=0, 2)
41969 & / -0.1013897E+03, -0.7113478E+00, 0.2621865E+00 /
41970 DATA (AM( 5,K, 0),K=0, 2)
41971 & / -0.1312404E+01, -0.9297691E+00, -0.1562531E+00 /
41972 DATA (AM( 6,K, 0),K=0, 2)
41973 & / 0.1627137E+01, 0.4954111E+00, -0.6387009E+00 /
41974 DATA (AM( 7,K, 0),K=0, 2)
41975 & / 0.1537698E+00, -0.2487878E+00, 0.8305947E+00 /
41976 DATA (AM( 8,K, 0),K=0, 2)
41977 & / 0.2496448E-01, 0.2457823E-02, 0.8234276E-03 /
41978
41979 DATA MEXVEC(-1) / 8 /
41980 DATA MLFVEC(-1) / 2 /
41981 DATA UT1VEC(-1) / 0.3862583E+01 /
41982 DATA UT2VEC(-1) / -0.1265969E+01 /
41983 DATA ALFVEC(-1) / 0.2457668E+00 /
41984 DATA QMAVEC(-1) / 0.0000000E+00 /
41985 DATA (AM( 0,K,-1),K=0, 2)
41986 & / 0.2647441E+02, 0.1059277E+02, -0.9176654E+00 /
41987 DATA (AM( 1,K,-1),K=0, 2)
41988 & / 0.1990636E+01, 0.8558918E-01, 0.4248667E-01 /
41989 DATA (AM( 2,K,-1),K=0, 2)
41990 & / -0.1476095E+02, -0.3276255E+02, 0.1558110E+01 /
41991 DATA (AM( 3,K,-1),K=0, 2)
41992 & / -0.2966889E+01, -0.3649037E+02, 0.1195914E+01 /
41993 DATA (AM( 4,K,-1),K=0, 2)
41994 & / -0.1000519E+03, -0.2464635E+01, 0.1964849E+00 /
41995 DATA (AM( 5,K,-1),K=0, 2)
41996 & / 0.3718331E+02, 0.4700389E+02, -0.2772142E+01 /
41997 DATA (AM( 6,K,-1),K=0, 2)
41998 & / -0.1872722E+02, -0.2291189E+02, 0.1089052E+01 /
41999 DATA (AM( 7,K,-1),K=0, 2)
42000 & / -0.1628146E+02, -0.1823993E+02, 0.2537369E+01 /
42001 DATA (AM( 8,K,-1),K=0, 2)
42002 & / -0.1156300E+01, -0.1280495E+00, 0.5153245E-01 /
42003
42004 DATA MEXVEC(-2) / 7 /
42005 DATA MLFVEC(-2) / 2 /
42006 DATA UT1VEC(-2) / 0.1895615E+00 /
42007 DATA UT2VEC(-2) / -0.3069097E+01 /
42008 DATA ALFVEC(-2) / 0.5293999E+00 /
42009 DATA QMAVEC(-2) / 0.0000000E+00 /
42010 DATA (AM( 0,K,-2),K=0, 2)
42011 & / -0.6556775E+00, 0.2490190E+00, 0.3966485E-01 /
42012 DATA (AM( 1,K,-2),K=0, 2)
42013 & / 0.1305102E+01, -0.1188925E+00, -0.4600870E-02 /
42014 DATA (AM( 2,K,-2),K=0, 2)
42015 & / -0.2371436E+01, 0.3566814E+00, -0.2834683E+00 /
42016 DATA (AM( 3,K,-2),K=0, 2)
42017 & / -0.6152826E+01, 0.8339877E+00, -0.7233230E+00 /
42018 DATA (AM( 4,K,-2),K=0, 2)
42019 & / -0.8346558E+01, 0.2892168E+01, 0.2137099E+00 /
42020 DATA (AM( 5,K,-2),K=0, 2)
42021 & / 0.1279530E+02, 0.1021114E+00, 0.5787439E+00 /
42022 DATA (AM( 6,K,-2),K=0, 2)
42023 & / 0.5858816E+00, -0.1940375E+01, -0.4029269E+00 /
42024 DATA (AM( 7,K,-2),K=0, 2)
42025 & / -0.2795725E+02, -0.5263392E+00, 0.1290229E+01 /
42026
42027 DATA MEXVEC(-3) / 7 /
42028 DATA MLFVEC(-3) / 2 /
42029 DATA UT1VEC(-3) / 0.3753257E+01 /
42030 DATA UT2VEC(-3) / -0.1113085E+01 /
42031 DATA ALFVEC(-3) / 0.3713141E+00 /
42032 DATA QMAVEC(-3) / 0.0000000E+00 /
42033 DATA (AM( 0,K,-3),K=0, 2)
42034 & / 0.1580931E+01, -0.2273826E+01, -0.1822245E+01 /
42035 DATA (AM( 1,K,-3),K=0, 2)
42036 & / 0.2702644E+01, 0.6763243E+00, 0.7231586E-02 /
42037 DATA (AM( 2,K,-3),K=0, 2)
42038 & / -0.1857924E+02, 0.3907500E+01, 0.5850109E+01 /
42039 DATA (AM( 3,K,-3),K=0, 2)
42040 & / -0.3044793E+02, 0.2639332E+01, 0.5566644E+01 /
42041 DATA (AM( 4,K,-3),K=0, 2)
42042 & / -0.4258011E+01, -0.5429244E+01, 0.4418946E+00 /
42043 DATA (AM( 5,K,-3),K=0, 2)
42044 & / 0.3465259E+02, -0.5532604E+01, -0.4904153E+01 /
42045 DATA (AM( 6,K,-3),K=0, 2)
42046 & / -0.1658858E+02, 0.2923275E+01, 0.2266286E+01 /
42047 DATA (AM( 7,K,-3),K=0, 2)
42048 & / -0.1149263E+02, 0.2877475E+01, -0.7999105E+00 /
42049
42050 DATA MEXVEC(-4) / 7 /
42051 DATA MLFVEC(-4) / 2 /
42052 DATA UT1VEC(-4) / 0.4400772E+01 /
42053 DATA UT2VEC(-4) / -0.1356116E+01 /
42054 DATA ALFVEC(-4) / 0.3712017E-01 /
42055 DATA QMAVEC(-4) / 0.1300000E+01 /
42056 DATA (AM( 0,K,-4),K=0, 2)
42057 & / -0.8293661E+00, -0.3982375E+01, -0.6494283E-01 /
42058 DATA (AM( 1,K,-4),K=0, 2)
42059 & / 0.2754618E+01, 0.8338636E+00, -0.6885160E-01 /
42060 DATA (AM( 2,K,-4),K=0, 2)
42061 & / -0.1657987E+02, 0.1439143E+02, -0.6887240E+00 /
42062 DATA (AM( 3,K,-4),K=0, 2)
42063 & / -0.2800703E+02, 0.1535966E+02, -0.7377693E+00 /
42064 DATA (AM( 4,K,-4),K=0, 2)
42065 & / -0.6460216E+01, -0.4783019E+01, 0.4913297E+00 /
42066 DATA (AM( 5,K,-4),K=0, 2)
42067 & / 0.3141830E+02, -0.3178031E+02, 0.7136013E+01 /
42068 DATA (AM( 6,K,-4),K=0, 2)
42069 & / -0.1802509E+02, 0.1862163E+02, -0.4632843E+01 /
42070 DATA (AM( 7,K,-4),K=0, 2)
42071 & / -0.1240412E+02, 0.2565386E+02, -0.1066570E+02 /
42072
42073 DATA MEXVEC(-5) / 6 /
42074 DATA MLFVEC(-5) / 2 /
42075 DATA UT1VEC(-5) / 0.5562568E+01 /
42076 DATA UT2VEC(-5) / -0.1801317E+01 /
42077 DATA ALFVEC(-5) / 0.4952010E-02 /
42078 DATA QMAVEC(-5) / 0.4500000E+01 /
42079 DATA (AM( 0,K,-5),K=0, 2)
42080 & / -0.6031237E+01, 0.1992727E+01, -0.1076331E+01 /
42081 DATA (AM( 1,K,-5),K=0, 2)
42082 & / 0.2933912E+01, 0.5839674E+00, 0.7509435E-01 /
42083 DATA (AM( 2,K,-5),K=0, 2)
42084 & / -0.8284919E+01, 0.1488593E+01, -0.8251678E+00 /
42085 DATA (AM( 3,K,-5),K=0, 2)
42086 & / -0.1925986E+02, 0.2805753E+01, -0.3015446E+01 /
42087 DATA (AM( 4,K,-5),K=0, 2)
42088 & / -0.9480483E+01, -0.9767837E+00, -0.1165544E+01 /
42089 DATA (AM( 5,K,-5),K=0, 2)
42090 & / 0.2193195E+02, -0.1788518E+02, 0.9460908E+01 /
42091 DATA (AM( 6,K,-5),K=0, 2)
42092 & / -0.1327377E+02, 0.1201754E+02, -0.6277844E+01 /
42093
42094 IF(Q .LE. QMAVEC(IFL)) THEN
42095 PYCT5L = 0.D0
42096 RETURN
42097 ENDIF
42098
42099 IF(X .GE. 1.D0) THEN
42100 PYCT5L = 0.D0
42101 RETURN
42102 ENDIF
42103
42104 TMP = LOG(Q/ALFVEC(IFL))
42105 IF(TMP .LE. 0.D0) THEN
42106 PYCT5L = 0.D0
42107 RETURN
42108 ENDIF
42109
42110 SB = LOG(TMP)
42111 SB1 = SB - 1.2D0
42112 SB2 = SB1*SB1
42113
42114 DO 110 I = 0, NEX
42115 AF(I) = 0.D0
42116 SBX = 1.D0
42117 DO 100 K = 0, MLFVEC(IFL)
42118 AF(I) = AF(I) + SBX*AM(I,K,IFL)
42119 SBX = SB1*SBX
42120 100 CONTINUE
42121 110 CONTINUE
42122
42123 Y = -LOG(X)
42124 U = LOG(X/0.00001D0)
42125
42126 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
42127 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
42128 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
42129 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
42130 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
42131
42132 PYCT5L = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
42133
42134C...Include threshold factor.
42135 PYCT5L = PYCT5L * (1.D0 - QMAVEC(IFL)/Q)
42136
42137 RETURN
42138 END
42139
42140C*********************************************************************
42141
42142C...PYCT5M
42143C...Auxiliary function for parametrization of CTEQ5M1.
42144C...Author: J. Pumplin 9/99.
42145
42146 FUNCTION PYCT5M(IFL,X,Q)
42147
42148C...Double precision declaration.
42149 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42150 IMPLICIT INTEGER(I-N)
42151
42152 PARAMETER (NEX=8, NLF=2)
42153 DIMENSION AM(0:NEX,0:NLF,-5:2)
42154 DIMENSION ALFVEC(-5:2), QMAVEC(-5:2)
42155 DIMENSION MEXVEC(-5:2), MLFVEC(-5:2)
42156 DIMENSION UT1VEC(-5:2), UT2VEC(-5:2)
42157 DIMENSION AF(0:NEX)
42158
42159 DATA MEXVEC( 2) / 8 /
42160 DATA MLFVEC( 2) / 2 /
42161 DATA UT1VEC( 2) / 0.5141718E+01 /
42162 DATA UT2VEC( 2) / -0.1346944E+01 /
42163 DATA ALFVEC( 2) / 0.5260555E+00 /
42164 DATA QMAVEC( 2) / 0.0000000E+00 /
42165 DATA (AM( 0,K, 2),K=0, 2)
42166 & / 0.4289071E+01, -0.2536870E+01, -0.1259948E+01 /
42167 DATA (AM( 1,K, 2),K=0, 2)
42168 & / 0.9839410E+00, 0.4168426E-01, -0.5018952E-01 /
42169 DATA (AM( 2,K, 2),K=0, 2)
42170 & / -0.1651961E+02, 0.9246261E+01, 0.5996400E+01 /
42171 DATA (AM( 3,K, 2),K=0, 2)
42172 & / -0.2077936E+02, 0.9786469E+01, 0.7656465E+01 /
42173 DATA (AM( 4,K, 2),K=0, 2)
42174 & / 0.3054926E+02, 0.1889536E+01, 0.1380541E+01 /
42175 DATA (AM( 5,K, 2),K=0, 2)
42176 & / 0.3084695E+02, -0.1212303E+02, -0.1053551E+02 /
42177 DATA (AM( 6,K, 2),K=0, 2)
42178 & / -0.1426778E+02, 0.6239537E+01, 0.5254819E+01 /
42179 DATA (AM( 7,K, 2),K=0, 2)
42180 & / -0.1909811E+02, 0.3695678E+01, 0.5495729E+01 /
42181 DATA (AM( 8,K, 2),K=0, 2)
42182 & / 0.1889751E-01, 0.5027193E-02, 0.6624896E-03 /
42183
42184 DATA MEXVEC( 1) / 8 /
42185 DATA MLFVEC( 1) / 2 /
42186 DATA UT1VEC( 1) / 0.4138426E+01 /
42187 DATA UT2VEC( 1) / -0.3221374E+01 /
42188 DATA ALFVEC( 1) / 0.4960962E+00 /
42189 DATA QMAVEC( 1) / 0.0000000E+00 /
42190 DATA (AM( 0,K, 1),K=0, 2)
42191 & / 0.1332497E+01, -0.3703718E+00, 0.1288638E+00 /
42192 DATA (AM( 1,K, 1),K=0, 2)
42193 & / 0.7544687E+00, 0.3255075E-01, -0.4706680E-01 /
42194 DATA (AM( 2,K, 1),K=0, 2)
42195 & / -0.7638814E+00, 0.5008313E+00, -0.9237374E-01 /
42196 DATA (AM( 3,K, 1),K=0, 2)
42197 & / -0.3689889E+00, -0.1055098E+01, -0.4645065E+00 /
42198 DATA (AM( 4,K, 1),K=0, 2)
42199 & / 0.3991610E+02, 0.1979881E+01, 0.1775814E+01 /
42200 DATA (AM( 5,K, 1),K=0, 2)
42201 & / 0.6201080E+01, 0.2046288E+01, 0.3804571E+00 /
42202 DATA (AM( 6,K, 1),K=0, 2)
42203 & / -0.8027900E+00, -0.7011688E+00, -0.8049612E+00 /
42204 DATA (AM( 7,K, 1),K=0, 2)
42205 & / -0.8631305E+01, -0.3981200E+01, 0.6970153E+00 /
42206 DATA (AM( 8,K, 1),K=0, 2)
42207 & / 0.2371230E-01, 0.5372683E-02, 0.1118701E-02 /
42208
42209 DATA MEXVEC( 0) / 8 /
42210 DATA MLFVEC( 0) / 2 /
42211 DATA UT1VEC( 0) / -0.1026789E+01 /
42212 DATA UT2VEC( 0) / -0.9051707E+01 /
42213 DATA ALFVEC( 0) / 0.9462977E+00 /
42214 DATA QMAVEC( 0) / 0.0000000E+00 /
42215 DATA (AM( 0,K, 0),K=0, 2)
42216 & / 0.1191990E+03, -0.8548739E+00, -0.1963040E+01 /
42217 DATA (AM( 1,K, 0),K=0, 2)
42218 & / -0.9449972E+02, 0.1074771E+01, 0.2056055E+01 /
42219 DATA (AM( 2,K, 0),K=0, 2)
42220 & / 0.3701064E+01, -0.1167947E-02, 0.1933573E+00 /
42221 DATA (AM( 3,K, 0),K=0, 2)
42222 & / 0.1171345E+03, -0.1064540E+01, -0.1875312E+01 /
42223 DATA (AM( 4,K, 0),K=0, 2)
42224 & / -0.1014453E+03, -0.5707427E+00, 0.4511242E-01 /
42225 DATA (AM( 5,K, 0),K=0, 2)
42226 & / 0.6365168E+01, 0.1275354E+01, -0.4964081E+00 /
42227 DATA (AM( 6,K, 0),K=0, 2)
42228 & / -0.3370693E+01, -0.1122020E+01, 0.5947751E-01 /
42229 DATA (AM( 7,K, 0),K=0, 2)
42230 & / -0.5327270E+01, -0.9293556E+00, 0.6629940E+00 /
42231 DATA (AM( 8,K, 0),K=0, 2)
42232 & / 0.2437513E-01, 0.1600939E-02, 0.6855336E-03 /
42233
42234 DATA MEXVEC(-1) / 8 /
42235 DATA MLFVEC(-1) / 2 /
42236 DATA UT1VEC(-1) / 0.5243571E+01 /
42237 DATA UT2VEC(-1) / -0.2870513E+01 /
42238 DATA ALFVEC(-1) / 0.6701448E+00 /
42239 DATA QMAVEC(-1) / 0.0000000E+00 /
42240 DATA (AM( 0,K,-1),K=0, 2)
42241 & / 0.2428863E+02, 0.1907035E+01, -0.4606457E+00 /
42242 DATA (AM( 1,K,-1),K=0, 2)
42243 & / 0.2006810E+01, -0.1265915E+00, 0.7153556E-02 /
42244 DATA (AM( 2,K,-1),K=0, 2)
42245 & / -0.1884546E+02, -0.2339471E+01, 0.5740679E+01 /
42246 DATA (AM( 3,K,-1),K=0, 2)
42247 & / -0.2527892E+02, -0.2044124E+01, 0.1280470E+02 /
42248 DATA (AM( 4,K,-1),K=0, 2)
42249 & / -0.1013824E+03, -0.1594199E+01, 0.2216401E+00 /
42250 DATA (AM( 5,K,-1),K=0, 2)
42251 & / 0.8070930E+02, 0.1792072E+01, -0.2164364E+02 /
42252 DATA (AM( 6,K,-1),K=0, 2)
42253 & / -0.4641050E+02, 0.1977338E+00, 0.1273014E+02 /
42254 DATA (AM( 7,K,-1),K=0, 2)
42255 & / -0.3910568E+02, 0.1719632E+01, 0.1086525E+02 /
42256 DATA (AM( 8,K,-1),K=0, 2)
42257 & / -0.1185496E+01, -0.1905847E+00, -0.8744118E-03 /
42258
42259 DATA MEXVEC(-2) / 7 /
42260 DATA MLFVEC(-2) / 2 /
42261 DATA UT1VEC(-2) / 0.4782210E+01 /
42262 DATA UT2VEC(-2) / -0.1976856E+02 /
42263 DATA ALFVEC(-2) / 0.7558374E+00 /
42264 DATA QMAVEC(-2) / 0.0000000E+00 /
42265 DATA (AM( 0,K,-2),K=0, 2)
42266 & / -0.6216935E+00, 0.2369963E+00, -0.7909949E-02 /
42267 DATA (AM( 1,K,-2),K=0, 2)
42268 & / 0.1245440E+01, -0.1031510E+00, 0.4916523E-02 /
42269 DATA (AM( 2,K,-2),K=0, 2)
42270 & / -0.7060824E+01, -0.3875283E-01, 0.1784981E+00 /
42271 DATA (AM( 3,K,-2),K=0, 2)
42272 & / -0.7430595E+01, 0.1964572E+00, -0.1284999E+00 /
42273 DATA (AM( 4,K,-2),K=0, 2)
42274 & / -0.6897810E+01, 0.2620543E+01, 0.8012553E-02 /
42275 DATA (AM( 5,K,-2),K=0, 2)
42276 & / 0.1507713E+02, 0.2340307E-01, 0.2482535E+01 /
42277 DATA (AM( 6,K,-2),K=0, 2)
42278 & / -0.1815341E+01, -0.1538698E+01, -0.2014208E+01 /
42279 DATA (AM( 7,K,-2),K=0, 2)
42280 & / -0.2571932E+02, 0.2903941E+00, -0.2848206E+01 /
42281
42282 DATA MEXVEC(-3) / 7 /
42283 DATA MLFVEC(-3) / 2 /
42284 DATA UT1VEC(-3) / 0.4518239E+01 /
42285 DATA UT2VEC(-3) / -0.2690590E+01 /
42286 DATA ALFVEC(-3) / 0.6124079E+00 /
42287 DATA QMAVEC(-3) / 0.0000000E+00 /
42288 DATA (AM( 0,K,-3),K=0, 2)
42289 & / -0.2734458E+01, -0.7245673E+00, -0.6351374E+00 /
42290 DATA (AM( 1,K,-3),K=0, 2)
42291 & / 0.2927174E+01, 0.4822709E+00, -0.1088787E-01 /
42292 DATA (AM( 2,K,-3),K=0, 2)
42293 & / -0.1771017E+02, -0.1416635E+01, 0.8467622E+01 /
42294 DATA (AM( 3,K,-3),K=0, 2)
42295 & / -0.4972782E+02, -0.3348547E+01, 0.1767061E+02 /
42296 DATA (AM( 4,K,-3),K=0, 2)
42297 & / -0.7102770E+01, -0.3205337E+01, 0.4101704E+00 /
42298 DATA (AM( 5,K,-3),K=0, 2)
42299 & / 0.7169698E+02, -0.2205985E+01, -0.2463931E+02 /
42300 DATA (AM( 6,K,-3),K=0, 2)
42301 & / -0.4090347E+02, 0.2103486E+01, 0.1416507E+02 /
42302 DATA (AM( 7,K,-3),K=0, 2)
42303 & / -0.2952639E+02, 0.5376136E+01, 0.7825585E+01 /
42304
42305 DATA MEXVEC(-4) / 7 /
42306 DATA MLFVEC(-4) / 2 /
42307 DATA UT1VEC(-4) / 0.2783230E+01 /
42308 DATA UT2VEC(-4) / -0.1746328E+01 /
42309 DATA ALFVEC(-4) / 0.1115653E+01 /
42310 DATA QMAVEC(-4) / 0.1300000E+01 /
42311 DATA (AM( 0,K,-4),K=0, 2)
42312 & / -0.1743872E+01, -0.1128921E+01, -0.2841969E+00 /
42313 DATA (AM( 1,K,-4),K=0, 2)
42314 & / 0.3345755E+01, 0.3187765E+00, 0.1378124E+00 /
42315 DATA (AM( 2,K,-4),K=0, 2)
42316 & / -0.2037615E+02, 0.4121687E+01, 0.2236520E+00 /
42317 DATA (AM( 3,K,-4),K=0, 2)
42318 & / -0.4703104E+02, 0.5353087E+01, -0.1455347E+01 /
42319 DATA (AM( 4,K,-4),K=0, 2)
42320 & / -0.1060230E+02, -0.1551122E+01, -0.1078863E+01 /
42321 DATA (AM( 5,K,-4),K=0, 2)
42322 & / 0.5088892E+02, -0.8197304E+01, 0.8083451E+01 /
42323 DATA (AM( 6,K,-4),K=0, 2)
42324 & / -0.2819070E+02, 0.4554086E+01, -0.5890995E+01 /
42325 DATA (AM( 7,K,-4),K=0, 2)
42326 & / -0.1098238E+02, 0.2590096E+01, -0.8062879E+01 /
42327
42328 DATA MEXVEC(-5) / 6 /
42329 DATA MLFVEC(-5) / 2 /
42330 DATA UT1VEC(-5) / 0.1619654E+02 /
42331 DATA UT2VEC(-5) / -0.3367346E+01 /
42332 DATA ALFVEC(-5) / 0.5109891E-02 /
42333 DATA QMAVEC(-5) / 0.4500000E+01 /
42334 DATA (AM( 0,K,-5),K=0, 2)
42335 & / -0.6800138E+01, 0.2493627E+01, -0.1075724E+01 /
42336 DATA (AM( 1,K,-5),K=0, 2)
42337 & / 0.3036555E+01, 0.3324733E+00, 0.2008298E+00 /
42338 DATA (AM( 2,K,-5),K=0, 2)
42339 & / -0.5203879E+01, -0.8493476E+01, -0.4523208E+01 /
42340 DATA (AM( 3,K,-5),K=0, 2)
42341 & / -0.1524239E+01, -0.3411912E+01, -0.1771867E+02 /
42342 DATA (AM( 4,K,-5),K=0, 2)
42343 & / -0.1099444E+02, 0.1320930E+01, -0.2353831E+01 /
42344 DATA (AM( 5,K,-5),K=0, 2)
42345 & / 0.1699299E+02, -0.3565802E+02, 0.3566872E+02 /
42346 DATA (AM( 6,K,-5),K=0, 2)
42347 & / -0.1465793E+02, 0.2703365E+02, -0.2176372E+02 /
42348
42349 IF(Q .LE. QMAVEC(IFL)) THEN
42350 PYCT5M = 0.D0
42351 RETURN
42352 ENDIF
42353
42354 IF(X .GE. 1.D0) THEN
42355 PYCT5M = 0.D0
42356 RETURN
42357 ENDIF
42358
42359 TMP = LOG(Q/ALFVEC(IFL))
42360 IF(TMP .LE. 0.D0) THEN
42361 PYCT5M = 0.D0
42362 RETURN
42363 ENDIF
42364
42365 SB = LOG(TMP)
42366 SB1 = SB - 1.2D0
42367 SB2 = SB1*SB1
42368
42369 DO 110 I = 0, NEX
42370 AF(I) = 0.D0
42371 SBX = 1.D0
42372 DO 100 K = 0, MLFVEC(IFL)
42373 AF(I) = AF(I) + SBX*AM(I,K,IFL)
42374 SBX = SB1*SBX
42375 100 CONTINUE
42376 110 CONTINUE
42377
42378 Y = -LOG(X)
42379 U = LOG(X/0.00001D0)
42380
42381 PART1 = AF(1)*Y**(1.D0+0.01D0*AF(4))*(1.D0+ AF(8)*U)
42382 PART2 = AF(0)*(1.D0 - X) + AF(3)*X
42383 PART3 = X*(1.D0-X)*(AF(5)+AF(6)*(1.D0-X)+AF(7)*X*(1.D0-X))
42384 PART4 = UT1VEC(IFL)*LOG(1.D0-X) +
42385 & AF(2)*LOG(1.D0+EXP(UT2VEC(IFL))-X)
42386
42387 PYCT5M = EXP(LOG(X) + PART1 + PART2 + PART3 + PART4)
42388
42389C...Include threshold factor.
42390 PYCT5M = PYCT5M * (1.D0 - QMAVEC(IFL)/Q)
42391
42392 RETURN
42393 END
42394
42395C*********************************************************************
42396
42397C...PYPDPO
42398C...Auxiliary to PYPDPR. Gives proton parton distributions according to
42399C...a few older parametrizations, now obsolete but convenient for
42400C...backwards checks.
42401
42402 SUBROUTINE PYPDPO(X,Q2,XPPR)
42403
42404C...Double precision and integer declarations.
42405 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42406 IMPLICIT INTEGER(I-N)
42407 INTEGER PYK,PYCHGE,PYCOMP
42408C...Commonblocks.
42409 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42410 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
42411 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42412 COMMON/PYINT1/MINT(400),VINT(400)
42413 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
42414 DIMENSION XPPR(-6:6),XQ(9),TX(6),TT(6),TS(6),NEHLQ(8,2),
42415 &CEHLQ(6,6,2,8,2),CDO(3,6,5,2)
42416
42417
42418C...The following data lines are coefficients needed in the
42419C...Eichten, Hinchliffe, Lane, Quigg proton structure function
42420C...parametrizations, see below.
42421C...Powers of 1-x in different cases.
42422 DATA NEHLQ/3,4,7,5,7,7,7,7,3,4,7,6,7,7,7,7/
42423C...Expansion coefficients for up valence quark distribution.
42424 DATA (((CEHLQ(IX,IT,NX,1,1),IX=1,6),IT=1,6),NX=1,2)/
42425 1 7.677D-01,-2.087D-01,-3.303D-01,-2.517D-02,-1.570D-02,-1.000D-04,
42426 2-5.326D-01,-2.661D-01, 3.201D-01, 1.192D-01, 2.434D-02, 7.620D-03,
42427 3 2.162D-01, 1.881D-01,-8.375D-02,-6.515D-02,-1.743D-02,-5.040D-03,
42428 4-9.211D-02,-9.952D-02, 1.373D-02, 2.506D-02, 8.770D-03, 2.550D-03,
42429 5 3.670D-02, 4.409D-02, 9.600D-04,-7.960D-03,-3.420D-03,-1.050D-03,
42430 6-1.549D-02,-2.026D-02,-3.060D-03, 2.220D-03, 1.240D-03, 4.100D-04,
42431 1 2.395D-01, 2.905D-01, 9.778D-02, 2.149D-02, 3.440D-03, 5.000D-04,
42432 2 1.751D-02,-6.090D-03,-2.687D-02,-1.916D-02,-7.970D-03,-2.750D-03,
42433 3-5.760D-03,-5.040D-03, 1.080D-03, 2.490D-03, 1.530D-03, 7.500D-04,
42434 4 1.740D-03, 1.960D-03, 3.000D-04,-3.400D-04,-2.900D-04,-1.800D-04,
42435 5-5.300D-04,-6.400D-04,-1.700D-04, 4.000D-05, 6.000D-05, 4.000D-05,
42436 6 1.700D-04, 2.200D-04, 8.000D-05, 1.000D-05,-1.000D-05,-1.000D-05/
42437 DATA (((CEHLQ(IX,IT,NX,1,2),IX=1,6),IT=1,6),NX=1,2)/
42438 1 7.237D-01,-2.189D-01,-2.995D-01,-1.909D-02,-1.477D-02, 2.500D-04,
42439 2-5.314D-01,-2.425D-01, 3.283D-01, 1.119D-01, 2.223D-02, 7.070D-03,
42440 3 2.289D-01, 1.890D-01,-9.859D-02,-6.900D-02,-1.747D-02,-5.080D-03,
42441 4-1.041D-01,-1.084D-01, 2.108D-02, 2.975D-02, 9.830D-03, 2.830D-03,
42442 5 4.394D-02, 5.116D-02,-1.410D-03,-1.055D-02,-4.230D-03,-1.270D-03,
42443 6-1.991D-02,-2.539D-02,-2.780D-03, 3.430D-03, 1.720D-03, 5.500D-04,
42444 1 2.410D-01, 2.884D-01, 9.369D-02, 1.900D-02, 2.530D-03, 2.400D-04,
42445 2 1.765D-02,-9.220D-03,-3.037D-02,-2.085D-02,-8.440D-03,-2.810D-03,
42446 3-6.450D-03,-5.260D-03, 1.720D-03, 3.110D-03, 1.830D-03, 8.700D-04,
42447 4 2.120D-03, 2.320D-03, 2.600D-04,-4.900D-04,-3.900D-04,-2.300D-04,
42448 5-6.900D-04,-8.200D-04,-2.000D-04, 7.000D-05, 9.000D-05, 6.000D-05,
42449 6 2.400D-04, 3.100D-04, 1.100D-04, 0.000D+00,-2.000D-05,-2.000D-05/
42450C...Expansion coefficients for down valence quark distribution.
42451 DATA (((CEHLQ(IX,IT,NX,2,1),IX=1,6),IT=1,6),NX=1,2)/
42452 1 3.813D-01,-8.090D-02,-1.634D-01,-2.185D-02,-8.430D-03,-6.200D-04,
42453 2-2.948D-01,-1.435D-01, 1.665D-01, 6.638D-02, 1.473D-02, 4.080D-03,
42454 3 1.252D-01, 1.042D-01,-4.722D-02,-3.683D-02,-1.038D-02,-2.860D-03,
42455 4-5.478D-02,-5.678D-02, 8.900D-03, 1.484D-02, 5.340D-03, 1.520D-03,
42456 5 2.220D-02, 2.567D-02,-3.000D-05,-4.970D-03,-2.160D-03,-6.500D-04,
42457 6-9.530D-03,-1.204D-02,-1.510D-03, 1.510D-03, 8.300D-04, 2.700D-04,
42458 1 1.261D-01, 1.354D-01, 3.958D-02, 8.240D-03, 1.660D-03, 4.500D-04,
42459 2 3.890D-03,-1.159D-02,-1.625D-02,-9.610D-03,-3.710D-03,-1.260D-03,
42460 3-1.910D-03,-5.600D-04, 1.590D-03, 1.590D-03, 8.400D-04, 3.900D-04,
42461 4 6.400D-04, 4.900D-04,-1.500D-04,-2.900D-04,-1.800D-04,-1.000D-04,
42462 5-2.000D-04,-1.900D-04, 0.000D+00, 6.000D-05, 4.000D-05, 3.000D-05,
42463 6 7.000D-05, 8.000D-05, 2.000D-05,-1.000D-05,-1.000D-05,-1.000D-05/
42464 DATA (((CEHLQ(IX,IT,NX,2,2),IX=1,6),IT=1,6),NX=1,2)/
42465 1 3.578D-01,-8.622D-02,-1.480D-01,-1.840D-02,-7.820D-03,-4.500D-04,
42466 2-2.925D-01,-1.304D-01, 1.696D-01, 6.243D-02, 1.353D-02, 3.750D-03,
42467 3 1.318D-01, 1.041D-01,-5.486D-02,-3.872D-02,-1.038D-02,-2.850D-03,
42468 4-6.162D-02,-6.143D-02, 1.303D-02, 1.740D-02, 5.940D-03, 1.670D-03,
42469 5 2.643D-02, 2.957D-02,-1.490D-03,-6.450D-03,-2.630D-03,-7.700D-04,
42470 6-1.218D-02,-1.497D-02,-1.260D-03, 2.240D-03, 1.120D-03, 3.500D-04,
42471 1 1.263D-01, 1.334D-01, 3.732D-02, 7.070D-03, 1.260D-03, 3.400D-04,
42472 2 3.660D-03,-1.357D-02,-1.795D-02,-1.031D-02,-3.880D-03,-1.280D-03,
42473 3-2.100D-03,-3.600D-04, 2.050D-03, 1.920D-03, 9.800D-04, 4.400D-04,
42474 4 7.700D-04, 5.400D-04,-2.400D-04,-3.900D-04,-2.400D-04,-1.300D-04,
42475 5-2.600D-04,-2.300D-04, 2.000D-05, 9.000D-05, 6.000D-05, 4.000D-05,
42476 6 9.000D-05, 1.000D-04, 2.000D-05,-2.000D-05,-2.000D-05,-1.000D-05/
42477C...Expansion coefficients for up and down sea quark distributions.
42478 DATA (((CEHLQ(IX,IT,NX,3,1),IX=1,6),IT=1,6),NX=1,2)/
42479 1 6.870D-02,-6.861D-02, 2.973D-02,-5.400D-03, 3.780D-03,-9.700D-04,
42480 2-1.802D-02, 1.400D-04, 6.490D-03,-8.540D-03, 1.220D-03,-1.750D-03,
42481 3-4.650D-03, 1.480D-03,-5.930D-03, 6.000D-04,-1.030D-03,-8.000D-05,
42482 4 6.440D-03, 2.570D-03, 2.830D-03, 1.150D-03, 7.100D-04, 3.300D-04,
42483 5-3.930D-03,-2.540D-03,-1.160D-03,-7.700D-04,-3.600D-04,-1.900D-04,
42484 6 2.340D-03, 1.930D-03, 5.300D-04, 3.700D-04, 1.600D-04, 9.000D-05,
42485 1 1.014D+00,-1.106D+00, 3.374D-01,-7.444D-02, 8.850D-03,-8.700D-04,
42486 2 9.233D-01,-1.285D+00, 4.475D-01,-9.786D-02, 1.419D-02,-1.120D-03,
42487 3 4.888D-02,-1.271D-01, 8.606D-02,-2.608D-02, 4.780D-03,-6.000D-04,
42488 4-2.691D-02, 4.887D-02,-1.771D-02, 1.620D-03, 2.500D-04,-6.000D-05,
42489 5 7.040D-03,-1.113D-02, 1.590D-03, 7.000D-04,-2.000D-04, 0.000D+00,
42490 6-1.710D-03, 2.290D-03, 3.800D-04,-3.500D-04, 4.000D-05, 1.000D-05/
42491 DATA (((CEHLQ(IX,IT,NX,3,2),IX=1,6),IT=1,6),NX=1,2)/
42492 1 1.008D-01,-7.100D-02, 1.973D-02,-5.710D-03, 2.930D-03,-9.900D-04,
42493 2-5.271D-02,-1.823D-02, 1.792D-02,-6.580D-03, 1.750D-03,-1.550D-03,
42494 3 1.220D-02, 1.763D-02,-8.690D-03,-8.800D-04,-1.160D-03,-2.100D-04,
42495 4-1.190D-03,-7.180D-03, 2.360D-03, 1.890D-03, 7.700D-04, 4.100D-04,
42496 5-9.100D-04, 2.040D-03,-3.100D-04,-1.050D-03,-4.000D-04,-2.400D-04,
42497 6 1.190D-03,-1.700D-04,-2.000D-04, 4.200D-04, 1.700D-04, 1.000D-04,
42498 1 1.081D+00,-1.189D+00, 3.868D-01,-8.617D-02, 1.115D-02,-1.180D-03,
42499 2 9.917D-01,-1.396D+00, 4.998D-01,-1.159D-01, 1.674D-02,-1.720D-03,
42500 3 5.099D-02,-1.338D-01, 9.173D-02,-2.885D-02, 5.890D-03,-6.500D-04,
42501 4-3.178D-02, 5.703D-02,-2.070D-02, 2.440D-03, 1.100D-04,-9.000D-05,
42502 5 8.970D-03,-1.392D-02, 2.050D-03, 6.500D-04,-2.300D-04, 2.000D-05,
42503 6-2.340D-03, 3.010D-03, 5.000D-04,-3.900D-04, 6.000D-05, 1.000D-05/
42504C...Expansion coefficients for gluon distribution.
42505 DATA (((CEHLQ(IX,IT,NX,4,1),IX=1,6),IT=1,6),NX=1,2)/
42506 1 9.482D-01,-9.578D-01, 1.009D-01,-1.051D-01, 3.456D-02,-3.054D-02,
42507 2-9.627D-01, 5.379D-01, 3.368D-01,-9.525D-02, 1.488D-02,-2.051D-02,
42508 3 4.300D-01,-8.306D-02,-3.372D-01, 4.902D-02,-9.160D-03, 1.041D-02,
42509 4-1.925D-01,-1.790D-02, 2.183D-01, 7.490D-03, 4.140D-03,-1.860D-03,
42510 5 8.183D-02, 1.926D-02,-1.072D-01,-1.944D-02,-2.770D-03,-5.200D-04,
42511 6-3.884D-02,-1.234D-02, 5.410D-02, 1.879D-02, 3.350D-03, 1.040D-03,
42512 1 2.948D+01,-3.902D+01, 1.464D+01,-3.335D+00, 5.054D-01,-5.915D-02,
42513 2 2.559D+01,-3.955D+01, 1.661D+01,-4.299D+00, 6.904D-01,-8.243D-02,
42514 3-1.663D+00, 1.176D+00, 1.118D+00,-7.099D-01, 1.948D-01,-2.404D-02,
42515 4-2.168D-01, 8.170D-01,-7.169D-01, 1.851D-01,-1.924D-02,-3.250D-03,
42516 5 2.088D-01,-4.355D-01, 2.239D-01,-2.446D-02,-3.620D-03, 1.910D-03,
42517 6-9.097D-02, 1.601D-01,-5.681D-02,-2.500D-03, 2.580D-03,-4.700D-04/
42518 DATA (((CEHLQ(IX,IT,NX,4,2),IX=1,6),IT=1,6),NX=1,2)/
42519 1 2.367D+00, 4.453D-01, 3.660D-01, 9.467D-02, 1.341D-01, 1.661D-02,
42520 2-3.170D+00,-1.795D+00, 3.313D-02,-2.874D-01,-9.827D-02,-7.119D-02,
42521 3 1.823D+00, 1.457D+00,-2.465D-01, 3.739D-02, 6.090D-03, 1.814D-02,
42522 4-1.033D+00,-9.827D-01, 2.136D-01, 1.169D-01, 5.001D-02, 1.684D-02,
42523 5 5.133D-01, 5.259D-01,-1.173D-01,-1.139D-01,-4.988D-02,-2.021D-02,
42524 6-2.881D-01,-3.145D-01, 5.667D-02, 9.161D-02, 4.568D-02, 1.951D-02,
42525 1 3.036D+01,-4.062D+01, 1.578D+01,-3.699D+00, 6.020D-01,-7.031D-02,
42526 2 2.700D+01,-4.167D+01, 1.770D+01,-4.804D+00, 7.862D-01,-1.060D-01,
42527 3-1.909D+00, 1.357D+00, 1.127D+00,-7.181D-01, 2.232D-01,-2.481D-02,
42528 4-2.488D-01, 9.781D-01,-8.127D-01, 2.094D-01,-2.997D-02,-4.710D-03,
42529 5 2.506D-01,-5.427D-01, 2.672D-01,-3.103D-02,-1.800D-03, 2.870D-03,
42530 6-1.128D-01, 2.087D-01,-6.972D-02,-2.480D-03, 2.630D-03,-8.400D-04/
42531C...Expansion coefficients for strange sea quark distribution.
42532 DATA (((CEHLQ(IX,IT,NX,5,1),IX=1,6),IT=1,6),NX=1,2)/
42533 1 4.968D-02,-4.173D-02, 2.102D-02,-3.270D-03, 3.240D-03,-6.700D-04,
42534 2-6.150D-03,-1.294D-02, 6.740D-03,-6.890D-03, 9.000D-04,-1.510D-03,
42535 3-8.580D-03, 5.050D-03,-4.900D-03,-1.600D-04,-9.400D-04,-1.500D-04,
42536 4 7.840D-03, 1.510D-03, 2.220D-03, 1.400D-03, 7.000D-04, 3.500D-04,
42537 5-4.410D-03,-2.220D-03,-8.900D-04,-8.500D-04,-3.600D-04,-2.000D-04,
42538 6 2.520D-03, 1.840D-03, 4.100D-04, 3.900D-04, 1.600D-04, 9.000D-05,
42539 1 9.235D-01,-1.085D+00, 3.464D-01,-7.210D-02, 9.140D-03,-9.100D-04,
42540 2 9.315D-01,-1.274D+00, 4.512D-01,-9.775D-02, 1.380D-02,-1.310D-03,
42541 3 4.739D-02,-1.296D-01, 8.482D-02,-2.642D-02, 4.760D-03,-5.700D-04,
42542 4-2.653D-02, 4.953D-02,-1.735D-02, 1.750D-03, 2.800D-04,-6.000D-05,
42543 5 6.940D-03,-1.132D-02, 1.480D-03, 6.500D-04,-2.100D-04, 0.000D+00,
42544 6-1.680D-03, 2.340D-03, 4.200D-04,-3.400D-04, 5.000D-05, 1.000D-05/
42545 DATA (((CEHLQ(IX,IT,NX,5,2),IX=1,6),IT=1,6),NX=1,2)/
42546 1 6.478D-02,-4.537D-02, 1.643D-02,-3.490D-03, 2.710D-03,-6.700D-04,
42547 2-2.223D-02,-2.126D-02, 1.247D-02,-6.290D-03, 1.120D-03,-1.440D-03,
42548 3-1.340D-03, 1.362D-02,-6.130D-03,-7.900D-04,-9.000D-04,-2.000D-04,
42549 4 5.080D-03,-3.610D-03, 1.700D-03, 1.830D-03, 6.800D-04, 4.000D-04,
42550 5-3.580D-03, 6.000D-05,-2.600D-04,-1.050D-03,-3.800D-04,-2.300D-04,
42551 6 2.420D-03, 9.300D-04,-1.000D-04, 4.500D-04, 1.700D-04, 1.100D-04,
42552 1 9.868D-01,-1.171D+00, 3.940D-01,-8.459D-02, 1.124D-02,-1.250D-03,
42553 2 1.001D+00,-1.383D+00, 5.044D-01,-1.152D-01, 1.658D-02,-1.830D-03,
42554 3 4.928D-02,-1.368D-01, 9.021D-02,-2.935D-02, 5.800D-03,-6.600D-04,
42555 4-3.133D-02, 5.785D-02,-2.023D-02, 2.630D-03, 1.600D-04,-8.000D-05,
42556 5 8.840D-03,-1.416D-02, 1.900D-03, 5.800D-04,-2.500D-04, 1.000D-05,
42557 6-2.300D-03, 3.080D-03, 5.500D-04,-3.700D-04, 7.000D-05, 1.000D-05/
42558C...Expansion coefficients for charm sea quark distribution.
42559 DATA (((CEHLQ(IX,IT,NX,6,1),IX=1,6),IT=1,6),NX=1,2)/
42560 1 9.270D-03,-1.817D-02, 9.590D-03,-6.390D-03, 1.690D-03,-1.540D-03,
42561 2 5.710D-03,-1.188D-02, 6.090D-03,-4.650D-03, 1.240D-03,-1.310D-03,
42562 3-3.960D-03, 7.100D-03,-3.590D-03, 1.840D-03,-3.900D-04, 3.400D-04,
42563 4 1.120D-03,-1.960D-03, 1.120D-03,-4.800D-04, 1.000D-04,-4.000D-05,
42564 5 4.000D-05,-3.000D-05,-1.800D-04, 9.000D-05,-5.000D-05,-2.000D-05,
42565 6-4.200D-04, 7.300D-04,-1.600D-04, 5.000D-05, 5.000D-05, 5.000D-05,
42566 1 8.098D-01,-1.042D+00, 3.398D-01,-6.824D-02, 8.760D-03,-9.000D-04,
42567 2 8.961D-01,-1.217D+00, 4.339D-01,-9.287D-02, 1.304D-02,-1.290D-03,
42568 3 3.058D-02,-1.040D-01, 7.604D-02,-2.415D-02, 4.600D-03,-5.000D-04,
42569 4-2.451D-02, 4.432D-02,-1.651D-02, 1.430D-03, 1.200D-04,-1.000D-04,
42570 5 1.122D-02,-1.457D-02, 2.680D-03, 5.800D-04,-1.200D-04, 3.000D-05,
42571 6-7.730D-03, 7.330D-03,-7.600D-04,-2.400D-04, 1.000D-05, 0.000D+00/
42572 DATA (((CEHLQ(IX,IT,NX,6,2),IX=1,6),IT=1,6),NX=1,2)/
42573 1 9.980D-03,-1.945D-02, 1.055D-02,-6.870D-03, 1.860D-03,-1.560D-03,
42574 2 5.700D-03,-1.203D-02, 6.250D-03,-4.860D-03, 1.310D-03,-1.370D-03,
42575 3-4.490D-03, 7.990D-03,-4.170D-03, 2.050D-03,-4.400D-04, 3.300D-04,
42576 4 1.470D-03,-2.480D-03, 1.460D-03,-5.700D-04, 1.200D-04,-1.000D-05,
42577 5-9.000D-05, 1.500D-04,-3.200D-04, 1.200D-04,-6.000D-05,-4.000D-05,
42578 6-4.200D-04, 7.600D-04,-1.400D-04, 4.000D-05, 7.000D-05, 5.000D-05,
42579 1 8.698D-01,-1.131D+00, 3.836D-01,-8.111D-02, 1.048D-02,-1.300D-03,
42580 2 9.626D-01,-1.321D+00, 4.854D-01,-1.091D-01, 1.583D-02,-1.700D-03,
42581 3 3.057D-02,-1.088D-01, 8.022D-02,-2.676D-02, 5.590D-03,-5.600D-04,
42582 4-2.845D-02, 5.164D-02,-1.918D-02, 2.210D-03,-4.000D-05,-1.500D-04,
42583 5 1.311D-02,-1.751D-02, 3.310D-03, 5.100D-04,-1.200D-04, 5.000D-05,
42584 6-8.590D-03, 8.380D-03,-9.200D-04,-2.600D-04, 1.000D-05,-1.000D-05/
42585C...Expansion coefficients for bottom sea quark distribution.
42586 DATA (((CEHLQ(IX,IT,NX,7,1),IX=1,6),IT=1,6),NX=1,2)/
42587 1 9.010D-03,-1.401D-02, 7.150D-03,-4.130D-03, 1.260D-03,-1.040D-03,
42588 2 6.280D-03,-9.320D-03, 4.780D-03,-2.890D-03, 9.100D-04,-8.200D-04,
42589 3-2.930D-03, 4.090D-03,-1.890D-03, 7.600D-04,-2.300D-04, 1.400D-04,
42590 4 3.900D-04,-1.200D-03, 4.400D-04,-2.500D-04, 2.000D-05,-2.000D-05,
42591 5 2.600D-04, 1.400D-04,-8.000D-05, 1.000D-04, 1.000D-05, 1.000D-05,
42592 6-2.600D-04, 3.200D-04, 1.000D-05,-1.000D-05, 1.000D-05,-1.000D-05,
42593 1 8.029D-01,-1.075D+00, 3.792D-01,-7.843D-02, 1.007D-02,-1.090D-03,
42594 2 7.903D-01,-1.099D+00, 4.153D-01,-9.301D-02, 1.317D-02,-1.410D-03,
42595 3-1.704D-02,-1.130D-02, 2.882D-02,-1.341D-02, 3.040D-03,-3.600D-04,
42596 4-7.200D-04, 7.230D-03,-5.160D-03, 1.080D-03,-5.000D-05,-4.000D-05,
42597 5 3.050D-03,-4.610D-03, 1.660D-03,-1.300D-04,-1.000D-05, 1.000D-05,
42598 6-4.360D-03, 5.230D-03,-1.610D-03, 2.000D-04,-2.000D-05, 0.000D+00/
42599 DATA (((CEHLQ(IX,IT,NX,7,2),IX=1,6),IT=1,6),NX=1,2)/
42600 1 8.980D-03,-1.459D-02, 7.510D-03,-4.410D-03, 1.310D-03,-1.070D-03,
42601 2 5.970D-03,-9.440D-03, 4.800D-03,-3.020D-03, 9.100D-04,-8.500D-04,
42602 3-3.050D-03, 4.440D-03,-2.100D-03, 8.500D-04,-2.400D-04, 1.400D-04,
42603 4 5.300D-04,-1.300D-03, 5.600D-04,-2.700D-04, 3.000D-05,-2.000D-05,
42604 5 2.000D-04, 1.400D-04,-1.100D-04, 1.000D-04, 0.000D+00, 0.000D+00,
42605 6-2.600D-04, 3.200D-04, 0.000D+00,-3.000D-05, 1.000D-05,-1.000D-05,
42606 1 8.672D-01,-1.174D+00, 4.265D-01,-9.252D-02, 1.244D-02,-1.460D-03,
42607 2 8.500D-01,-1.194D+00, 4.630D-01,-1.083D-01, 1.614D-02,-1.830D-03,
42608 3-2.241D-02,-5.630D-03, 2.815D-02,-1.425D-02, 3.520D-03,-4.300D-04,
42609 4-7.300D-04, 8.030D-03,-5.780D-03, 1.380D-03,-1.300D-04,-4.000D-05,
42610 5 3.460D-03,-5.380D-03, 1.960D-03,-2.100D-04, 1.000D-05, 1.000D-05,
42611 6-4.850D-03, 5.950D-03,-1.890D-03, 2.600D-04,-3.000D-05, 0.000D+00/
42612C...Expansion coefficients for top sea quark distribution.
42613 DATA (((CEHLQ(IX,IT,NX,8,1),IX=1,6),IT=1,6),NX=1,2)/
42614 1 4.410D-03,-7.480D-03, 3.770D-03,-2.580D-03, 7.300D-04,-7.100D-04,
42615 2 3.840D-03,-6.050D-03, 3.030D-03,-2.030D-03, 5.800D-04,-5.900D-04,
42616 3-8.800D-04, 1.660D-03,-7.500D-04, 4.700D-04,-1.000D-04, 1.000D-04,
42617 4-8.000D-05,-1.500D-04, 1.200D-04,-9.000D-05, 3.000D-05, 0.000D+00,
42618 5 1.300D-04,-2.200D-04,-2.000D-05,-2.000D-05,-2.000D-05,-2.000D-05,
42619 6-7.000D-05, 1.900D-04,-4.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
42620 1 6.623D-01,-9.248D-01, 3.519D-01,-7.930D-02, 1.110D-02,-1.180D-03,
42621 2 6.380D-01,-9.062D-01, 3.582D-01,-8.479D-02, 1.265D-02,-1.390D-03,
42622 3-2.581D-02, 2.125D-02, 4.190D-03,-4.980D-03, 1.490D-03,-2.100D-04,
42623 4 7.100D-04, 5.300D-04,-1.270D-03, 3.900D-04,-5.000D-05,-1.000D-05,
42624 5 3.850D-03,-5.060D-03, 1.860D-03,-3.500D-04, 4.000D-05, 0.000D+00,
42625 6-3.530D-03, 4.460D-03,-1.500D-03, 2.700D-04,-3.000D-05, 0.000D+00/
42626 DATA (((CEHLQ(IX,IT,NX,8,2),IX=1,6),IT=1,6),NX=1,2)/
42627 1 4.260D-03,-7.530D-03, 3.830D-03,-2.680D-03, 7.600D-04,-7.300D-04,
42628 2 3.640D-03,-6.050D-03, 3.030D-03,-2.090D-03, 5.900D-04,-6.000D-04,
42629 3-9.200D-04, 1.710D-03,-8.200D-04, 5.000D-04,-1.200D-04, 1.000D-04,
42630 4-5.000D-05,-1.600D-04, 1.300D-04,-9.000D-05, 3.000D-05, 0.000D+00,
42631 5 1.300D-04,-2.100D-04,-1.000D-05,-2.000D-05,-2.000D-05,-1.000D-05,
42632 6-8.000D-05, 1.800D-04,-5.000D-05, 2.000D-05, 0.000D+00, 0.000D+00,
42633 1 7.146D-01,-1.007D+00, 3.932D-01,-9.246D-02, 1.366D-02,-1.540D-03,
42634 2 6.856D-01,-9.828D-01, 3.977D-01,-9.795D-02, 1.540D-02,-1.790D-03,
42635 3-3.053D-02, 2.758D-02, 2.150D-03,-4.880D-03, 1.640D-03,-2.500D-04,
42636 4 9.200D-04, 4.200D-04,-1.340D-03, 4.600D-04,-8.000D-05,-1.000D-05,
42637 5 4.230D-03,-5.660D-03, 2.140D-03,-4.300D-04, 6.000D-05, 0.000D+00,
42638 6-3.890D-03, 5.000D-03,-1.740D-03, 3.300D-04,-4.000D-05, 0.000D+00/
42639
42640C...The following data lines are coefficients needed in the
42641C...Duke, Owens proton structure function parametrizations, see below.
42642C...Expansion coefficients for (up+down) valence quark distribution.
42643 DATA ((CDO(IP,IS,1,1),IS=1,6),IP=1,3)/
42644 1 4.190D-01, 3.460D+00, 4.400D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42645 2 4.000D-03, 7.240D-01,-4.860D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42646 3-7.000D-03,-6.600D-02, 1.330D+00, 0.000D+00, 0.000D+00, 0.000D+00/
42647 DATA ((CDO(IP,IS,1,2),IS=1,6),IP=1,3)/
42648 1 3.740D-01, 3.330D+00, 6.030D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42649 2 1.400D-02, 7.530D-01,-6.220D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42650 3 0.000D+00,-7.600D-02, 1.560D+00, 0.000D+00, 0.000D+00, 0.000D+00/
42651C...Expansion coefficients for down valence quark distribution.
42652 DATA ((CDO(IP,IS,2,1),IS=1,6),IP=1,3)/
42653 1 7.630D-01, 4.000D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42654 2-2.370D-01, 6.270D-01,-4.210D-01, 0.000D+00, 0.000D+00, 0.000D+00,
42655 3 2.600D-02,-1.900D-02, 3.300D-02, 0.000D+00, 0.000D+00, 0.000D+00/
42656 DATA ((CDO(IP,IS,2,2),IS=1,6),IP=1,3)/
42657 1 7.610D-01, 3.830D+00, 0.000D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42658 2-2.320D-01, 6.270D-01,-4.180D-01, 0.000D+00, 0.000D+00, 0.000D+00,
42659 3 2.300D-02,-1.900D-02, 3.600D-02, 0.000D+00, 0.000D+00, 0.000D+00/
42660C...Expansion coefficients for (up+down+strange) sea quark distribution.
42661 DATA ((CDO(IP,IS,3,1),IS=1,6),IP=1,3)/
42662 1 1.265D+00, 0.000D+00, 8.050D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42663 2-1.132D+00,-3.720D-01, 1.590D+00, 6.310D+00,-1.050D+01, 1.470D+01,
42664 3 2.930D-01,-2.900D-02,-1.530D-01,-2.730D-01,-3.170D+00, 9.800D+00/
42665 DATA ((CDO(IP,IS,3,2),IS=1,6),IP=1,3)/
42666 1 1.670D+00, 0.000D+00, 9.150D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42667 2-1.920D+00,-2.730D-01, 5.300D-01, 1.570D+01,-1.010D+02, 2.230D+02,
42668 3 5.820D-01,-1.640D-01,-7.630D-01,-2.830D+00, 4.470D+01,-1.170D+02/
42669C...Expansion coefficients for charm sea quark distribution.
42670 DATA ((CDO(IP,IS,4,1),IS=1,6),IP=1,3)/
42671 1 0.000D+00,-3.600D-02, 6.350D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42672 2 1.350D-01,-2.220D-01, 3.260D+00,-3.030D+00, 1.740D+01,-1.790D+01,
42673 3-7.500D-02,-5.800D-02,-9.090D-01, 1.500D+00,-1.130D+01, 1.560D+01/
42674 DATA ((CDO(IP,IS,4,2),IS=1,6),IP=1,3)/
42675 1 0.000D+00,-1.200D-01, 3.510D+00, 0.000D+00, 0.000D+00, 0.000D+00,
42676 2 6.700D-02,-2.330D-01, 3.660D+00,-4.740D-01, 9.500D+00,-1.660D+01,
42677 3-3.100D-02,-2.300D-02,-4.530D-01, 3.580D-01,-5.430D+00, 1.550D+01/
42678C...Expansion coefficients for gluon distribution.
42679 DATA ((CDO(IP,IS,5,1),IS=1,6),IP=1,3)/
42680 1 1.560D+00, 0.000D+00, 6.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
42681 2-1.710D+00,-9.490D-01, 1.440D+00,-7.190D+00,-1.650D+01, 1.530D+01,
42682 3 6.380D-01, 3.250D-01,-1.050D+00, 2.550D-01, 1.090D+01,-1.010D+01/
42683 DATA ((CDO(IP,IS,5,2),IS=1,6),IP=1,3)/
42684 1 8.790D-01, 0.000D+00, 4.000D+00, 9.000D+00, 0.000D+00, 0.000D+00,
42685 2-9.710D-01,-1.160D+00, 1.230D+00,-5.640D+00,-7.540D+00,-5.960D-01,
42686 3 4.340D-01, 4.760D-01,-2.540D-01,-8.170D-01, 5.500D+00, 1.260D-01/
42687
42688C...Euler's beta function, requires ordinary Gamma function
42689 EULBET(X,Y)=PYGAMM(X)*PYGAMM(Y)/PYGAMM(X+Y)
42690
42691C...Leading order proton parton distributions from Glueck, Reya and
42692C...Vogt. Allowed variable range: 0.25 GeV^2 < Q^2 < 10^8 GeV^2 and
42693C...10^-5 < x < 1.
42694 IF(MSTP(51).EQ.11) THEN
42695
42696C...Determine s expansion variable and some x expressions.
42697 Q2IN=MIN(1D8,MAX(0.25D0,Q2))
42698 SD=LOG(LOG(Q2IN/0.232D0**2)/LOG(0.25D0/0.232D0**2))
42699 SD2=SD**2
42700 XL=-LOG(X)
42701 XS=SQRT(X)
42702
42703C...Evaluate valence, gluon and sea distributions.
42704 XFVUD=(0.663D0+0.191D0*SD-0.041D0*SD2+0.031D0*SD**3)*
42705 & X**0.326D0*(1D0+(-1.97D0+6.74D0*SD-1.96D0*SD2)*XS+
42706 & (24.4D0-20.7D0*SD+4.08D0*SD2)*X)*
42707 & (1D0-X)**(2.86D0+0.70D0*SD-0.02D0*SD2)
42708 XFVDD=(0.579D0+0.283D0*SD+0.047D0*SD2)*X**(0.523D0-0.015D0*SD)*
42709 & (1D0+(2.22D0-0.59D0*SD-0.27D0*SD2)*XS+(5.95D0-6.19D0*SD+
42710 & 1.55D0*SD2)*X)*(1D0-X)**(3.57D0+0.94D0*SD-0.16D0*SD2)
42711 XFGLU=(X**(1.00D0-0.17D0*SD)*((4.879D0*SD-1.383D0*SD2)+
42712 & (25.92D0-28.97D0*SD+5.596D0*SD2)*X+(-25.69D0+23.68D0*SD-
42713 & 1.975D0*SD2)*X**2)+SD**0.558D0*EXP(-(0.595D0+2.138D0*SD)+
42714 & SQRT(4.066D0*SD**1.218D0*XL)))*
42715 & (1D0-X)**(2.537D0+1.718D0*SD+0.353D0*SD2)
42716 XFSEA=(X**(0.412D0-0.171D0*SD)*(0.363D0-1.196D0*X+(1.029D0+
42717 & 1.785D0*SD-0.459D0*SD2)*X**2)*XL**(0.566D0-0.496D0*SD)+
42718 & SD**1.396D0*EXP(-(3.838D0+1.944D0*SD)+SQRT(2.845D0*SD**1.331D0*
42719 & XL)))*(1D0-X)**(4.696D0+2.109D0*SD)
42720 XFSTR=SD**0.803D0*(1D0+(-3.055D0+1.024D0*SD**0.67D0)*XS+
42721 & (27.4D0-20.0D0*SD**0.154D0)*X)*(1D0-X)**6.22D0*
42722 & EXP(-(4.33D0+1.408D0*SD)+SQRT((8.27D0-0.437D0*SD)*
42723 & SD**0.563D0*XL))/XL**(2.082D0-0.577D0*SD)
42724 IF(SD.LE.0.888D0) THEN
42725 XFCHM=0D0
42726 ELSE
42727 XFCHM=(SD-0.888D0)**1.01D0*(1.+(4.24D0-0.804D0*SD)*X)*
42728 & (1D0-X)**(3.46D0+1.076D0*SD)*EXP(-(4.61D0+1.49D0*SD)+
42729 & SQRT((2.555D0+1.961D0*SD)*SD**0.37D0*XL))
42730 ENDIF
42731 IF(SD.LE.1.351D0) THEN
42732 XFBOT=0D0
42733 ELSE
42734 XFBOT=(SD-1.351D0)*(1D0+1.848D0*X)*(1D0-X)**(2.929D0+
42735 & 1.396D0*SD)*EXP(-(4.71D0+1.514D0*SD)+
42736 & SQRT((4.02D0+1.239D0*SD)*SD**0.51D0*XL))
42737 ENDIF
42738
42739C...Put into output array.
42740 XPPR(0)=XFGLU
42741 XPPR(1)=XFVDD+XFSEA
42742 XPPR(2)=XFVUD-XFVDD+XFSEA
42743 XPPR(3)=XFSTR
42744 XPPR(4)=XFCHM
42745 XPPR(5)=XFBOT
42746 XPPR(-1)=XFSEA
42747 XPPR(-2)=XFSEA
42748 XPPR(-3)=XFSTR
42749 XPPR(-4)=XFCHM
42750 XPPR(-5)=XFBOT
42751
42752C...Proton parton distributions from Eichten, Hinchliffe, Lane, Quigg.
42753C...Allowed variable range: 5 GeV^2 < Q^2 < 1E8 GeV^2; 1E-4 < x < 1
42754 ELSEIF(MSTP(51).EQ.12.OR.MSTP(51).EQ.13) THEN
42755
42756C...Determine set, Lambda and x and t expansion variables.
42757 NSET=MSTP(51)-11
42758 IF(NSET.EQ.1) ALAM=0.2D0
42759 IF(NSET.EQ.2) ALAM=0.29D0
42760 TMIN=LOG(5D0/ALAM**2)
42761 TMAX=LOG(1D8/ALAM**2)
42762 T=LOG(MAX(1D0,Q2/ALAM**2))
42763 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42764 NX=1
42765 IF(X.LE.0.1D0) NX=2
42766 IF(NX.EQ.1) VX=(2D0*X-1.1D0)/0.9D0
42767 IF(NX.EQ.2) VX=MAX(-1D0,(2D0*LOG(X)+11.51293D0)/6.90776D0)
42768
42769C...Chebyshev polynomials for x and t expansion.
42770 TX(1)=1D0
42771 TX(2)=VX
42772 TX(3)=2D0*VX**2-1D0
42773 TX(4)=4D0*VX**3-3D0*VX
42774 TX(5)=8D0*VX**4-8D0*VX**2+1D0
42775 TX(6)=16D0*VX**5-20D0*VX**3+5D0*VX
42776 TT(1)=1D0
42777 TT(2)=VT
42778 TT(3)=2D0*VT**2-1D0
42779 TT(4)=4D0*VT**3-3D0*VT
42780 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42781 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42782
42783C...Calculate structure functions.
42784 DO 120 KFL=1,6
42785 XQSUM=0D0
42786 DO 110 IT=1,6
42787 DO 100 IX=1,6
42788 XQSUM=XQSUM+CEHLQ(IX,IT,NX,KFL,NSET)*TX(IX)*TT(IT)
42789 100 CONTINUE
42790 110 CONTINUE
42791 XQ(KFL)=XQSUM*(1D0-X)**NEHLQ(KFL,NSET)
42792 120 CONTINUE
42793
42794C...Put into output array.
42795 XPPR(0)=XQ(4)
42796 XPPR(1)=XQ(2)+XQ(3)
42797 XPPR(2)=XQ(1)+XQ(3)
42798 XPPR(3)=XQ(5)
42799 XPPR(4)=XQ(6)
42800 XPPR(-1)=XQ(3)
42801 XPPR(-2)=XQ(3)
42802 XPPR(-3)=XQ(5)
42803 XPPR(-4)=XQ(6)
42804
42805C...Special expansion for bottom (threshold effects).
42806 IF(MSTP(58).GE.5) THEN
42807 IF(NSET.EQ.1) TMIN=8.1905D0
42808 IF(NSET.EQ.2) TMIN=7.4474D0
42809 IF(T.GT.TMIN) THEN
42810 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42811 TT(1)=1D0
42812 TT(2)=VT
42813 TT(3)=2D0*VT**2-1D0
42814 TT(4)=4D0*VT**3-3D0*VT
42815 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42816 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42817 XQSUM=0D0
42818 DO 140 IT=1,6
42819 DO 130 IX=1,6
42820 XQSUM=XQSUM+CEHLQ(IX,IT,NX,7,NSET)*TX(IX)*TT(IT)
42821 130 CONTINUE
42822 140 CONTINUE
42823 XPPR(5)=XQSUM*(1D0-X)**NEHLQ(7,NSET)
42824 XPPR(-5)=XPPR(5)
42825 ENDIF
42826 ENDIF
42827
42828C...Special expansion for top (threshold effects).
42829 IF(MSTP(58).GE.6) THEN
42830 IF(NSET.EQ.1) TMIN=11.5528D0
42831 IF(NSET.EQ.2) TMIN=10.8097D0
42832 TMIN=TMIN+2D0*LOG(PMAS(6,1)/30D0)
42833 TMAX=TMAX+2D0*LOG(PMAS(6,1)/30D0)
42834 IF(T.GT.TMIN) THEN
42835 VT=MAX(-1D0,MIN(1D0,(2D0*T-TMAX-TMIN)/(TMAX-TMIN)))
42836 TT(1)=1D0
42837 TT(2)=VT
42838 TT(3)=2D0*VT**2-1D0
42839 TT(4)=4D0*VT**3-3D0*VT
42840 TT(5)=8D0*VT**4-8D0*VT**2+1D0
42841 TT(6)=16D0*VT**5-20D0*VT**3+5D0*VT
42842 XQSUM=0D0
42843 DO 160 IT=1,6
42844 DO 150 IX=1,6
42845 XQSUM=XQSUM+CEHLQ(IX,IT,NX,8,NSET)*TX(IX)*TT(IT)
42846 150 CONTINUE
42847 160 CONTINUE
42848 XPPR(6)=XQSUM*(1D0-X)**NEHLQ(8,NSET)
42849 XPPR(-6)=XPPR(6)
42850 ENDIF
42851 ENDIF
42852
42853C...Proton parton distributions from Duke, Owens.
42854C...Allowed variable range: 4 GeV^2 < Q^2 < approx 1E6 GeV^2.
42855 ELSEIF(MSTP(51).EQ.14.OR.MSTP(51).EQ.15) THEN
42856
42857C...Determine set, Lambda and s expansion parameter.
42858 NSET=MSTP(51)-13
42859 IF(NSET.EQ.1) ALAM=0.2D0
42860 IF(NSET.EQ.2) ALAM=0.4D0
42861 Q2IN=MIN(1D6,MAX(4D0,Q2))
42862 SD=LOG(LOG(Q2IN/ALAM**2)/LOG(4D0/ALAM**2))
42863
42864C...Calculate structure functions.
42865 DO 180 KFL=1,5
42866 DO 170 IS=1,6
42867 TS(IS)=CDO(1,IS,KFL,NSET)+CDO(2,IS,KFL,NSET)*SD+
42868 & CDO(3,IS,KFL,NSET)*SD**2
42869 170 CONTINUE
42870 IF(KFL.LE.2) THEN
42871 XQ(KFL)=X**TS(1)*(1D0-X)**TS(2)*(1D0+TS(3)*X)/(EULBET(TS(1),
42872 & TS(2)+1D0)*(1D0+TS(3)*TS(1)/(TS(1)+TS(2)+1D0)))
42873 ELSE
42874 XQ(KFL)=TS(1)*X**TS(2)*(1D0-X)**TS(3)*(1D0+TS(4)*X+
42875 & TS(5)*X**2+TS(6)*X**3)
42876 ENDIF
42877 180 CONTINUE
42878
42879C...Put into output arrays.
42880 XPPR(0)=XQ(5)
42881 XPPR(1)=XQ(2)+XQ(3)/6D0
42882 XPPR(2)=3D0*XQ(1)-XQ(2)+XQ(3)/6D0
42883 XPPR(3)=XQ(3)/6D0
42884 XPPR(4)=XQ(4)
42885 XPPR(-1)=XQ(3)/6D0
42886 XPPR(-2)=XQ(3)/6D0
42887 XPPR(-3)=XQ(3)/6D0
42888 XPPR(-4)=XQ(4)
42889
42890 ENDIF
42891
42892 RETURN
42893 END
42894
42895C*********************************************************************
42896
42897C...PYHFTH
42898C...Gives threshold attractive/repulsive factor for heavy flavour
42899C...production.
42900
42901 FUNCTION PYHFTH(SH,SQM,FRATT)
42902
42903C...Double precision and integer declarations.
42904 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42905 IMPLICIT INTEGER(I-N)
42906 INTEGER PYK,PYCHGE,PYCOMP
42907C...Commonblocks.
42908 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42909 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42910 COMMON/PYINT1/MINT(400),VINT(400)
42911 SAVE /PYDAT1/,/PYPARS/,/PYINT1/
42912
42913C...Value for alpha_strong.
42914 IF(MSTP(35).LE.1) THEN
42915 ALSSG=PARP(35)
42916 ELSE
42917 MST115=MSTU(115)
42918 MSTU(115)=MSTP(36)
42919 Q2BN=SQRT(MAX(1D0,SQM*((SQRT(SH)-2D0*SQRT(SQM))**2+
42920 & PARP(36)**2)))
42921 ALSSG=PYALPS(Q2BN)
42922 MSTU(115)=MST115
42923 ENDIF
42924
42925C...Evaluate attractive and repulsive factors.
42926 XATTR=4D0*PARU(1)*ALSSG/(3D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42927 FATTR=XATTR/(1D0-EXP(-MIN(50D0,XATTR)))
42928 XREPU=PARU(1)*ALSSG/(6D0*SQRT(MAX(1D-20,1D0-4D0*SQM/SH)))
42929 FREPU=XREPU/(EXP(MIN(50D0,XREPU))-1D0)
42930 PYHFTH=FRATT*FATTR+(1D0-FRATT)*FREPU
42931 VINT(138)=PYHFTH
42932
42933 RETURN
42934 END
42935
42936C*********************************************************************
42937
42938C...PYSPLI
42939C...Splits a hadron remnant into two (partons or hadron + parton)
42940C...in case it is more complicated than just a quark or a diquark.
42941
42942 SUBROUTINE PYSPLI(KF,KFLIN,KFLCH,KFLSP)
42943
42944C...Double precision and integer declarations.
42945 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
42946 IMPLICIT INTEGER(I-N)
42947 INTEGER PYK,PYCHGE,PYCOMP
42948C...Commonblocks. PYDAT1 temporary
42949 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
42950 COMMON/PYINT1/MINT(400),VINT(400)
42951 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
42952 SAVE /PYPARS/,/PYINT1/,/PYDAT1/
42953C...Local array.
42954 DIMENSION KFL(3)
42955
42956C...Preliminaries. Parton composition.
42957 KFA=IABS(KF)
42958 KFS=ISIGN(1,KF)
42959 KFL(1)=MOD(KFA/1000,10)
42960 KFL(2)=MOD(KFA/100,10)
42961 KFL(3)=MOD(KFA/10,10)
42962 IF(KFA.EQ.22.AND.MINT(109).EQ.2) THEN
42963 KFL(2)=INT(1.5D0+PYR(0))
42964 IF(MINT(105).EQ.333) KFL(2)=3
42965 IF(MINT(105).EQ.443) KFL(2)=4
42966 KFL(3)=KFL(2)
42967 ELSEIF((KFA.EQ.111.OR.KFA.EQ.113).AND.PYR(0).GT.0.5D0) THEN
42968 KFL(2)=2
42969 KFL(3)=2
42970 ELSEIF(KFA.EQ.223.AND.PYR(0).GT.0.5D0) THEN
42971 KFL(2)=1
42972 KFL(3)=1
42973 ELSEIF((KFA.EQ.130.OR.KFA.EQ.310).AND.PYR(0).GT.0.5D0) THEN
42974 KFL(2)=MOD(KFA/10,10)
42975 KFL(3)=MOD(KFA/100,10)
42976 ENDIF
42977 IF(KFLIN.NE.21.AND.KFLIN.NE.22.AND.KFLIN.NE.23) THEN
42978 KFLR=KFLIN*KFS
42979 ELSE
42980 KFLR=KFLIN
42981 ENDIF
42982 KFLCH=0
42983
42984C...Subdivide lepton.
42985 IF(KFA.GE.11.AND.KFA.LE.18) THEN
42986 IF(KFLR.EQ.KFA) THEN
42987 KFLSP=KFS*22
42988 ELSEIF(KFLR.EQ.22) THEN
42989 KFLSP=KFA
42990 ELSEIF(KFLR.EQ.-24.AND.MOD(KFA,2).EQ.1) THEN
42991 KFLSP=KFA+1
42992 ELSEIF(KFLR.EQ.24.AND.MOD(KFA,2).EQ.0) THEN
42993 KFLSP=KFA-1
42994 ELSEIF(KFLR.EQ.21) THEN
42995 KFLSP=KFA
42996 KFLCH=KFS*21
42997 ELSE
42998 KFLSP=KFA
42999 KFLCH=-KFLR
43000 ENDIF
43001
43002C...Subdivide photon.
43003 ELSEIF(KFA.EQ.22.AND.MINT(109).NE.2) THEN
43004 IF(KFLR.NE.21) THEN
43005 KFLSP=-KFLR
43006 ELSE
43007 RAGR=0.75D0*PYR(0)
43008 KFLSP=1
43009 IF(RAGR.GT.0.125D0) KFLSP=2
43010 IF(RAGR.GT.0.625D0) KFLSP=3
43011 IF(PYR(0).GT.0.5D0) KFLSP=-KFLSP
43012 KFLCH=-KFLSP
43013 ENDIF
43014
43015C...Subdivide Reggeon or Pomeron.
43016 ELSEIF(KFA.EQ.110.OR.KFA.EQ.990) THEN
43017 IF(KFLIN.EQ.21) THEN
43018 KFLSP=KFS*21
43019 ELSE
43020 KFLSP=-KFLIN
43021 ENDIF
43022
43023C...Subdivide meson.
43024 ELSEIF(KFL(1).EQ.0) THEN
43025 KFL(2)=KFL(2)*(-1)**KFL(2)
43026 KFL(3)=-KFL(3)*(-1)**IABS(KFL(2))
43027 IF(KFLR.EQ.KFL(2)) THEN
43028 KFLSP=KFL(3)
43029 ELSEIF(KFLR.EQ.KFL(3)) THEN
43030 KFLSP=KFL(2)
43031 ELSEIF(KFLR.EQ.21.AND.PYR(0).GT.0.5D0) THEN
43032 KFLSP=KFL(2)
43033 KFLCH=KFL(3)
43034 ELSEIF(KFLR.EQ.21) THEN
43035 KFLSP=KFL(3)
43036 KFLCH=KFL(2)
43037 ELSEIF(KFLR*KFL(2).GT.0) THEN
43038 NTRY=0
43039 100 NTRY=NTRY+1
43040 CALL PYKFDI(-KFLR,KFL(2),KFDUMP,KFLCH)
43041 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43042 GOTO 100
43043 ELSEIF(KFLCH.EQ.0) THEN
43044 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43045 MINT(51)=1
43046 RETURN
43047 ENDIF
43048 KFLSP=KFL(3)
43049 ELSE
43050 NTRY=0
43051 110 NTRY=NTRY+1
43052 CALL PYKFDI(-KFLR,KFL(3),KFDUMP,KFLCH)
43053 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43054 GOTO 110
43055 ELSEIF(KFLCH.EQ.0) THEN
43056 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43057 MINT(51)=1
43058 RETURN
43059 ENDIF
43060 KFLSP=KFL(2)
43061 ENDIF
43062
43063C...Special case for extracting photon from baryon without splitting
43064C...the latter. (Currently only used by external programs.)
43065 ELSEIF(KFLIN.EQ.22.AND.MSTP(98).EQ.1) then
43066 KFLSP=KFA
43067 KFLCH=0
43068
43069C...Subdivide baryon.
43070 ELSE
43071 NAGR=0
43072 DO 120 J=1,3
43073 IF(KFLR.EQ.KFL(J)) NAGR=NAGR+1
43074 120 CONTINUE
43075 IF(NAGR.GE.1) THEN
43076 RAGR=0.00001D0+(NAGR-0.00002D0)*PYR(0)
43077 IAGR=0
43078 DO 130 J=1,3
43079 IF(KFLR.EQ.KFL(J)) RAGR=RAGR-1D0
43080 IF(IAGR.EQ.0.AND.RAGR.LE.0D0) IAGR=J
43081 130 CONTINUE
43082 ELSE
43083 IAGR=1.00001D0+2.99998D0*PYR(0)
43084 ENDIF
43085 ID1=1
43086 IF(IAGR.EQ.1) ID1=2
43087 IF(IAGR.EQ.1.AND.KFL(3).GT.KFL(2)) ID1=3
43088 ID2=6-IAGR-ID1
43089 KSP=3
43090 IF(MOD(KFA,10).EQ.2.AND.KFL(1).EQ.KFL(2)) THEN
43091 IF(IAGR.NE.3.AND.PYR(0).GT.0.25D0) KSP=1
43092 ELSEIF(MOD(KFA,10).EQ.2.AND.KFL(2).GE.KFL(3)) THEN
43093 IF(IAGR.NE.1.AND.PYR(0).GT.0.25D0) KSP=1
43094 ELSEIF(MOD(KFA,10).EQ.2) THEN
43095 IF(IAGR.EQ.1) KSP=1
43096 IF(IAGR.NE.1.AND.PYR(0).GT.0.75D0) KSP=1
43097 ENDIF
43098 KFLSP=1000*KFL(ID1)+100*KFL(ID2)+KSP
43099 IF(KFLR.EQ.21) THEN
43100 KFLCH=KFL(IAGR)
43101 ELSEIF(NAGR.EQ.0.AND.KFLR.GT.0) THEN
43102 NTRY=0
43103 140 NTRY=NTRY+1
43104 CALL PYKFDI(-KFLR,KFL(IAGR),KFDUMP,KFLCH)
43105 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43106 GOTO 140
43107 ELSEIF(KFLCH.EQ.0) THEN
43108 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43109 MINT(51)=1
43110 RETURN
43111 ENDIF
43112 ELSEIF(NAGR.EQ.0) THEN
43113 NTRY=0
43114 150 NTRY=NTRY+1
43115 CALL PYKFDI(10000*KFL(ID1)+KFLSP,-KFLR,KFDUMP,KFLCH)
43116 IF(KFLCH.EQ.0.AND.NTRY.LT.100) THEN
43117 GOTO 150
43118 ELSEIF(KFLCH.EQ.0) THEN
43119 CALL PYERRM(14,'(PYSPLI:) caught in infinite loop')
43120 MINT(51)=1
43121 RETURN
43122 ENDIF
43123 KFLSP=KFL(IAGR)
43124 ENDIF
43125 ENDIF
43126
43127C...Add on correct sign for result.
43128 KFLCH=KFLCH*KFS
43129 KFLSP=KFLSP*KFS
43130
43131 RETURN
43132 END
43133
43134C*********************************************************************
43135
43136C...PYGAMM
43137C...Gives ordinary Gamma function Gamma(x) for positive, real arguments;
43138C...see M. Abramowitz, I. A. Stegun: Handbook of Mathematical Functions
43139C...(Dover, 1965) 6.1.36.
43140
43141 FUNCTION PYGAMM(X)
43142
43143C...Double precision and integer declarations.
43144 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43145 IMPLICIT INTEGER(I-N)
43146 INTEGER PYK,PYCHGE,PYCOMP
43147C...Local array and data.
43148 DIMENSION B(8)
43149 DATA B/-0.577191652D0,0.988205891D0,-0.897056937D0,0.918206857D0,
43150 &-0.756704078D0,0.482199394D0,-0.193527818D0,0.035868343D0/
43151
43152 NX=INT(X)
43153 DX=X-NX
43154
43155 PYGAMM=1D0
43156 DXP=1D0
43157 DO 100 I=1,8
43158 DXP=DXP*DX
43159 PYGAMM=PYGAMM+B(I)*DXP
43160 100 CONTINUE
43161 IF(X.LT.1D0) THEN
43162 PYGAMM=PYGAMM/X
43163 ELSE
43164 DO 110 IX=1,NX-1
43165 PYGAMM=(X-IX)*PYGAMM
43166 110 CONTINUE
43167 ENDIF
43168
43169 RETURN
43170 END
43171
43172C***********************************************************************
43173
43174C...PYWAUX
43175C...Calculates real and imaginary parts of the auxiliary functions W1
43176C...and W2; see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van
43177C...der Bij, Nucl. Phys. B297 (1988) 221.
43178
43179 SUBROUTINE PYWAUX(IAUX,EPS,WRE,WIM)
43180
43181C...Double precision and integer declarations.
43182 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43183 IMPLICIT INTEGER(I-N)
43184 INTEGER PYK,PYCHGE,PYCOMP
43185C...Commonblocks.
43186 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43187 SAVE /PYDAT1/
43188
43189 ASINH(X)=LOG(X+SQRT(X**2+1D0))
43190 ACOSH(X)=LOG(X+SQRT(X**2-1D0))
43191
43192 IF(EPS.LT.0D0) THEN
43193 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ASINH(SQRT(-1D0/EPS))
43194 IF(IAUX.EQ.2) WRE=4D0*(ASINH(SQRT(-1D0/EPS)))**2
43195 WIM=0D0
43196 ELSEIF(EPS.LT.1D0) THEN
43197 IF(IAUX.EQ.1) WRE=2D0*SQRT(1D0-EPS)*ACOSH(SQRT(1D0/EPS))
43198 IF(IAUX.EQ.2) WRE=4D0*(ACOSH(SQRT(1D0/EPS)))**2-PARU(1)**2
43199 IF(IAUX.EQ.1) WIM=-PARU(1)*SQRT(1D0-EPS)
43200 IF(IAUX.EQ.2) WIM=-4D0*PARU(1)*ACOSH(SQRT(1D0/EPS))
43201 ELSE
43202 IF(IAUX.EQ.1) WRE=2D0*SQRT(EPS-1D0)*ASIN(SQRT(1D0/EPS))
43203 IF(IAUX.EQ.2) WRE=-4D0*(ASIN(SQRT(1D0/EPS)))**2
43204 WIM=0D0
43205 ENDIF
43206
43207 RETURN
43208 END
43209
43210C***********************************************************************
43211
43212C...PYI3AU
43213C...Calculates real and imaginary parts of the auxiliary function I3;
43214C...see R. K. Ellis, I. Hinchliffe, M. Soldate and J. J. van der Bij,
43215C...Nucl. Phys. B297 (1988) 221.
43216
43217 SUBROUTINE PYI3AU(EPS,RAT,Y3RE,Y3IM)
43218
43219C...Double precision and integer declarations.
43220 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43221 IMPLICIT INTEGER(I-N)
43222 INTEGER PYK,PYCHGE,PYCOMP
43223C...Commonblocks.
43224 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43225 SAVE /PYDAT1/
43226
43227 BE=0.5D0*(1D0+SQRT(1D0+RAT*EPS))
43228 IF(EPS.LT.1D0) GA=0.5D0*(1D0+SQRT(1D0-EPS))
43229
43230 IF(EPS.LT.0D0) THEN
43231 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43232 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
43233 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
43234 & PYSPEN(0.25D0*(RAT+1D0)*EPS/(1D0+0.25D0*RAT*EPS),0D0,1)-
43235 & PYSPEN((RAT+1D0)/RAT,0D0,1)+0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-
43236 & LOG(0.25D0*RAT*EPS)**2)+LOG(1D0-0.25D0*EPS)*
43237 & LOG((1D0+0.25D0*(RAT-1D0)*EPS)/(1D0+0.25D0*RAT*EPS))+
43238 & LOG(-0.25D0*EPS)*LOG(0.25D0*RAT*EPS/(1D0+0.25D0*(RAT-1D0)*
43239 & EPS))
43240 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
43241 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
43242 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
43243 & PYSPEN((BE-1D0+0.25D0*EPS)/BE,0D0,1)-
43244 & PYSPEN((BE-1D0+0.25D0*EPS)/(BE-1D0),0D0,1)+
43245 & 0.5D0*(LOG(BE)**2-LOG(BE-1D0)**2)+
43246 & LOG(1D0-0.25D0*EPS)*LOG((BE-0.25D0*EPS)/BE)+
43247 & LOG(-0.25D0*EPS)*LOG((BE-1D0)/(BE-0.25D0*EPS))
43248 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43249 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
43250 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
43251 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(1D0+0.25D0*RAT*EPS),0D0,1)-
43252 & PYSPEN((1D0+0.25D0*RAT*EPS-GA)/(0.25D0*RAT*EPS),0D0,1)+
43253 & 0.5D0*(LOG(1D0+0.25D0*RAT*EPS)**2-LOG(0.25D0*RAT*EPS)**2)+
43254 & LOG(GA)*LOG((GA+0.25D0*RAT*EPS)/(1D0+0.25D0*RAT*EPS))+
43255 & LOG(GA-1D0)*LOG(0.25D0*RAT*EPS/(GA+0.25D0*RAT*EPS))
43256 ELSE
43257 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
43258 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN((BE-GA)/BE,0D0,1)-
43259 & PYSPEN((BE-GA)/(BE-1D0),0D0,1)+0.5D0*(LOG(BE)**2-
43260 & LOG(BE-1D0)**2)+LOG(GA)*LOG((GA+BE-1D0)/BE)+
43261 & LOG(GA-1D0)*LOG((BE-1D0)/(GA+BE-1D0))
43262 ENDIF
43263 F3IM=0D0
43264 ELSEIF(EPS.LT.1D0) THEN
43265 IF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43266 F3RE=PYSPEN(-0.25D0*EPS/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)-
43267 & PYSPEN((1D0-0.25D0*EPS)/(1D0+0.25D0*(RAT-1D0)*EPS),0D0,1)+
43268 & PYSPEN((1D0-0.25D0*EPS)/(-0.25D0*(RAT+1D0)*EPS),0D0,1)-
43269 & PYSPEN(1D0/(RAT+1D0),0D0,1)+LOG((1D0-0.25D0*EPS)/
43270 & (0.25D0*EPS))*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
43271 & (0.25D0*(RAT+1D0)*EPS))
43272 F3IM=-PARU(1)*LOG((1D0+0.25D0*(RAT-1D0)*EPS)/
43273 & (0.25D0*(RAT+1D0)*EPS))
43274 ELSEIF(ABS(EPS).LT.1D-4.AND.ABS(RAT*EPS).GE.1D-4) THEN
43275 F3RE=PYSPEN(-0.25D0*EPS/(BE-0.25D0*EPS),0D0,1)-
43276 & PYSPEN((1D0-0.25D0*EPS)/(BE-0.25D0*EPS),0D0,1)+
43277 & PYSPEN((1D0-0.25D0*EPS)/(1D0-0.25D0*EPS-BE),0D0,1)-
43278 & PYSPEN(-0.25D0*EPS/(1D0-0.25D0*EPS-BE),0D0,1)+
43279 & LOG((1D0-0.25D0*EPS)/(0.25D0*EPS))*
43280 & LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
43281 F3IM=-PARU(1)*LOG((BE-0.25D0*EPS)/(BE-1D0+0.25D0*EPS))
43282 ELSEIF(ABS(EPS).GE.1D-4.AND.ABS(RAT*EPS).LT.1D-4) THEN
43283 F3RE=PYSPEN((GA-1D0)/(GA+0.25D0*RAT*EPS),0D0,1)-
43284 & PYSPEN(GA/(GA+0.25D0*RAT*EPS),0D0,1)+
43285 & PYSPEN(GA/(GA-1D0-0.25D0*RAT*EPS),0D0,1)-
43286 & PYSPEN((GA-1D0)/(GA-1D0-0.25D0*RAT*EPS),0D0,1)+
43287 & LOG(GA/(1D0-GA))*LOG((GA+0.25D0*RAT*EPS)/
43288 & (1D0+0.25D0*RAT*EPS-GA))
43289 F3IM=-PARU(1)*LOG((GA+0.25D0*RAT*EPS)/
43290 & (1D0+0.25D0*RAT*EPS-GA))
43291 ELSE
43292 F3RE=PYSPEN((GA-1D0)/(GA+BE-1D0),0D0,1)-
43293 & PYSPEN(GA/(GA+BE-1D0),0D0,1)+PYSPEN(GA/(GA-BE),0D0,1)-
43294 & PYSPEN((GA-1D0)/(GA-BE),0D0,1)+LOG(GA/(1D0-GA))*
43295 & LOG((GA+BE-1D0)/(BE-GA))
43296 F3IM=-PARU(1)*LOG((GA+BE-1D0)/(BE-GA))
43297 ENDIF
43298 ELSE
43299 RSQ=EPS/(EPS-1D0+(2D0*BE-1D0)**2)
43300 RCTHE=RSQ*(1D0-2D0*BE/EPS)
43301 RSTHE=SQRT(MAX(0D0,RSQ-RCTHE**2))
43302 RCPHI=RSQ*(1D0+2D0*(BE-1D0)/EPS)
43303 RSPHI=SQRT(MAX(0D0,RSQ-RCPHI**2))
43304 R=SQRT(RSQ)
43305 THE=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCTHE/R)))
43306 PHI=ACOS(MAX(-0.999999D0,MIN(0.999999D0,RCPHI/R)))
43307 F3RE=PYSPEN(RCTHE,RSTHE,1)+PYSPEN(RCTHE,-RSTHE,1)-
43308 & PYSPEN(RCPHI,RSPHI,1)-PYSPEN(RCPHI,-RSPHI,1)+
43309 & (PHI-THE)*(PHI+THE-PARU(1))
43310 F3IM=PYSPEN(RCTHE,RSTHE,2)+PYSPEN(RCTHE,-RSTHE,2)-
43311 & PYSPEN(RCPHI,RSPHI,2)-PYSPEN(RCPHI,-RSPHI,2)
43312 ENDIF
43313
43314 Y3RE=2D0/(2D0*BE-1D0)*F3RE
43315 Y3IM=2D0/(2D0*BE-1D0)*F3IM
43316
43317 RETURN
43318 END
43319
43320C***********************************************************************
43321
43322C...PYSPEN
43323C...Calculates real and imaginary part of Spence function; see
43324C...G. 't Hooft and M. Veltman, Nucl. Phys. B153 (1979) 365.
43325
43326 FUNCTION PYSPEN(XREIN,XIMIN,IREIM)
43327
43328C...Double precision and integer declarations.
43329 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43330 IMPLICIT INTEGER(I-N)
43331 INTEGER PYK,PYCHGE,PYCOMP
43332C...Commonblocks.
43333 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43334 SAVE /PYDAT1/
43335C...Local array and data.
43336 DIMENSION B(0:14)
43337 DATA B/
43338 &1.000000D+00, -5.000000D-01, 1.666667D-01,
43339 &0.000000D+00, -3.333333D-02, 0.000000D+00,
43340 &2.380952D-02, 0.000000D+00, -3.333333D-02,
43341 &0.000000D+00, 7.575757D-02, 0.000000D+00,
43342 &-2.531135D-01, 0.000000D+00, 1.166667D+00/
43343
43344 XRE=XREIN
43345 XIM=XIMIN
43346 IF(ABS(1D0-XRE).LT.1D-6.AND.ABS(XIM).LT.1D-6) THEN
43347 IF(IREIM.EQ.1) PYSPEN=PARU(1)**2/6D0
43348 IF(IREIM.EQ.2) PYSPEN=0D0
43349 RETURN
43350 ENDIF
43351
43352 XMOD=SQRT(XRE**2+XIM**2)
43353 IF(XMOD.LT.1D-6) THEN
43354 IF(IREIM.EQ.1) PYSPEN=0D0
43355 IF(IREIM.EQ.2) PYSPEN=0D0
43356 RETURN
43357 ENDIF
43358
43359 XARG=SIGN(ACOS(XRE/XMOD),XIM)
43360 SP0RE=0D0
43361 SP0IM=0D0
43362 SGN=1D0
43363 IF(XMOD.GT.1D0) THEN
43364 ALGXRE=LOG(XMOD)
43365 ALGXIM=XARG-SIGN(PARU(1),XARG)
43366 SP0RE=-PARU(1)**2/6D0-(ALGXRE**2-ALGXIM**2)/2D0
43367 SP0IM=-ALGXRE*ALGXIM
43368 SGN=-1D0
43369 XMOD=1D0/XMOD
43370 XARG=-XARG
43371 XRE=XMOD*COS(XARG)
43372 XIM=XMOD*SIN(XARG)
43373 ENDIF
43374 IF(XRE.GT.0.5D0) THEN
43375 ALGXRE=LOG(XMOD)
43376 ALGXIM=XARG
43377 XRE=1D0-XRE
43378 XIM=-XIM
43379 XMOD=SQRT(XRE**2+XIM**2)
43380 XARG=SIGN(ACOS(XRE/XMOD),XIM)
43381 ALGYRE=LOG(XMOD)
43382 ALGYIM=XARG
43383 SP0RE=SP0RE+SGN*(PARU(1)**2/6D0-(ALGXRE*ALGYRE-ALGXIM*ALGYIM))
43384 SP0IM=SP0IM-SGN*(ALGXRE*ALGYIM+ALGXIM*ALGYRE)
43385 SGN=-SGN
43386 ENDIF
43387
43388 XRE=1D0-XRE
43389 XIM=-XIM
43390 XMOD=SQRT(XRE**2+XIM**2)
43391 XARG=SIGN(ACOS(XRE/XMOD),XIM)
43392 ZRE=-LOG(XMOD)
43393 ZIM=-XARG
43394
43395 SPRE=0D0
43396 SPIM=0D0
43397 SAVERE=1D0
43398 SAVEIM=0D0
43399 DO 100 I=0,14
43400 IF(MAX(ABS(SAVERE),ABS(SAVEIM)).LT.1D-30) GOTO 110
43401 TERMRE=(SAVERE*ZRE-SAVEIM*ZIM)/DBLE(I+1)
43402 TERMIM=(SAVERE*ZIM+SAVEIM*ZRE)/DBLE(I+1)
43403 SAVERE=TERMRE
43404 SAVEIM=TERMIM
43405 SPRE=SPRE+B(I)*TERMRE
43406 SPIM=SPIM+B(I)*TERMIM
43407 100 CONTINUE
43408
43409 110 IF(IREIM.EQ.1) PYSPEN=SP0RE+SGN*SPRE
43410 IF(IREIM.EQ.2) PYSPEN=SP0IM+SGN*SPIM
43411
43412 RETURN
43413 END
43414
43415C***********************************************************************
43416
43417C...PYQQBH
43418C...Calculates the matrix element for the processes
43419C...g + g or q + qbar -> Q + Qbar + H (normally with Q = t).
43420C...REDUCE output and part of the rest courtesy Z. Kunszt, see
43421C...Z. Kunszt, Nucl. Phys. B247 (1984) 339.
43422
43423 SUBROUTINE PYQQBH(WTQQBH)
43424
43425C...Double precision and integer declarations.
43426 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43427 IMPLICIT INTEGER(I-N)
43428 INTEGER PYK,PYCHGE,PYCOMP
43429C...Commonblocks.
43430 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43431 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43432 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43433 COMMON/PYINT1/MINT(400),VINT(400)
43434 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43435 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/
43436C...Local arrays and function.
43437 DIMENSION PP(15,4),CLR(8,8),FM(10,10),RM(8,8),DX(8)
43438 DOT(I,J)=PP(I,4)*PP(J,4)-PP(I,1)*PP(J,1)-PP(I,2)*PP(J,2)-
43439 &PP(I,3)*PP(J,3)
43440
43441C...Mass parameters.
43442 WTQQBH=0D0
43443 ISUB=MINT(1)
43444 SHPR=SQRT(VINT(26))*VINT(1)
43445 PQ=PMAS(PYCOMP(KFPR(ISUB,2)),1)
43446 PH=SQRT(VINT(21))*VINT(1)
43447 SPQ=PQ**2
43448 SPH=PH**2
43449
43450C...Set up outgoing kinematics: 1=t, 2=tbar, 3=H.
43451 DO 100 I=1,2
43452 PT=SQRT(MAX(0D0,VINT(197+5*I)))
43453 PP(I,1)=PT*COS(VINT(198+5*I))
43454 PP(I,2)=PT*SIN(VINT(198+5*I))
43455 100 CONTINUE
43456 PP(3,1)=-PP(1,1)-PP(2,1)
43457 PP(3,2)=-PP(1,2)-PP(2,2)
43458 PMS1=SPQ+PP(1,1)**2+PP(1,2)**2
43459 PMS2=SPQ+PP(2,1)**2+PP(2,2)**2
43460 PMS3=SPH+PP(3,1)**2+PP(3,2)**2
43461 PMT3=SQRT(PMS3)
43462 PP(3,3)=PMT3*SINH(VINT(211))
43463 PP(3,4)=PMT3*COSH(VINT(211))
43464 PMS12=(SHPR-PP(3,4))**2-PP(3,3)**2
43465 PP(1,3)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
43466 &VINT(213)*(SHPR-PP(3,4))*VINT(220))/(2D0*PMS12)
43467 PP(2,3)=-PP(1,3)-PP(3,3)
43468 PP(1,4)=SQRT(PMS1+PP(1,3)**2)
43469 PP(2,4)=SQRT(PMS2+PP(2,3)**2)
43470
43471C...Set up incoming kinematics and derived momentum combinations.
43472 DO 110 I=4,5
43473 PP(I,1)=0D0
43474 PP(I,2)=0D0
43475 PP(I,3)=-0.5D0*SHPR*(-1)**I
43476 PP(I,4)=-0.5D0*SHPR
43477 110 CONTINUE
43478 DO 120 J=1,4
43479 PP(6,J)=PP(1,J)+PP(2,J)
43480 PP(7,J)=PP(1,J)+PP(3,J)
43481 PP(8,J)=PP(1,J)+PP(4,J)
43482 PP(9,J)=PP(1,J)+PP(5,J)
43483 PP(10,J)=-PP(2,J)-PP(3,J)
43484 PP(11,J)=-PP(2,J)-PP(4,J)
43485 PP(12,J)=-PP(2,J)-PP(5,J)
43486 PP(13,J)=-PP(4,J)-PP(5,J)
43487 120 CONTINUE
43488
43489C...Derived kinematics invariants.
43490 X1=DOT(1,2)
43491 X2=DOT(1,3)
43492 X3=DOT(1,4)
43493 X4=DOT(1,5)
43494 X5=DOT(2,3)
43495 X6=DOT(2,4)
43496 X7=DOT(2,5)
43497 X8=DOT(3,4)
43498 X9=DOT(3,5)
43499 X10=DOT(4,5)
43500
43501C...Propagators.
43502 SS1=DOT(7,7)-SPQ
43503 SS2=DOT(8,8)-SPQ
43504 SS3=DOT(9,9)-SPQ
43505 SS4=DOT(10,10)-SPQ
43506 SS5=DOT(11,11)-SPQ
43507 SS6=DOT(12,12)-SPQ
43508 SS7=DOT(13,13)
43509 DX(1)=SS1*SS6
43510 DX(2)=SS2*SS6
43511 DX(3)=SS2*SS4
43512 DX(4)=SS1*SS5
43513 DX(5)=SS3*SS5
43514 DX(6)=SS3*SS4
43515 DX(7)=SS7*SS1
43516 DX(8)=SS7*SS4
43517
43518C...Define colour coefficients for g + g -> Q + Qbar + H.
43519 IF(ISUB.EQ.121.OR.ISUB.EQ.181.OR.ISUB.EQ.186) THEN
43520 DO 140 I=1,3
43521 DO 130 J=1,3
43522 CLR(I,J)=16D0/3D0
43523 CLR(I+3,J+3)=16D0/3D0
43524 CLR(I,J+3)=-2D0/3D0
43525 CLR(I+3,J)=-2D0/3D0
43526 130 CONTINUE
43527 140 CONTINUE
43528 DO 160 L=1,2
43529 DO 150 I=1,3
43530 CLR(I,6+L)=-6D0
43531 CLR(I+3,6+L)=6D0
43532 CLR(6+L,I)=-6D0
43533 CLR(6+L,I+3)=6D0
43534 150 CONTINUE
43535 160 CONTINUE
43536 DO 180 K1=1,2
43537 DO 170 K2=1,2
43538 CLR(6+K1,6+K2)=12D0
43539 170 CONTINUE
43540 180 CONTINUE
43541
43542C...Evaluate matrix elements for g + g -> Q + Qbar + H.
43543 FM(1,1)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X4+X9+2*
43544 & X7+X5)+8*PQ**2*PH**2*(-X1-X4+2*X7)+16*PQ**2*(X2*X9+4*X2*
43545 & X7+X2*X5-2*X4*X7-2*X9*X7)+8*PH**2*X4*X7-16*X2*X9*X7
43546 FM(1,2)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10+X9-X8+2
43547 & *X7-4*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X4-2*X2*X10+X2*X7-2*
43548 & X2*X6-2*X3*X7+2*X4*X7+4*X10*X7-X9*X7-X8*X7)+16*X2*X7*(X4+
43549 & X10)
43550 FM(1,3)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-2*X3-4*
43551 & X4-8*X10+X9+X8-2*X7-4*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X4+X10
43552 & +X6)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
43553 & -4*X2*X4-5*X2*X10+X2*X8-X2*X7-3*X2*X6+X2*X5+X3*X9+2*X3*X7
43554 & -X3*X5+X4*X8+2*X4*X6-3*X4*X5-5*X10*X5+X9*X8+X9*X6+X9*X5+
43555 & X8*X7-4*X6*X5+X5**2)-(16*X2*X5)*(X1+X4+X10+X6)
43556 FM(1,4)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1+X2-X3-X4+X10-
43557 & X9-X8+2*X7+2*X6-X5)+4*PQ**2*PH**2*(X1+X3+X4+X10+2*X7+2*X6
43558 & )+8*PQ**2*(4*X1*X10+4*X1*X7+4*X1*X6+2*X2*X10-X2*X9-X2*X8+
43559 & 4*X2*X7+4*X2*X6-X2*X5+4*X10*X5+4*X7*X5+4*X6*X5)-(8*PH**2*
43560 & X1)*(X10+X7+X6)+16*X2*X5*(X10+X7+X6)
43561 FM(1,5)=8*PQ**4*(-2*X1-2*X4+X10-X9)+4*PQ**2*(4*X1**2-2*X1*
43562 & X2+8*X1*X3+6*X1*X10-2*X1*X9+4*X1*X8+4*X1*X7+4*X1*X6+2*X1*
43563 & X5+X2*X10+4*X3*X4-X3*X9+2*X3*X7+3*X4*X8-2*X4*X6+2*X4*X5-4
43564 & *X10*X7+3*X10*X5-3*X9*X6+3*X8*X7-4*X7**2+4*X7*X5)+8*(X1**
43565 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5-X1*X4*
43566 & X8-X1*X4*X5+X1*X10*X9+X1*X9*X7+X1*X9*X6-X1*X8*X7-X2*X3*X7
43567 & +X2*X4*X6-X2*X10*X7-X2*X7**2+X3*X7*X5-X4*X10*X5-X4*X7*X5-
43568 & X4*X6*X5)
43569 FM(1,6)=16*PQ**4*(-4*X1-X4+X9-X7)+4*PQ**2*PH**2*(-2*X1-X4-
43570 & X7)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X4-3*X1*X9-2*X1*X7-3*
43571 & X1*X5-2*X2*X4-2*X7*X5)-8*PH**2*X4*X7+8*(-X1*X2*X9-2*X1*X2
43572 & *X5-X1*X9**2-X1*X9*X5+X2**2*X7-X2*X4*X5+X2*X9*X7-X2*X7*X5
43573 & +X4*X9*X5+X4*X5**2)
43574 FM(1,7)=8*PQ**4*(2*X3+X4+3*X10+X9+2*X8+3*X7+6*X6)+2*PQ**2*
43575 & PH**2*(-2*X3-X4+3*X10+3*X7+6*X6)+4*PQ**2*(4*X1*X10+4*X1*
43576 & X7+8*X1*X6+6*X2*X10+X2*X9+2*X2*X8+6*X2*X7+12*X2*X6-8*X3*
43577 & X7+4*X4*X7+4*X4*X6+4*X10*X5+4*X9*X7+4*X9*X6-8*X8*X7+4*X7*
43578 & X5+8*X6*X5)+4*PH**2*(-X1*X10-X1*X7-2*X1*X6+2*X3*X7-X4*X7-
43579 & X4*X6)+8*X2*(X10*X5+X9*X7+X9*X6-2*X8*X7+X7*X5+2*X6*X5)
43580 FM(1,8)=8*PQ**4*(2*X3+X4+3*X10+2*X9+X8+3*X7+6*X6)+2*PQ**2*
43581 & PH**2*(-2*X3-X4+2*X10+X7+2*X6)+4*PQ**2*(4*X1*X10-2*X1*X9+
43582 & 2*X1*X8+4*X1*X7+8*X1*X6+5*X2*X10+2*X2*X9+X2*X8+4*X2*X7+8*
43583 & X2*X6-X3*X9-8*X3*X7+2*X3*X5+2*X4*X9-X4*X8+4*X4*X7+4*X4*X6
43584 & +4*X4*X5+5*X10*X5+X9**2-X9*X8+2*X9*X7+5*X9*X6+X9*X5-7*X8*
43585 & X7+2*X8*X5+2*X7*X5+10*X6*X5)+2*PH**2*(-X1*X10+X3*X7-2*X4*
43586 & X7+X4*X6)+4*(-X1*X9**2+X1*X9*X8-2*X1*X9*X5-X1*X8*X5+2*X2*
43587 & X10*X5+X2*X9*X7+X2*X9*X6-2*X2*X8*X7+3*X2*X6*X5+X3*X9*X5+
43588 & X3*X5**2+X4*X9*X5-2*X4*X8*X5+2*X4*X5**2)
43589 FM(2,2)=16*PQ**6+16*PQ**4*(-X1+X3-X4-X10+X7-X6)+16*PQ**2*(
43590 & X3*X10+X3*X7+X3*X6+X4*X7+X10*X7)-16*X3*X10*X7
43591 FM(2,3)=16*PQ**6+8*PQ**4*(-2*X1+X2+2*X3-4*X4-4*X10-X9+X8-2
43592 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5+4*X3*X10-X3*X9-X3*X8-2*X3*
43593 & X7+2*X3*X6+X3*X5-2*X4*X5-2*X10*X5-2*X6*X5)+16*X3*X5*(X10+
43594 & X6)
43595 FM(2,4)=8*PQ**4*(-2*X1-2*X3+X10-X8)+4*PQ**2*(4*X1**2-2*X1*
43596 & X2+8*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+4*X1*X7+4*X1*X6+2*X1*
43597 & X5+X2*X10+4*X3*X4+3*X3*X9-2*X3*X7+2*X3*X5-X4*X8+2*X4*X6-4
43598 & *X10*X6+3*X10*X5+3*X9*X6-3*X8*X7-4*X6**2+4*X6*X5)+8*(-X1
43599 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9-X1*X3*X5+X1*X4
43600 & *X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X1*X8*X6+X2*X3*
43601 & X7-X2*X4*X6-X2*X10*X6-X2*X6**2-X3*X10*X5-X3*X7*X5-X3*X6*
43602 & X5+X4*X6*X5)
43603 FM(2,5)=16*PQ**4*X10+8*PQ**2*(2*X1**2+2*X1*X3+2*X1*X4+2*X1
43604 & *X10+2*X1*X7+2*X1*X6+X3*X7+X4*X6)+8*(-2*X1**3-2*X1**2*X3-
43605 & 2*X1**2*X4-2*X1**2*X10-2*X1**2*X7-2*X1**2*X6-2*X1*X3*X4-
43606 & X1*X3*X10-2*X1*X3*X6-X1*X4*X10-2*X1*X4*X7-X1*X10**2-X1*
43607 & X10*X7-X1*X10*X6-2*X1*X7*X6+X3**2*X7-X3*X4*X7-X3*X4*X6+X3
43608 & *X10*X7+X3*X7**2-X3*X7*X6+X4**2*X6+X4*X10*X6-X4*X7*X6+X4*
43609 & X6**2)
43610 FM(2,6)=8*PQ**4*(-2*X1+X10-X9-2*X7)+4*PQ**2*(4*X1**2+2*X1*
43611 & X2+4*X1*X3+4*X1*X4+6*X1*X10-2*X1*X9+4*X1*X8+8*X1*X6-2*X1*
43612 & X5+4*X2*X4+3*X2*X10+2*X2*X7-3*X3*X9-2*X3*X7-4*X4**2-4*X4*
43613 & X10+3*X4*X8+2*X4*X6+X10*X5-X9*X6+3*X8*X7+4*X7*X6)+8*(X1**
43614 & 2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9+X1*X3*X5+X1*X4*
43615 & X9-X1*X4*X8-X1*X4*X5+X1*X10*X9+X1*X9*X6-X1*X8*X7-X2*X3*X7
43616 & -X2*X4*X7+X2*X4*X6-X2*X10*X7+X3*X7*X5-X4**2*X5-X4*X10*X5-
43617 & X4*X6*X5)
43618 FM(2,7)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
43619 & 2*X1*X4-2*X1*X10+X1*X9-X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
43620 & X4+3*X2*X10+X2*X7+2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9-2*X3*
43621 & X7-4*X3*X6-X3*X5-6*X4**2-6*X4*X10-3*X4*X9-X4*X8-4*X4*X7-2
43622 & *X4*X6-2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+X10*X5
43623 & +X9*X7-2*X8*X7-2*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
43624 & -X1**2*X9+X1**2*X8-2*X1*X2*X10-3*X1*X2*X7-3*X1*X2*X6+X1*
43625 & X3*X9-X1*X3*X5+X1*X4*X9+X1*X4*X8+X1*X4*X5+X1*X10*X9+X1*
43626 & X10*X8-X1*X9*X6+X1*X8*X6+X2*X3*X7-3*X2*X4*X7-X2*X4*X6-3*
43627 & X2*X10*X7-3*X2*X10*X6-3*X2*X7*X6-3*X2*X6**2-2*X3*X4*X5-X3
43628 & *X10*X5-X3*X6*X5-X4**2*X5-X4*X10*X5+X4*X6*X5)
43629 FM(2,8)=8*PQ**4*(X3+2*X4+3*X10+X7+2*X6)+4*PQ**2*(-4*X1*X3-
43630 & 2*X1*X4-2*X1*X10-X1*X9+X1*X8-4*X1*X7-2*X1*X6+X2*X3+2*X2*
43631 & X4+X2*X10-X2*X7-2*X2*X6-6*X3*X4-6*X3*X10-2*X3*X9+X3*X8-2*
43632 & X3*X7-4*X3*X6+X3*X5-6*X4**2-6*X4*X10-2*X4*X9-4*X4*X7-2*X4
43633 & *X6+2*X4*X5-3*X10*X9-3*X10*X8-6*X10*X7-6*X10*X6+3*X10*X5-
43634 & X9*X6-2*X8*X7-3*X8*X6-6*X7*X6+X7*X5-6*X6**2+2*X6*X5)+4*(
43635 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6-3*X1*X3*X5+X1*X4*X9-
43636 & X1*X4*X8-3*X1*X4*X5+X1*X10*X9+X1*X10*X8-2*X1*X10*X5+X1*X9
43637 & *X6+X1*X8*X7+X1*X8*X6-X2*X4*X7+X2*X4*X6-X2*X10*X7-X2*X10*
43638 & X6-2*X2*X7*X6-X2*X6**2-3*X3*X4*X5-3*X3*X10*X5+X3*X7*X5-3*
43639 & X3*X6*X5-3*X4**2*X5-3*X4*X10*X5-X4*X6*X5)
43640 FM(3,3)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X3+X8+X6
43641 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X3-X6)+16*PQ**2*(X2*X5-2*X3*
43642 & X8-2*X3*X6+4*X3*X5+X8*X5)+8*PH**2*X3*X6-16*X3*X8*X5
43643 FM(3,4)=16*PQ**4*(-4*X1-X3+X8-X6)+4*PQ**2*PH**2*(-2*X1-X3-
43644 & X6)+16*PQ**2*(-2*X1**2-3*X1*X2-2*X1*X3-3*X1*X8-2*X1*X6-3*
43645 & X1*X5-2*X2*X3-2*X6*X5)-8*PH**2*X3*X6+8*(-X1*X2*X8-2*X1*X2
43646 & *X5-X1*X8**2-X1*X8*X5+X2**2*X6-X2*X3*X5+X2*X8*X6-X2*X6*X5
43647 & +X3*X8*X5+X3*X5**2)
43648 FM(3,5)=8*PQ**4*(-2*X1+X10-X8-2*X6)+4*PQ**2*(4*X1**2+2*X1*
43649 & X2+4*X1*X3+4*X1*X4+6*X1*X10+4*X1*X9-2*X1*X8+8*X1*X7-2*X1*
43650 & X5+4*X2*X3+3*X2*X10+2*X2*X6-4*X3**2-4*X3*X10+3*X3*X9+2*X3
43651 & *X7-3*X4*X8-2*X4*X6+X10*X5+3*X9*X6-X8*X7+4*X7*X6)+8*(-X1
43652 & **2*X9+X1**2*X8+X1*X2*X7-X1*X2*X6-X1*X3*X9+X1*X3*X8-X1*X3
43653 & *X5+X1*X4*X8+X1*X4*X5+X1*X10*X8-X1*X9*X6+X1*X8*X7+X2*X3*
43654 & X7-X2*X3*X6-X2*X4*X6-X2*X10*X6-X3**2*X5-X3*X10*X5-X3*X7*
43655 & X5+X4*X6*X5)
43656 FM(3,6)=16*PQ**6+4*PQ**4*PH**2+16*PQ**4*(-X1-X2+2*X3+2*X4+
43657 & X10-X9-X8-X7-X6+X5)+4*PQ**2*PH**2*(X1+2*X3+2*X4+X10+X7+X6
43658 & )+8*PQ**2*(4*X1*X3+4*X1*X4+4*X1*X10+4*X2*X3+4*X2*X4+4*X2*
43659 & X10-X2*X5+4*X3*X5+4*X4*X5+2*X10*X5-X9*X5-X8*X5)-(8*PH**2*
43660 & X1)*(X3+X4+X10)+16*X2*X5*(X3+X4+X10)
43661 FM(3,7)=8*PQ**4*(3*X3+6*X4+3*X10+X9+2*X8+2*X7+X6)+2*PQ**2*
43662 & PH**2*(X3+2*X4+2*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+4*
43663 & X1*X10+2*X1*X9-2*X1*X8+2*X2*X3+10*X2*X4+5*X2*X10+2*X2*X9+
43664 & X2*X8+2*X2*X7+4*X2*X6-7*X3*X9+2*X3*X8-8*X3*X7+4*X3*X6+4*
43665 & X3*X5+5*X4*X8+4*X4*X6+8*X4*X5+5*X10*X5-X9*X8-X9*X6+X9*X5+
43666 & X8**2-X8*X7+2*X8*X6+2*X8*X5)+2*PH**2*(-X1*X10+X3*X7-2*X3*
43667 & X6+X4*X6)+4*(-X1*X2*X9-2*X1*X2*X8+X1*X9*X8-X1*X8**2+X2**2
43668 & *X7+2*X2**2*X6+3*X2*X4*X5+2*X2*X10*X5-2*X2*X9*X6+X2*X8*X7
43669 & +X2*X8*X6-2*X3*X9*X5+X3*X8*X5+X4*X8*X5)
43670 FM(3,8)=8*PQ**4*(3*X3+6*X4+3*X10+2*X9+X8+2*X7+X6)+2*PQ**2*
43671 & PH**2*(3*X3+6*X4+3*X10-2*X7-X6)+4*PQ**2*(4*X1*X3+8*X1*X4+
43672 & 4*X1*X10+4*X2*X3+8*X2*X4+4*X2*X10-8*X3*X9+4*X3*X8-8*X3*X7
43673 & +4*X3*X6+6*X3*X5+4*X4*X8+4*X4*X6+12*X4*X5+6*X10*X5+2*X9*
43674 & X5+X8*X5)+4*PH**2*(-X1*X3-2*X1*X4-X1*X10+2*X3*X7-X3*X6-X4
43675 & *X6)+8*X5*(X2*X3+2*X2*X4+X2*X10-2*X3*X9+X3*X8+X4*X8)
43676 FM(4,4)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+2*X2+X3+X8+2*
43677 & X6+X5)+8*PQ**2*PH**2*(-X1-X3+2*X6)+16*PQ**2*(X2*X8+4*X2*
43678 & X6+X2*X5-2*X3*X6-2*X8*X6)+8*PH**2*X3*X6-16*X2*X8*X6
43679 FM(4,5)=16*PQ**6+8*PQ**4*(-2*X1+X2-2*X3-2*X4-4*X10-X9+X8-4
43680 & *X7+2*X6+X5)+8*PQ**2*(-2*X1*X2-2*X2*X3-2*X2*X10-2*X2*X7+
43681 & X2*X6+2*X3*X6-2*X4*X6+4*X10*X6-X9*X6-X8*X6)+16*X2*X6*(X3+
43682 & X10)
43683 FM(4,6)=16*PQ**6-4*PQ**4*PH**2+8*PQ**4*(-2*X1+2*X2-4*X3-2*
43684 & X4-8*X10+X9+X8-4*X7-2*X6+2*X5)-(4*PQ**2*PH**2)*(X1+X3+X10
43685 & +X7)+8*PQ**2*(-2*X1*X2-2*X1*X10+X1*X9+X1*X8-2*X1*X5+X2**2
43686 & -4*X2*X3-5*X2*X10+X2*X9-3*X2*X7-X2*X6+X2*X5+X3*X9+2*X3*X7
43687 & -3*X3*X5+X4*X8+2*X4*X6-X4*X5-5*X10*X5+X9*X8+X9*X6+X8*X7+
43688 & X8*X5-4*X7*X5+X5**2)-(16*X2*X5)*(X1+X3+X10+X7)
43689 FM(4,7)=8*PQ**4*(-X3-2*X4-3*X10-2*X9-X8-6*X7-3*X6)+2*PQ**2
43690 & *PH**2*(X3+2*X4-3*X10-6*X7-3*X6)+4*PQ**2*(-4*X1*X10-8*X1*
43691 & X7-4*X1*X6-6*X2*X10-2*X2*X9-X2*X8-12*X2*X7-6*X2*X6-4*X3*
43692 & X7-4*X3*X6+8*X4*X6-4*X10*X5+8*X9*X6-4*X8*X7-4*X8*X6-8*X7*
43693 & X5-4*X6*X5)+4*PH**2*(X1*X10+2*X1*X7+X1*X6+X3*X7+X3*X6-2*
43694 & X4*X6)+8*X2*(-X10*X5+2*X9*X6-X8*X7-X8*X6-2*X7*X5-X6*X5)
43695 FM(4,8)=8*PQ**4*(-X3-2*X4-3*X10-X9-2*X8-6*X7-3*X6)+2*PQ**2
43696 & *PH**2*(X3+2*X4-2*X10-2*X7-X6)+4*PQ**2*(-4*X1*X10-2*X1*X9
43697 & +2*X1*X8-8*X1*X7-4*X1*X6-5*X2*X10-X2*X9-2*X2*X8-8*X2*X7-4
43698 & *X2*X6+X3*X9-2*X3*X8-4*X3*X7-4*X3*X6-4*X3*X5+X4*X8+8*X4*
43699 & X6-2*X4*X5-5*X10*X5+X9*X8+7*X9*X6-2*X9*X5-X8**2-5*X8*X7-2
43700 & *X8*X6-X8*X5-10*X7*X5-2*X6*X5)+2*PH**2*(X1*X10-X3*X7+2*X3
43701 & *X6-X4*X6)+4*(-X1*X9*X8+X1*X9*X5+X1*X8**2+2*X1*X8*X5-2*X2
43702 & *X10*X5+2*X2*X9*X6-X2*X8*X7-X2*X8*X6-3*X2*X7*X5+2*X3*X9*
43703 & X5-X3*X8*X5-2*X3*X5**2-X4*X8*X5-X4*X5**2)
43704 FM(5,5)=16*PQ**6+16*PQ**4*(-X1-X3+X4-X10-X7+X6)+16*PQ**2*(
43705 & X3*X6+X4*X10+X4*X7+X4*X6+X10*X6)-16*X4*X10*X6
43706 FM(5,6)=16*PQ**6+8*PQ**4*(-2*X1+X2-4*X3+2*X4-4*X10+X9-X8-2
43707 & *X7-2*X6+X5)+8*PQ**2*(-2*X1*X5-2*X3*X5+4*X4*X10-X4*X9-X4*
43708 & X8+2*X4*X7-2*X4*X6+X4*X5-2*X10*X5-2*X7*X5)+16*X4*X5*(X10+
43709 & X7)
43710 FM(5,7)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
43711 & 4*X1*X4+2*X1*X10+X1*X9-X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
43712 & X4-3*X2*X10-2*X2*X7-X2*X6+6*X3**2+6*X3*X4+6*X3*X10+X3*X9+
43713 & 3*X3*X8+2*X3*X7+4*X3*X6+2*X3*X5+6*X4*X10+2*X4*X8+4*X4*X7+
43714 & 2*X4*X6+X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-X10*X5+
43715 & 2*X9*X7+2*X9*X6-X8*X6+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(-
43716 & X1**2*X9+X1**2*X8+2*X1*X2*X10+3*X1*X2*X7+3*X1*X2*X6-X1*X3
43717 & *X9-X1*X3*X8-X1*X3*X5-X1*X4*X8+X1*X4*X5-X1*X10*X9-X1*X10*
43718 & X8-X1*X9*X7+X1*X8*X7+X2*X3*X7+3*X2*X3*X6-X2*X4*X6+3*X2*
43719 & X10*X7+3*X2*X10*X6+3*X2*X7**2+3*X2*X7*X6+X3**2*X5+2*X3*X4
43720 & *X5+X3*X10*X5-X3*X7*X5+X4*X10*X5+X4*X7*X5)
43721 FM(5,8)=8*PQ**4*(-2*X3-X4-3*X10-2*X7-X6)+4*PQ**2*(2*X1*X3+
43722 & 4*X1*X4+2*X1*X10-X1*X9+X1*X8+2*X1*X7+4*X1*X6-2*X2*X3-X2*
43723 & X4-X2*X10+2*X2*X7+X2*X6+6*X3**2+6*X3*X4+6*X3*X10+2*X3*X8+
43724 & 2*X3*X7+4*X3*X6-2*X3*X5+6*X4*X10-X4*X9+2*X4*X8+4*X4*X7+2*
43725 & X4*X6-X4*X5+3*X10*X9+3*X10*X8+6*X10*X7+6*X10*X6-3*X10*X5+
43726 & 3*X9*X7+2*X9*X6+X8*X7+6*X7**2+6*X7*X6-2*X7*X5-X6*X5)+4*(
43727 & X1**2*X9-X1**2*X8-X1*X2*X7+X1*X2*X6+X1*X3*X9-X1*X3*X8+3*
43728 & X1*X3*X5+3*X1*X4*X5-X1*X10*X9-X1*X10*X8+2*X1*X10*X5-X1*X9
43729 & *X7-X1*X9*X6-X1*X8*X7-X2*X3*X7+X2*X3*X6+X2*X10*X7+X2*X10*
43730 & X6+X2*X7**2+2*X2*X7*X6+3*X3**2*X5+3*X3*X4*X5+3*X3*X10*X5+
43731 & X3*X7*X5+3*X4*X10*X5+3*X4*X7*X5-X4*X6*X5)
43732 FM(6,6)=64*PQ**6+16*PQ**4*PH**2+32*PQ**4*(X1+X2+2*X4+X9+X7
43733 & +2*X5)+8*PQ**2*PH**2*(-X1+2*X4-X7)+16*PQ**2*(X2*X5-2*X4*
43734 & X9-2*X4*X7+4*X4*X5+X9*X5)+8*PH**2*X4*X7-16*X4*X9*X5
43735 FM(6,7)=8*PQ**4*(-6*X3-3*X4-3*X10-2*X9-X8-X7-2*X6)+2*PQ**2
43736 & *PH**2*(-2*X3-X4-2*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*X4
43737 & -4*X1*X10+2*X1*X9-2*X1*X8-10*X2*X3-2*X2*X4-5*X2*X10-X2*X9
43738 & -2*X2*X8-4*X2*X7-2*X2*X6-5*X3*X9-4*X3*X7-8*X3*X5-2*X4*X9+
43739 & 7*X4*X8-4*X4*X7+8*X4*X6-4*X4*X5-5*X10*X5-X9**2+X9*X8-2*X9
43740 & *X7+X9*X6-2*X9*X5+X8*X7-X8*X5)+2*PH**2*(X1*X10-X3*X7+2*X4
43741 & *X7-X4*X6)+4*(2*X1*X2*X9+X1*X2*X8+X1*X9**2-X1*X9*X8-2*X2
43742 & **2*X7-X2**2*X6-3*X2*X3*X5-2*X2*X10*X5-X2*X9*X7-X2*X9*X6+
43743 & 2*X2*X8*X7-X3*X9*X5-X4*X9*X5+2*X4*X8*X5)
43744 FM(6,8)=8*PQ**4*(-6*X3-3*X4-3*X10-X9-2*X8-X7-2*X6)+2*PQ**2
43745 & *PH**2*(-6*X3-3*X4-3*X10+X7+2*X6)+4*PQ**2*(-8*X1*X3-4*X1*
43746 & X4-4*X1*X10-8*X2*X3-4*X2*X4-4*X2*X10-4*X3*X9-4*X3*X7-12*
43747 & X3*X5-4*X4*X9+8*X4*X8-4*X4*X7+8*X4*X6-6*X4*X5-6*X10*X5-X9
43748 & *X5-2*X8*X5)+4*PH**2*(2*X1*X3+X1*X4+X1*X10+X3*X7+X4*X7-2*
43749 & X4*X6)+8*X5*(-2*X2*X3-X2*X4-X2*X10-X3*X9-X4*X9+2*X4*X8)
43750 FM(7,7)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+9*
43751 & X2*X10+7*X3*X7+2*X3*X6+2*X4*X7+7*X4*X6+X10*X5+2*X9*X7+7*
43752 & X9*X6+7*X8*X7+2*X8*X6)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2
43753 & *X4*X7-7*X4*X6)+4*X2*(X10*X5+2*X9*X7+7*X9*X6+7*X8*X7+2*X8
43754 & *X6)
43755 FM(7,8)=72*PQ**4*X10+2*PQ**2*PH**2*X10+4*PQ**2*(2*X1*X10+
43756 & 10*X2*X10+7*X3*X9+2*X3*X8+14*X3*X7+4*X3*X6+2*X4*X9+7*X4*
43757 & X8+4*X4*X7+14*X4*X6+10*X10*X5+X9**2+7*X9*X8+2*X9*X7+7*X9*
43758 & X6+X8**2+7*X8*X7+2*X8*X6)+2*PH**2*(7*X1*X10-7*X3*X7-2*X3*
43759 & X6-2*X4*X7-7*X4*X6)+2*(-2*X1*X9**2-14*X1*X9*X8-2*X1*X8**2
43760 & +2*X2*X10*X5+2*X2*X9*X7+7*X2*X9*X6+7*X2*X8*X7+2*X2*X8*X6+
43761 & 7*X3*X9*X5+2*X3*X8*X5+2*X4*X9*X5+7*X4*X8*X5)
43762 FM(8,8)=72*PQ**4*X10+18*PQ**2*PH**2*X10+8*PQ**2*(X1*X10+X2
43763 & *X10+7*X3*X9+2*X3*X8+7*X3*X7+2*X3*X6+2*X4*X9+7*X4*X8+2*X4
43764 & *X7+7*X4*X6+9*X10*X5)+2*PH**2*(-X1*X10-7*X3*X7-2*X3*X6-2*
43765 & X4*X7-7*X4*X6)+4*X5*(X2*X10+7*X3*X9+2*X3*X8+2*X4*X9+7*X4*
43766 & X8)
43767 FM(9,9)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43768 & X3*X7+X4*X6-X10*X5+X9*X6+X8*X7)+PH**2*(X1*X10-X3*X7-X4*X6
43769 & )+2*X2*(-X10*X5+X9*X6+X8*X7)
43770 FM(9,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43771 & X10+2*X3*X9+2*X3*X7+2*X4*X6-2*X10*X5+X9*X8+2*X8*X7)+PH**2
43772 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X8*X7+X3*
43773 & X9*X5)
43774 FMXX=-4*PQ**4*X10-PQ**2*PH**2*X10+2*PQ**2*(-2*X1*X10-2*X2*
43775 & X10+2*X4*X8+2*X4*X6+2*X3*X7-2*X10*X5+X9*X8+2*X9*X6)+PH**2
43776 & *(X1*X10-X3*X7-X4*X6)+2*(-X1*X9*X8-X2*X10*X5+X2*X9*X6+X4*
43777 & X8*X5)
43778 FM(9,10)=0.5D0*(FMXX+FM(9,10))
43779 FM(10,10)=-4*PQ**4*X10-PQ**2*PH**2*X10+4*PQ**2*(-X1*X10-X2*X10+
43780 & X3*X7+X4*X6-X10*X5+X9*X3+X8*X4)+PH**2*(X1*X10-X3*X7-X4*X6
43781 & )+2*X5*(-X10*X2+X9*X3+X8*X4)
43782
43783C...Repackage matrix elements.
43784 DO 200 I=1,8
43785 DO 190 J=I,8
43786 RM(I,J)=FM(I,J)
43787 190 CONTINUE
43788 200 CONTINUE
43789 RM(7,7)=FM(7,7)-2D0*FM(9,9)
43790 RM(7,8)=FM(7,8)-2D0*FM(9,10)
43791 RM(8,8)=FM(8,8)-2D0*FM(10,10)
43792
43793C...Produce final result: matrix elements * colours * propagators.
43794 DO 220 I=1,8
43795 DO 210 J=I,8
43796 FAC=8D0
43797 IF(I.EQ.J)FAC=4D0
43798 WTQQBH=WTQQBH+RM(I,J)*FAC*CLR(I,J)/(DX(I)*DX(J))
43799 210 CONTINUE
43800 220 CONTINUE
43801 WTQQBH=-WTQQBH/256D0
43802
43803 ELSE
43804C...Evaluate matrix elements for q + qbar -> Q + Qbar + H.
43805 A11=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X2*X10+X3
43806 & *X7+X4*X6+X9*X6+X8*X7)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X2)*(X9
43807 & *X6+X8*X7)
43808 A12=-8D0*PQ**4*X10+4D0*PQ**2*(-X2*X10-X3*X9-2D0*X3*X7-X4*X8-
43809 & 2D0*X4*X6-X10*X5-X9*X8-X9*X6-X8*X7)+2D0*PH**2*(-X1*X10+X3*X7
43810 & +X4*X6)+2D0*(2D0*X1*X9*X8-X2*X9*X6-X2*X8*X7-X3*X9*X5-X4*X8*
43811 & X5)
43812 A22=-8D0*PQ**4*X10-2D0*PQ**2*PH**2*X10-(8D0*PQ**2)*(X3*X9+X3*
43813 & X7+X4*X8+X4*X6+X10*X5)+2D0*PH**2*(X3*X7+X4*X6)-(4D0*X5)*(X3
43814 & *X9+X4*X8)
43815
43816C...Produce final result: matrix elements * propagators.
43817 A11=A11/DX(7)**2
43818 A12=A12/(DX(7)*DX(8))
43819 A22=A22/DX(8)**2
43820 WTQQBH=-(A11+A22+2D0*A12)*8D0/9D0
43821 ENDIF
43822
43823 RETURN
43824 END
43825
43826C*********************************************************************
43827
43828C...PYSTBH (and auxiliaries)
43829C.. Evaluates the matrix elements for t + b + H production.
43830
43831 SUBROUTINE PYSTBH(WTTBH)
43832
43833C...DOUBLE PRECISION AND INTEGER DECLARATIONS
43834 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43835 IMPLICIT INTEGER(I-N)
43836 INTEGER PYK,PYCHGE,PYCOMP
43837
43838C...COMMONBLOCKS
43839 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43840 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43841 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
43842 COMMON/PYINT1/MINT(400),VINT(400)
43843 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
43844 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
43845 COMMON/PYINT4/MWID(500),WIDS(500,5)
43846 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
43847 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43848 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
43849 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
43850 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
43851 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
43852 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43853 DOUBLE PRECISION MW2
43854 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,
43855 &/PYINT4/,/PYSUBS/,/PYMSSM/,/PYSGCM/,/PYCTBH/
43856
43857C...LOCAL ARRAYS AND COMPLEX VARIABLES
43858 DIMENSION QQ(4,2),PP(4,3)
43859 DATA QQ/8*0D0/
43860
43861 WTTBH=0D0
43862
43863C...KINEMATIC PARAMETERS.
43864 SHPR=SQRT(VINT(26))*VINT(1)
43865 PH=SQRT(VINT(21))*VINT(1)
43866 SPH=PH**2
43867
43868C...SET UP OUTGOING KINEMATICS: 1=T, 2=TBAR, 3=H.
43869 DO 100 I=1,2
43870 PT=SQRT(MAX(0D0,VINT(197+5*I)))
43871 PP(1,I)=PT*COS(VINT(198+5*I))
43872 PP(2,I)=PT*SIN(VINT(198+5*I))
43873 100 CONTINUE
43874 PP(1,3)=-PP(1,1)-PP(1,2)
43875 PP(2,3)=-PP(2,1)-PP(2,2)
43876 PMS1=VINT(201)**2+PP(1,1)**2+PP(2,1)**2
43877 PMS2=VINT(206)**2+PP(1,2)**2+PP(2,2)**2
43878 PMS3=SPH+PP(1,3)**2+PP(2,3)**2
43879 PMT3=SQRT(PMS3)
43880 PP(3,3)=PMT3*SINH(VINT(211))
43881 PP(4,3)=PMT3*COSH(VINT(211))
43882 PMS12=(SHPR-PP(4,3))**2-PP(3,3)**2
43883 PP(3,1)=(-PP(3,3)*(PMS12+PMS1-PMS2)+
43884 &VINT(213)*(SHPR-PP(4,3))*VINT(220))/(2D0*PMS12)
43885 PP(3,2)=-PP(3,1)-PP(3,3)
43886 PP(4,1)=SQRT(PMS1+PP(3,1)**2)
43887 PP(4,2)=SQRT(PMS2+PP(3,2)**2)
43888
43889C...CM SYSTEM, INGOING QUARKS/GLUONS
43890 QQ(3,1) = SHPR/2.D0
43891 QQ(4,1) = QQ(3,1)
43892 QQ(3,2) = -QQ(3,1)
43893 QQ(4,2) = QQ(4,1)
43894
43895C...PARAMETERS FOR AMPLITUDE METHOD
43896 ALPHA = AEM
43897 ALPHAS = AS
43898 SW2 = PARU(102)
43899 MW2 = PMAS(24,1)**2
43900 TANB = PARU(141)
43901 VTB = VCKM(3,3)
43902 RMB=PYMRUN(5,VINT(52))
43903
43904 ISUB=MINT(1)
43905
43906 IF (ISUB.EQ.401) THEN
43907 CALL PYTBHG(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43908 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43909 ELSE IF (ISUB.EQ.402) THEN
43910 CALL PYTBHQ(QQ(1,1),QQ(1,2),PP(1,1),PP(1,2),PP(1,3),
43911 & VINT(201),VINT(206),RMB,VINT(43),WTTBH)
43912 END IF
43913
43914 RETURN
43915 END
43916C------------------------------------------------------------------
43917 SUBROUTINE PYTBHB(MT,MB,MHP,BR,GAMT)
43918C WIDTH AND BRANCHING RATIO FOR (ON-SHELL) T-> B W+, T->B H+
43919 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43920 IMPLICIT INTEGER(I-N)
43921 DOUBLE PRECISION MW2,MT,MB,MHP,MW,KFUN
43922 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43923 SAVE /PYCTBH/
43924
43925C TOP WIDTH CALCULATION
43926C VTB = 0.99
43927 MW=DSQRT(MW2)
43928 XB=(MB/MT)**2
43929 XW=(MW/MT)**2
43930 XH =(MHP/MT)**2
43931 GAMTBH = 0D0
43932 IF (MT .LT. (MHP+MB)) THEN
43933C T ->B W ONLY
43934 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43935 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43936 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43937 GAMT = GAMTBW
43938 ELSE
43939C T ->BW +T ->B H^+
43940 BETW = DSQRT(1.D0-2*(XB+XW)+(XW-XB)**2)
43941 GAMTBW = VTB**2*ALPHA/(16*SW2)*MT/XW*BETW*
43942 & (2*(1.D0-XB-XW)-(1.D0+XB-XW)*(1.D0-XB -2*XW) )
43943C
43944 KFUN = DSQRT( (1.D0-(MHP/MT)**2-(MB/MT)**2)**2
43945 & -4.D0*(MHP*MB/MT**2)**2 )
43946 GAMTBH= ALPHA/SW2/8.D0*VTB**2*KFUN/MT *
43947 & (V**2*((MT+MB)**2-MHP**2)+A**2*((MT-MB)**2-MHP**2))
43948 GAMT = GAMTBW+GAMTBH
43949 ENDIF
43950C THUS BR IS
43951 BR=GAMTBH/GAMT
43952 RETURN
43953 END
43954
43955C AMPLITUDE SQUARED (MATRIX ELEMENTS) FOR THE PROCESSES:
43956C GG->TBH^+, QQBAR->TBH^+
43957C AS A FUNCTION OF 4-MOMENTA FOR SUITABLE INTERFACE
43958C (FOR INSTANCE WITH PYTHIA)
43959C------------------------------------------------------------
43960C BASED ON F. BORZUMATI, J.-L. KNEUR, N. POLONSKY HEP-PH/9905443,
43961C PHYS REV. D 60 (1999) 115011
43962C (THESE FILES PREPARED BY J.-L. KNEUR)
43963C------------------------------------------------------------
43964C 1) GG->TBH^+
43965 SUBROUTINE PYTBHG(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
43966C
43967C CONVENTIONS AND INPUT/OUTPUT DEFINITIONS:
43968C
43969C INPUT: Q1,Q2 ARE ENTERING 4-MOMENTA OF INITIAL GLUONS OR QUARKS;
43970C P1, P2 ARE THE TOP AND BOTTOM OUTGOING 4-MOMENTA;
43971C P3 IS OUTGOING CHARGED HIGGS 4-MOMENTA.
43972C (NB FOR ALL 4-MOMENTA P(4) IS TIME-COMPONENT)
43973C "PHYSICAL PARAMETERS" INPUT:
43974C MT,MB TOP AND BOTTOM MASSES;
43975C MHP CHARGED HIGGS MASS
43976C FURTHER PARAMETERS INPUT IS NEEDED FROM COMMON/PARAM/ (SEE BELOW)
43977C
43978C OUTPUT: AMP2 IS MATRIX ELEMENT (AMPLITUDE**2) FOR GG->TB H^+
43979C (NB AMP2 IS TRULY AMPLITUDE SQUARRED, I.E. WITHOUT ANY
43980C PHASE SPACE FACTORS INCLUDED. IT INCLUDES COLOUR AND COUPLING
43981C FACTORS, AS EXPLICIT BELOW. ACCORDINGLY, FOR EXAMPLE THE TOTAL
43982C CROSS-SECTION SHOULD BE (SYMBOLICALLY):
43983C SIGMA = INTEGRATE [PARTON DENSITY FUNCTIONS * 3-PARTICLE FINAL
43984C STATE PHASE-SPACE (STANDARDLY NORMALIZED) * AMP2 ]
43985C
43986 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
43987 IMPLICIT INTEGER(I-N)
43988 DOUBLE PRECISION MW2,MT,MB,MHP,MW
43989 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
43990 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
43991 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
43992 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
43993
43994 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
43995 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
43996C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
43997C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
43998C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
43999C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB
44000C (TAN BETA) VALUES
44001C
44002C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
44003C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
44004
44005 PI = 4*DATAN(1.D0)
44006 MW = DSQRT(MW2)
44007C
44008C COLLECTING THE RELEVANT OVERALL FACTORS:
44009C 8X8 INITIAL GLUON COLOR AVERAGE, 2X2 GLUON SPIN AVERAGE
44010 PS=1.D0/(8.D0*8.D0 *2.D0*2.D0)
44011C COUPLING CONSTANT (OVERALL NORMALIZATION)
44012 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
44013C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
44014C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
44015C ALPHAS IS ALPHA_STRONG;
44016C SW2 IS SIN(THETA_W)**2.
44017C
44018C VTB=.998D0
44019C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
44020C
44021 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
44022 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
44023C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
44024C
44025C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
44026C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
44027 DO 100 KK=1,4
44028 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
44029 100 CONTINUE
44030C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
44031 S = 2*PYTBHS(Q1,Q2)
44032 P1Q1=PYTBHS(Q1,P1)
44033 P1Q2=PYTBHS(P1,Q2)
44034 P2Q1=PYTBHS(P2,Q1)
44035 P2Q2=PYTBHS(P2,Q2)
44036 P1P2=PYTBHS(P1,P2)
44037C
44038C TOP WIDTH CALCULATION
44039 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
44040C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
44041C THEN DEFINE TOP (RESONANT) PROPAGATOR:
44042 A1INV= S -2*P1Q1 -2*P1Q2
44043 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
44044C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
44045C NB: A12 = A1*A1 BUT CORRECT EXPRESSION BELOW BECAUSE OF
44046C THE TOP WIDTH
44047 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
44048 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
44049C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
44050C NOW COMES THE AMP**2:
44051C NB COLOR FACTOR (COMING FROM GRAPHS) ALREADY INCLUDED IN
44052C THE EXPRESSIONS BELOW
44053 V18=0.D0
44054 A18=0.D0
44055 V18= 640*A1/3+640*A2/3+32*A1*A2*MB**2-368*A12*MB*MT-
44056 &512*A1*A2*MB*MT/3-
44057 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
44058 &320*A1*A2*P1P2+496*A2**2*P1P2/3+128*A1*MB*MT**3/(3*P1Q1**2)+
44059 &128*A1*MT**4/(3*P1Q1**2)-256*A12*MB*MT**5/(3*P1Q1**2)+
44060 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
44061 &8/(3*P1Q1)-32*A1*MB*MT/P1Q1-56*A2*MB*MT/(3*P1Q1)+
44062 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1+
44063 &704*A12*MB*MT**3/(3*P1Q1)-224*A1*A2*MB*MT**3/(3*P1Q1)+
44064 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1+
44065 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
44066 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
44067 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1+128*A1*MB*MT**3/(3*P1Q2**2)+
44068 &128*A1*MT**4/(3*P1Q2**2)-256*A12*MB*MT**5/(3*P1Q2**2)+
44069 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
44070 &256*A1*MT**2*P1Q1/(3*P1Q2**2)+256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
44071 &8/(3*P1Q2)-32*A1*MB*MT/P1Q2-56*A2*MB*MT/(3*P1Q2)
44072 V18=V18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2+
44073 &704*A12*MB*MT**3/(3*P1Q2)-224*A1*A2*MB*MT**3/(3*P1Q2)+
44074 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2+
44075 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
44076 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2-
44077 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)+
44078 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
44079 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
44080 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
44081 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)+208*A12*MB*MT*P1Q1/(3*P1Q2)-
44082 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
44083 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
44084 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
44085 &256*A1*MT**2*P1Q2/(3*P1Q1**2)+256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
44086 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
44087 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)+208*A12*MB*MT*P1Q2/(3*P1Q1)-
44088 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
44089 V18=V18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
44090 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)+
44091 &128*A2*MB**3*MT/(3*P2Q1**2)-256*A2**2*MB**5*MT/(3*P2Q1**2)+
44092 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
44093 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)-
44094 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
44095 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
44096 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)+
44097 &64*MB**3*MT/(3*P1Q2*P2Q1**2)+
44098 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
44099 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)+
44100 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
44101 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
44102 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
44103 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
44104 &88*A2*MB**2/(3*P2Q1)+56*A1*MB*MT/(3*P2Q1)+32*A2*MB*MT/P2Q1+
44105 &224*A1*A2*MB**3*MT/(3*P2Q1)-704*A2**2*MB**3*MT/(3*P2Q1)
44106 V18=V18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
44107 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)-
44108 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
44109 &16*P1P2/(3*P1Q1*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)-
44110 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)-
44111 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
44112 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
44113 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)+
44114 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)-
44115 &64*MB*MT**3/(3*P1Q2**2*P2Q1)-
44116 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
44117 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
44118 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
44119 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
44120 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
44121 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)+
44122 &64*MB*MT/(3*P1Q2*P2Q1)-128*A2*MB**3*MT/(3*P1Q2*P2Q1)
44123 V18=V18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
44124 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)-128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
44125 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)-
44126 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
44127 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)+
44128 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
44129 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44130 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)+
44131 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44132 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
44133 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
44134 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)+
44135 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)+200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
44136 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
44137 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
44138 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
44139 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
44140 V18=V18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
44141 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)+
44142 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
44143 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
44144 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)+
44145 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
44146 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44147 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44148 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44149 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
44150 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
44151 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)+
44152 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
44153 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
44154 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
44155 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)+
44156 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
44157 V18=V18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
44158 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
44159 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
44160 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
44161 &128*A2*MB**4/(3*P2Q2**2)+128*A2*MB**3*MT/(3*P2Q2**2)-
44162 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
44163 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)-
44164 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
44165 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)+
44166 &64*MB**3*MT/(3*P1Q1*P2Q2**2)+
44167 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
44168 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
44169 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
44170 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
44171 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)+
44172 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
44173 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
44174 V18=V18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
44175 &256*A2*MB**2*P2Q1/(3*P2Q2**2)-256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
44176 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
44177 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)-
44178 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
44179 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
44180 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
44181 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
44182 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
44183 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)+56*A1*MB*MT/(3*P2Q2)+
44184 &32*A2*MB*MT/P2Q2+224*A1*A2*MB**3*MT/(3*P2Q2)-
44185 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
44186 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
44187 &512*A2**2*MB**2*P1P2/(3*P2Q2)-128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
44188 &32*A1*A2*P1P2**2/P2Q2-64*MB*MT**3/(3*P1Q1**2*P2Q2)-
44189 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
44190 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
44191 V18=V18+64*MB*MT/(3*P1Q1*P2Q2)-128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
44192 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
44193 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)-128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
44194 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)-
44195 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
44196 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)+
44197 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
44198 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
44199 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)+
44200 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
44201 &16*P1P2/(3*P1Q2*P2Q2)-32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)-
44202 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)-
44203 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
44204 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)-8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44205 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)+
44206 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44207 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
44208 V18=V18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
44209 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44210 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44211 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44212 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
44213 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)+
44214 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
44215 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44216 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44217 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
44218 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
44219 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)+
44220 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)+200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
44221 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44222 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44223 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
44224 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
44225 V18=V18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
44226 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)+
44227 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
44228 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)-
44229 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)+64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
44230 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
44231 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44232 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)-
44233 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44234 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44235 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44236 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
44237 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)+8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)-
44238 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44239 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44240 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)+
44241 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44242 V18=V18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44243 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
44244 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
44245 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
44246 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2-
44247 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)+208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
44248 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
44249 &96*A2**2*P1P2*P2Q1/P2Q2+256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
44250 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)-
44251 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)-56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
44252 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
44253 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)-
44254 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
44255 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
44256 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
44257 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
44258 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
44259 V18=V18+32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44260 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44261 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
44262 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
44263 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
44264 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
44265 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
44266 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44267 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44268 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
44269 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44270 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44271 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
44272 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
44273 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)+
44274 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
44275 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
44276 V18=V18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
44277 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
44278 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
44279 &16*A1*P2Q2/(3*P1Q1)+112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
44280 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
44281 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
44282 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)+
44283 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
44284 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
44285 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
44286 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
44287 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
44288 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
44289 &256*A2*MB**2*P2Q2/(3*P2Q1**2)-256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
44290 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
44291 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)-
44292 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
44293 V18=V18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
44294 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
44295 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
44296 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
44297 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1-
44298 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)+208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
44299 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
44300 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44301 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44302 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44303 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
44304 &32*A2**2*P1Q1*P2Q2/P2Q1+256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
44305 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
44306 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)-
44307 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)-56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
44308 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
44309 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
44310 V18=V18-256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
44311 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
44312 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
44313 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
44314 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44315 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44316 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
44317 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44318 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44319 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
44320 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
44321 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
44322 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
44323 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)+
44324 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
44325 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
44326 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
44327 V18=V18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)+
44328 &384*A12*MB*MT*P1Q1**2/S**2+
44329 &384*A12*P1P2*P1Q1**2/S**2+2688*A12*MB*MT*P1Q1*P1Q2/S**2+
44330 &2688*A12*P1P2*P1Q1*P1Q2/S**2+384*A12*MB*MT*P1Q2**2/S**2+
44331 &384*A12*P1P2*P1Q2**2/S**2+768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
44332 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2+2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
44333 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
44334 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
44335 &960*A1*A2*P1Q2**2*P2Q1/S**2+384*A2**2*MB*MT*P2Q1**2/S**2+
44336 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
44337 &960*A2**2*P1Q2*P2Q1**2/S**2+2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
44338 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
44339 &960*A1*A2*P1Q1**2*P2Q2/S**2+768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
44340 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
44341 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2+2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
44342 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
44343 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
44344 &960*A2**2*P1Q2*P2Q1*P2Q2/S**2+384*A2**2*MB*MT*P2Q2**2/S**2
44345 V18=V18+384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
44346 &960*A2**2*P1Q1*P2Q2**2/S**2+96*A1*MB*MT/S+96*A2*MB*MT/S-
44347 &768*A2**2*MB**3*MT/S-768*A12*MB*MT**3/S-192*A1*P1P2/S-
44348 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S-2304*A1*A2*MB*MT*P1P2/S-
44349 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S-
44350 &96*A1*MB*MT**3/(P1Q1*S)-192*A2*MB*MT*P1P2/(P1Q1*S)-
44351 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
44352 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S-
44353 &480*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S-
44354 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S-
44355 &96*A1*MB*MT**3/(P1Q2*S)-192*A2*MB*MT*P1P2/(P1Q2*S)-
44356 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)-
44357 &48*A1*MB*MT*P1Q1/(P1Q2*S)+96*A2*MB*MT*P1Q1/(P1Q2*S)-
44358 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
44359 &192*A2*P1P2*P1Q1/(P1Q2*S)+192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)+
44360 &192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
44361 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)
44362 V18=V18-192*A12*MB*MT*P1Q1**2/(P1Q2*S)+
44363 &96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
44364 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
44365 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S-
44366 &480*A12*MB*MT*P1Q2/S+96*A1*A2*MB*MT*P1Q2/S-
44367 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S-
44368 &48*A1*MB*MT*P1Q2/(P1Q1*S)+96*A2*MB*MT*P1Q2/(P1Q1*S)-
44369 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
44370 &192*A2*P1P2*P1Q2/(P1Q1*S)+192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
44371 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
44372 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
44373 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)-
44374 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)+96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
44375 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q1*S)+
44376 &96*A2*MB**2*P1P2/(P2Q1*S)+192*A1*MB*MT*P1P2/(P2Q1*S)+
44377 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)+
44378 &192*A2*MB**2*P1Q1/(P2Q1*S)+96*A1*MB*MT*P1Q1/(P2Q1*S)+
44379 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)
44380 V18=V18+192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
44381 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)+
44382 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
44383 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44384 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44385 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
44386 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44387 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44388 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
44389 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
44390 &48*A2*MB**2*P1Q2/(P2Q1*S)-192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
44391 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
44392 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S-
44393 &96*A1*A2*MB*MT*P2Q1/S+480*A2**2*MB*MT*P2Q1/S+
44394 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S+
44395 &672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S+
44396 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)
44397 V18=V18+96*A2*MT**2*P2Q1/(P1Q1*S)+
44398 &192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
44399 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
44400 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
44401 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)-
44402 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
44403 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)-
44404 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
44405 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44406 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
44407 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
44408 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
44409 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
44410 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)-
44411 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
44412 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)+
44413 &96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
44414 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)
44415 V18=V18-384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
44416 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
44417 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)+96*A2*MB**3*MT/(P2Q2*S)+
44418 &96*A2*MB**2*P1P2/(P2Q2*S)+192*A1*MB*MT*P1P2/(P2Q2*S)+
44419 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
44420 &48*A2*MB**2*P1Q1/(P2Q2*S)-192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
44421 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
44422 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
44423 &192*A2*MB**2*P1Q2/(P2Q2*S)+96*A1*MB*MT*P1Q2/(P2Q2*S)+
44424 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
44425 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)+
44426 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
44427 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)+
44428 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
44429 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)+
44430 &96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
44431 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)
44432 V18=V18+48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
44433 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)+
44434 &96*A1*MB*MT*P2Q1/(P2Q2*S)-48*A2*MB*MT*P2Q1/(P2Q2*S)-
44435 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)+
44436 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
44437 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)-
44438 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)-
44439 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44440 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
44441 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
44442 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
44443 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
44444 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
44445 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
44446 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
44447 &96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)+
44448 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)
44449 V18=V18+576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
44450 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44451 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44452 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44453 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44454 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
44455 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
44456 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
44457 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
44458 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)-
44459 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)+192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
44460 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)+
44461 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
44462 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
44463 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
44464 &96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
44465 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)
44466 V18=V18-192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+
44467 &96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
44468 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S-
44469 &96*A1*A2*MB*MT*P2Q2/S+480*A2**2*MB*MT*P2Q2/S+
44470 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
44471 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
44472 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)-
44473 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
44474 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
44475 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S+
44476 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
44477 &96*A2*MT**2*P2Q2/(P1Q2*S)+192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
44478 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
44479 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)-
44480 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)-
44481 &96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
44482 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)
44483 V18=V18-576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-
44484 &192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
44485 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
44486 &192*A2**2*P1Q2*P2Q2/S-96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
44487 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44488 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
44489 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
44490 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)+
44491 &96*A1*MB*MT*P2Q2/(P2Q1*S)-48*A2*MB*MT*P2Q2/(P2Q1*S)-
44492 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)+
44493 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
44494 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
44495 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
44496 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
44497 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
44498 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)-
44499 &192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)
44500 V18=V18-96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44501 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
44502 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
44503 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)+
44504 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)
44505
44506 V18BIS=
44507 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44508 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44509 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44510 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
44511 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
44512 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
44513 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
44514 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
44515 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
44516 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
44517 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)-
44518 &96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
44519 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
44520 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)-
44521 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)+192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
44522 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)
44523 V18BIS=V18BIS-384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-
44524 &192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)+
44525 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
44526 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44527 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
44528 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
44529 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
44530 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
44531 &128*A1*MT**2*S/(3*P1Q1**2)-128*A12*MB*MT**3*S/(3*P1Q1**2)-
44532 &152*A1*S/(3*P1Q1)+152*A12*MB*MT*S/(3*P1Q1)+
44533 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
44534 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
44535 &128*A1*MT**2*S/(3*P1Q2**2)-128*A12*MB*MT**3*S/(3*P1Q2**2)-
44536 &152*A1*S/(3*P1Q2)+152*A12*MB*MT*S/(3*P1Q2)+
44537 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
44538 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)-
44539 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)+32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)
44540 V18BIS=V18BIS-16*A1*P1P2*S/(3*P1Q1*P1Q2)+
44541 &272*A1*A2*P1Q1*S/(3*P1Q2)+
44542 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)-
44543 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
44544 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)-
44545 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
44546 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
44547 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
44548 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
44549 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
44550 &112*A1*A2*MB**2*S/(3*P2Q1)-128*A1*A2*MB*MT*S/(3*P2Q1)-
44551 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
44552 &16*A2**2*P1P2*S/P2Q1+8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
44553 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)+
44554 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
44555 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)+
44556 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)
44557 V18BIS=V18BIS+8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
44558 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
44559 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)+
44560 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)+
44561 &128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-12*S/(P1Q2*P2Q1)+
44562 &24*A1*MB**2*S/(P1Q2*P2Q1)-64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
44563 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)-
44564 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
44565 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)-
44566 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
44567 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
44568 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+
44569 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
44570 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
44571 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)-
44572 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
44573 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)
44574 V18BIS=V18BIS+16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-
44575 &32*A12*P2Q1*S/(3*P1Q1)-
44576 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
44577 &128*A2*MB**2*S/(3*P2Q2**2)-128*A2**2*MB**3*MT*S/(3*P2Q2**2)+
44578 &32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+32*MB**2*S/(3*P1Q1*P2Q2**2)-
44579 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
44580 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
44581 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
44582 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
44583 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
44584 &112*A1*A2*MB**2*S/(3*P2Q2)-128*A1*A2*MB*MT*S/(3*P2Q2)-
44585 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
44586 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
44587 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)+
44588 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
44589 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
44590 &24*A1*MB**2*S/(P1Q1*P2Q2)-64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)
44591 V18BIS=V18BIS+24*A2*MT**2*S/(P1Q1*P2Q2)-
44592 &128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)-
44593 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
44594 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)-
44595 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
44596 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
44597 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)+
44598 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
44599 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)+
44600 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
44601 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)+
44602 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
44603 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
44604 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
44605 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
44606 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
44607 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)
44608 V18BIS=V18BIS+136*A2*P1Q2*S/(3*P1Q1*P2Q2)-
44609 &128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)-
44610 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
44611 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)-16*A2*MB*MT*S/(3*P2Q1*P2Q2)+
44612 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)-
44613 &4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-
44614 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44615 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
44616 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
44617 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44618 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44619 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44620 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44621 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44622 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44623 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
44624 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)
44625 V18BIS=V18BIS+8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+
44626 &272*A1*A2*P2Q1*S/(3*P2Q2)-
44627 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)+
44628 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
44629 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)+
44630 &256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
44631 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
44632 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
44633 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
44634 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
44635 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
44636 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
44637 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)+
44638 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
44639 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
44640 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
44641 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)
44642 V18BIS=V18BIS+256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)+
44643 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
44644 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
44645 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)+
44646 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)-
44647 &4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
44648 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
44649 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44650C
44651
44652 A18 = 640*A1/3+640*A2/3+32*A1*A2*MB**2+368*A12*MB*MT+
44653 &512*A1*A2*MB*MT/3+
44654 &368*A2**2*MB*MT+32*A1*A2*MT**2+496*A12*P1P2/3+
44655 &320*A1*A2*P1P2+496*A2**2*P1P2/3-128*A1*MB*MT**3/(3*P1Q1**2)+
44656 &128*A1*MT**4/(3*P1Q1**2)+256*A12*MB*MT**5/(3*P1Q1**2)+
44657 &256*A1*MT**2*P1P2/(3*P1Q1**2)-256*A12*MT**4*P1P2/(3*P1Q1**2)+
44658 &8/(3*P1Q1)+32*A1*MB*MT/P1Q1+56*A2*MB*MT/(3*P1Q1)+
44659 &88*A1*MT**2/(3*P1Q1)+72*A2*MT**2/P1Q1-
44660 &704*A12*MB*MT**3/(3*P1Q1)+224*A1*A2*MB*MT**3/(3*P1Q1)+
44661 &104*A1*P1P2/(3*P1Q1)+48*A2*P1P2/P1Q1-
44662 &128*A1*A2*MB*MT*P1P2/(3*P1Q1)+512*A12*MT**2*P1P2/(3*P1Q1)-
44663 &448*A1*A2*MT**2*P1P2/(3*P1Q1)-32*A1*A2*P1P2**2/P1Q1-
44664 &656*A1*A2*P1Q1/3-224*A2**2*P1Q1-128*A1*MB*MT**3/(3*P1Q2**2)+
44665 &128*A1*MT**4/(3*P1Q2**2)+256*A12*MB*MT**5/(3*P1Q2**2)+
44666 &256*A1*MT**2*P1P2/(3*P1Q2**2)-256*A12*MT**4*P1P2/(3*P1Q2**2)+
44667 &256*A1*MT**2*P1Q1/(3*P1Q2**2)-256*A12*MB*MT**3*P1Q1/(3*P1Q2**2)+
44668 &8/(3*P1Q2)+32*A1*MB*MT/P1Q2+56*A2*MB*MT/(3*P1Q2)
44669 A18=A18+88*A1*MT**2/(3*P1Q2)+72*A2*MT**2/P1Q2-
44670 &704*A12*MB*MT**3/(3*P1Q2)+224*A1*A2*MB*MT**3/(3*P1Q2)+
44671 &104*A1*P1P2/(3*P1Q2)+48*A2*P1P2/P1Q2-
44672 &128*A1*A2*MB*MT*P1P2/(3*P1Q2)+512*A12*MT**2*P1P2/(3*P1Q2)-
44673 &448*A1*A2*MT**2*P1P2/(3*P1Q2)-32*A1*A2*P1P2**2/P1Q2+
44674 &32*A1*MB*MT**3/(3*P1Q1*P1Q2)-32*A1*MT**4/(3*P1Q1*P1Q2)-
44675 &64*A12*MB*MT**5/(3*P1Q1*P1Q2)+16*P1P2/(3*P1Q1*P1Q2)-
44676 &64*A1*MT**2*P1P2/(3*P1Q1*P1Q2)+64*A12*MT**4*P1P2/(3*P1Q1*P1Q2)+
44677 &112*A1*P1Q1/P1Q2+272*A2*P1Q1/(3*P1Q2)-
44678 &272*A1*A2*MB**2*P1Q1/(3*P1Q2)-208*A12*MB*MT*P1Q1/(3*P1Q2)+
44679 &400*A1*A2*MB*MT*P1Q1/(3*P1Q2)-80*A1*A2*MT**2*P1Q1/P1Q2+
44680 &96*A12*P1P2*P1Q1/P1Q2-320*A1*A2*P1P2*P1Q1/P1Q2-
44681 &544*A1*A2*P1Q1**2/(3*P1Q2)-656*A1*A2*P1Q2/3-224*A2**2*P1Q2+
44682 &256*A1*MT**2*P1Q2/(3*P1Q1**2)-256*A12*MB*MT**3*P1Q2/(3*P1Q1**2)+
44683 &112*A1*P1Q2/P1Q1+272*A2*P1Q2/(3*P1Q1)-
44684 &272*A1*A2*MB**2*P1Q2/(3*P1Q1)-208*A12*MB*MT*P1Q2/(3*P1Q1)+
44685 &400*A1*A2*MB*MT*P1Q2/(3*P1Q1)-80*A1*A2*MT**2*P1Q2/P1Q1
44686 A18=A18+96*A12*P1P2*P1Q2/P1Q1-320*A1*A2*P1P2*P1Q2/P1Q1-
44687 &544*A1*A2*P1Q2**2/(3*P1Q1)+128*A2*MB**4/(3*P2Q1**2)-
44688 &128*A2*MB**3*MT/(3*P2Q1**2)+256*A2**2*MB**5*MT/(3*P2Q1**2)+
44689 &256*A2*MB**2*P1P2/(3*P2Q1**2)-256*A2**2*MB**4*P1P2/(3*P2Q1**2)+
44690 &256*A2*MB**2*P1Q1/(3*P2Q1**2)-256*A2**2*MB**4*P1Q1/(3*P2Q1**2)+
44691 &64*MB**3*MT**3/(3*P1Q2**2*P2Q1**2)-
44692 &64*MB**2*MT**2*P1P2/(3*P1Q2**2*P2Q1**2)-
44693 &64*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1**2)-
44694 &64*MB**3*MT/(3*P1Q2*P2Q1**2)-
44695 &256*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1**2)+
44696 &256*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1**2)-
44697 &256*A2*MB**3*MT*P1Q1/(3*P1Q2*P2Q1**2)+
44698 &512*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1**2)+
44699 &256*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1**2)-
44700 &256*A2**2*MB**4*P1Q2/(3*P2Q1**2)-8/(3*P2Q1)-72*A1*MB**2/P2Q1-
44701 &88*A2*MB**2/(3*P2Q1)-56*A1*MB*MT/(3*P2Q1)-32*A2*MB*MT/P2Q1-
44702 &224*A1*A2*MB**3*MT/(3*P2Q1)+704*A2**2*MB**3*MT/(3*P2Q1)
44703 A18=A18-48*A1*P1P2/P2Q1-104*A2*P1P2/(3*P2Q1)+
44704 &448*A1*A2*MB**2*P1P2/(3*P2Q1)-512*A2**2*MB**2*P1P2/(3*P2Q1)+
44705 &128*A1*A2*MB*MT*P1P2/(3*P2Q1)+32*A1*A2*P1P2**2/P2Q1-
44706 &16*P1P2/(3*P1Q1*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q1)+
44707 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q1)+
44708 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q1)-
44709 &64*A1*A2*P1P2**3/(3*P1Q1*P2Q1)-256*A2*P1Q1/(3*P2Q1)+
44710 &448*A1*A2*MB**2*P1Q1/(3*P2Q1)-368*A2**2*MB**2*P1Q1/(3*P2Q1)-
44711 &224*A1*A2*MB*MT*P1Q1/(3*P2Q1)+304*A1*A2*P1P2*P1Q1/(3*P2Q1)+
44712 &64*MB*MT**3/(3*P1Q2**2*P2Q1)+
44713 &256*A1*MB*MT**3*P1P2/(3*P1Q2**2*P2Q1)-
44714 &256*A1*MT**2*P1P2**2/(3*P1Q2**2*P2Q1)+
44715 &64*MT**2*P1Q1/(3*P1Q2**2*P2Q1)-
44716 &128*A1*MB**2*MT**2*P1Q1/(3*P1Q2**2*P2Q1)+
44717 &128*A1*MB*MT**3*P1Q1/(3*P1Q2**2*P2Q1)-
44718 &256*A1*MT**2*P1P2*P1Q1/(3*P1Q2**2*P2Q1)-4*MB**2/(3*P1Q2*P2Q1)-
44719 &64*MB*MT/(3*P1Q2*P2Q1)+128*A2*MB**3*MT/(3*P1Q2*P2Q1)
44720 A18=A18-4*MT**2/(3*P1Q2*P2Q1)-128*A1*MB**2*MT**2/(3*P1Q2*P2Q1)-
44721 &128*A2*MB**2*MT**2/(3*P1Q2*P2Q1)+128*A1*MB*MT**3/(3*P1Q2*P2Q1)-
44722 &112*A2*MB**2*P1P2/(3*P1Q2*P2Q1)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q1)+
44723 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q1)-112*A1*MT**2*P1P2/(3*P1Q2*P2Q1)-
44724 &48*A1*P1P2**2/(P1Q2*P2Q1)-48*A2*P1P2**2/(P1Q2*P2Q1)-
44725 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q1)+
44726 &512*A1*A2*P1P2**3/(3*P1Q2*P2Q1)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44727 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44728 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q1)-
44729 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+
44730 &32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q1)+8*P1Q1/(3*P1Q2*P2Q1)-
44731 &160*A1*MB**2*P1Q1/(3*P1Q2*P2Q1)-272*A2*MB**2*P1Q1/(3*P1Q2*P2Q1)-
44732 &56*A1*MB*MT*P1Q1/(3*P1Q2*P2Q1)-200*A2*MB*MT*P1Q1/(3*P1Q2*P2Q1)-
44733 &48*A1*P1P2*P1Q1/(P1Q2*P2Q1)-256*A2*P1P2*P1Q1/(3*P1Q2*P2Q1)+
44734 &256*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1)-
44735 &256*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1)+
44736 &1024*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q1)
44737 A18=A18-272*A2*P1Q1**2/(3*P1Q2*P2Q1)+
44738 &256*A1*A2*MB**2*P1Q1**2/(3*P1Q2*P2Q1)-
44739 &256*A1*A2*MB*MT*P1Q1**2/(3*P1Q2*P2Q1)+
44740 &512*A1*A2*P1P2*P1Q1**2/(3*P1Q2*P2Q1)+16*A2*P1Q2/(3*P2Q1)+
44741 &64*A1*A2*MB**2*P1Q2/P2Q1+32*A2**2*MB**2*P1Q2/(3*P2Q1)-
44742 &112*A1*A2*MB*MT*P1Q2/(3*P2Q1)+368*A1*A2*P1P2*P1Q2/(3*P2Q1)+
44743 &32*A2*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44744 &32*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1)+
44745 &32*A1*A2*MB*MT*P1P2*P1Q2/(3*P1Q1*P2Q1)-
44746 &64*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q1)+224*A12*P2Q1+
44747 &656*A1*A2*P2Q1/3-256*A1*MT**2*P2Q1/(3*P1Q1**2)+
44748 &256*A12*MT**4*P2Q1/(3*P1Q1**2)-256*A1*P2Q1/(3*P1Q1)-
44749 &224*A1*A2*MB*MT*P2Q1/(3*P1Q1)-368*A12*MT**2*P2Q1/(3*P1Q1)+
44750 &448*A1*A2*MT**2*P2Q1/(3*P1Q1)+304*A1*A2*P1P2*P2Q1/(3*P1Q1)+
44751 &256*A12*MT**4*P2Q1/(3*P1Q2**2)+
44752 &256*A12*MT**2*P1Q1*P2Q1/(3*P1Q2**2)+16*A1*P2Q1/(3*P1Q2)-
44753 &112*A1*A2*MB*MT*P2Q1/(3*P1Q2)+32*A12*MT**2*P2Q1/(3*P1Q2)
44754 A18=A18+64*A1*A2*MT**2*P2Q1/P1Q2+368*A1*A2*P1P2*P2Q1/(3*P1Q2)+
44755 &16*A1*MT**2*P2Q1/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q1/(3*P1Q1*P1Q2)+
44756 &640*A12*P1Q1*P2Q1/(3*P1Q2)+544*A1*A2*P1Q1*P2Q1/(3*P1Q2)+
44757 &32*A12*P1Q2*P2Q1/P1Q1+944*A1*A2*P1Q2*P2Q1/(3*P1Q1)+
44758 &128*A2*MB**4/(3*P2Q2**2)-128*A2*MB**3*MT/(3*P2Q2**2)+
44759 &256*A2**2*MB**5*MT/(3*P2Q2**2)+256*A2*MB**2*P1P2/(3*P2Q2**2)-
44760 &256*A2**2*MB**4*P1P2/(3*P2Q2**2)+
44761 &64*MB**3*MT**3/(3*P1Q1**2*P2Q2**2)-
44762 &64*MB**2*MT**2*P1P2/(3*P1Q1**2*P2Q2**2)-
44763 &64*MB**3*MT/(3*P1Q1*P2Q2**2)-
44764 &256*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q2**2)+
44765 &256*A2*MB**2*P1P2**2/(3*P1Q1*P2Q2**2)-
44766 &256*A2**2*MB**4*P1Q1/(3*P2Q2**2)+256*A2*MB**2*P1Q2/(3*P2Q2**2)-
44767 &256*A2**2*MB**4*P1Q2/(3*P2Q2**2)-
44768 &64*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2**2)-
44769 &256*A2*MB**3*MT*P1Q2/(3*P1Q1*P2Q2**2)+
44770 &512*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2**2)
44771 A18=A18+256*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2**2)-
44772 &256*A2*MB**2*P2Q1/(3*P2Q2**2)+256*A2**2*MB**3*MT*P2Q1/(3*P2Q2**2)+
44773 &64*MB**2*MT**2*P2Q1/(3*P1Q1**2*P2Q2**2)+
44774 &64*MB**2*P2Q1/(3*P1Q1*P2Q2**2)+
44775 &128*A2*MB**3*MT*P2Q1/(3*P1Q1*P2Q2**2)-
44776 &128*A2*MB**2*MT**2*P2Q1/(3*P1Q1*P2Q2**2)-
44777 &256*A2*MB**2*P1P2*P2Q1/(3*P1Q1*P2Q2**2)+
44778 &256*A2**2*MB**2*P1Q1*P2Q1/(3*P2Q2**2)-
44779 &256*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2**2)-8/(3*P2Q2)-
44780 &72*A1*MB**2/P2Q2-88*A2*MB**2/(3*P2Q2)-56*A1*MB*MT/(3*P2Q2)-
44781 &32*A2*MB*MT/P2Q2-224*A1*A2*MB**3*MT/(3*P2Q2)+
44782 &704*A2**2*MB**3*MT/(3*P2Q2)-48*A1*P1P2/P2Q2-
44783 &104*A2*P1P2/(3*P2Q2)+448*A1*A2*MB**2*P1P2/(3*P2Q2)-
44784 &512*A2**2*MB**2*P1P2/(3*P2Q2)+128*A1*A2*MB*MT*P1P2/(3*P2Q2)+
44785 &32*A1*A2*P1P2**2/P2Q2+64*MB*MT**3/(3*P1Q1**2*P2Q2)+
44786 &256*A1*MB*MT**3*P1P2/(3*P1Q1**2*P2Q2)-
44787 &256*A1*MT**2*P1P2**2/(3*P1Q1**2*P2Q2)-4*MB**2/(3*P1Q1*P2Q2)
44788 A18=A18-64*MB*MT/(3*P1Q1*P2Q2)+128*A2*MB**3*MT/(3*P1Q1*P2Q2)-
44789 &4*MT**2/(3*P1Q1*P2Q2)-128*A1*MB**2*MT**2/(3*P1Q1*P2Q2)-
44790 &128*A2*MB**2*MT**2/(3*P1Q1*P2Q2)+128*A1*MB*MT**3/(3*P1Q1*P2Q2)-
44791 &112*A2*MB**2*P1P2/(3*P1Q1*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q1*P2Q2)+
44792 &32*A2*MB*MT*P1P2/(3*P1Q1*P2Q2)-112*A1*MT**2*P1P2/(3*P1Q1*P2Q2)-
44793 &48*A1*P1P2**2/(P1Q1*P2Q2)-48*A2*P1P2**2/(P1Q1*P2Q2)-
44794 &512*A1*A2*MB*MT*P1P2**2/(3*P1Q1*P2Q2)+
44795 &512*A1*A2*P1P2**3/(3*P1Q1*P2Q2)+16*A2*P1Q1/(3*P2Q2)+
44796 &64*A1*A2*MB**2*P1Q1/P2Q2+32*A2**2*MB**2*P1Q1/(3*P2Q2)-
44797 &112*A1*A2*MB*MT*P1Q1/(3*P2Q2)+368*A1*A2*P1P2*P1Q1/(3*P2Q2)-
44798 &16*P1P2/(3*P1Q2*P2Q2)+32*A1*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44799 &32*A2*MB*MT*P1P2/(3*P1Q2*P2Q2)+
44800 &64*A1*A2*MB*MT*P1P2**2/(3*P1Q2*P2Q2)-
44801 &64*A1*A2*P1P2**3/(3*P1Q2*P2Q2)+8*MB*MT*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44802 &8*MT**2*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44803 &32*A1*MB*MT**3*P1P2/(3*P1Q1*P1Q2*P2Q2)-
44804 &16*P1P2**2/(3*P1Q1*P1Q2*P2Q2)
44805 A18=A18+32*A1*MT**2*P1P2**2/(3*P1Q1*P1Q2*P2Q2)+
44806 &32*A2*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44807 &32*A1*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q2)+
44808 &32*A1*A2*MB*MT*P1P2*P1Q1/(3*P1Q2*P2Q2)-
44809 &64*A1*A2*P1P2**2*P1Q1/(3*P1Q2*P2Q2)-256*A2*P1Q2/(3*P2Q2)+
44810 &448*A1*A2*MB**2*P1Q2/(3*P2Q2)-368*A2**2*MB**2*P1Q2/(3*P2Q2)-
44811 &224*A1*A2*MB*MT*P1Q2/(3*P2Q2)+304*A1*A2*P1P2*P1Q2/(3*P2Q2)+
44812 &64*MT**2*P1Q2/(3*P1Q1**2*P2Q2)-
44813 &128*A1*MB**2*MT**2*P1Q2/(3*P1Q1**2*P2Q2)+
44814 &128*A1*MB*MT**3*P1Q2/(3*P1Q1**2*P2Q2)-
44815 &256*A1*MT**2*P1P2*P1Q2/(3*P1Q1**2*P2Q2)+8*P1Q2/(3*P1Q1*P2Q2)-
44816 &160*A1*MB**2*P1Q2/(3*P1Q1*P2Q2)-272*A2*MB**2*P1Q2/(3*P1Q1*P2Q2)-
44817 &56*A1*MB*MT*P1Q2/(3*P1Q1*P2Q2)-200*A2*MB*MT*P1Q2/(3*P1Q1*P2Q2)-
44818 &48*A1*P1P2*P1Q2/(P1Q1*P2Q2)-256*A2*P1P2*P1Q2/(3*P1Q1*P2Q2)+
44819 &256*A1*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q2)-
44820 &256*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2)+
44821 &1024*A1*A2*P1P2**2*P1Q2/(3*P1Q1*P2Q2)
44822 A18=A18-272*A2*P1Q2**2/(3*P1Q1*P2Q2)+
44823 &256*A1*A2*MB**2*P1Q2**2/(3*P1Q1*P2Q2)-
44824 &256*A1*A2*MB*MT*P1Q2**2/(3*P1Q1*P2Q2)+
44825 &512*A1*A2*P1P2*P1Q2**2/(3*P1Q1*P2Q2)-32*A2*MB**4/(3*P2Q1*P2Q2)+
44826 &32*A2*MB**3*MT/(3*P2Q1*P2Q2)-64*A2**2*MB**5*MT/(3*P2Q1*P2Q2)+
44827 &16*P1P2/(3*P2Q1*P2Q2)-64*A2*MB**2*P1P2/(3*P2Q1*P2Q2)+
44828 &64*A2**2*MB**4*P1P2/(3*P2Q1*P2Q2)+8*MB**2*P1P2/(3*P1Q1*P2Q1*P2Q2)-
44829 &8*MB*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44830 &32*A2*MB**3*MT*P1P2/(3*P1Q1*P2Q1*P2Q2)+
44831 &16*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44832 &32*A2*MB**2*P1P2**2/(3*P1Q1*P2Q1*P2Q2)-
44833 &16*A2*MB**2*P1Q1/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q1/(3*P2Q1*P2Q2)+
44834 &8*MB**2*P1P2/(3*P1Q2*P2Q1*P2Q2)-8*MB*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44835 &32*A2*MB**3*MT*P1P2/(3*P1Q2*P2Q1*P2Q2)+
44836 &16*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44837 &32*A2*MB**2*P1P2**2/(3*P1Q2*P2Q1*P2Q2)-
44838 &16*MB*MT*P1P2**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
44839 A18=A18+16*P1P2**3/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
44840 &32*A2*MB**2*P1P2*P1Q1/(3*P1Q2*P2Q1*P2Q2)-
44841 &16*A2*MB**2*P1Q2/(3*P2Q1*P2Q2)+64*A2**2*MB**4*P1Q2/(3*P2Q1*P2Q2)-
44842 &32*A2*MB**2*P1P2*P1Q2/(3*P1Q1*P2Q1*P2Q2)+272*A1*P2Q1/(3*P2Q2)+
44843 &112*A2*P2Q1/P2Q2-80*A1*A2*MB**2*P2Q1/P2Q2+
44844 &400*A1*A2*MB*MT*P2Q1/(3*P2Q2)-208*A2**2*MB*MT*P2Q1/(3*P2Q2)-
44845 &272*A1*A2*MT**2*P2Q1/(3*P2Q2)-320*A1*A2*P1P2*P2Q1/P2Q2+
44846 &96*A2**2*P1P2*P2Q1/P2Q2-256*A1*MB*MT**3*P2Q1/(3*P1Q1**2*P2Q2)+
44847 &512*A1*MT**2*P1P2*P2Q1/(3*P1Q1**2*P2Q2)-8*P2Q1/(3*P1Q1*P2Q2)+
44848 &200*A1*MB*MT*P2Q1/(3*P1Q1*P2Q2)+56*A2*MB*MT*P2Q1/(3*P1Q1*P2Q2)+
44849 &272*A1*MT**2*P2Q1/(3*P1Q1*P2Q2)+160*A2*MT**2*P2Q1/(3*P1Q1*P2Q2)+
44850 &256*A1*P1P2*P2Q1/(3*P1Q1*P2Q2)+48*A2*P1P2*P2Q1/(P1Q1*P2Q2)+
44851 &256*A1*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2)-
44852 &256*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q1*P2Q2)-
44853 &1024*A1*A2*P1P2**2*P2Q1/(3*P1Q1*P2Q2)-
44854 &544*A1*A2*P1Q1*P2Q1/(3*P2Q2)-640*A2**2*P1Q1*P2Q1/(3*P2Q2)-
44855 &32*A1*P1P2*P2Q1/(3*P1Q2*P2Q2)
44856 A18=A18-32*A1*A2*MB*MT*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44857 &32*A1*A2*MT**2*P1P2*P2Q1/(3*P1Q2*P2Q2)+
44858 &64*A1*A2*P1P2**2*P2Q1/(3*P1Q2*P2Q2)-
44859 &32*A1*MT**2*P1P2*P2Q1/(3*P1Q1*P1Q2*P2Q2)+
44860 &64*A1*A2*P1P2*P1Q1*P2Q1/(3*P1Q2*P2Q2)-
44861 &944*A1*A2*P1Q2*P2Q1/(3*P2Q2)-32*A2**2*P1Q2*P2Q1/P2Q2+
44862 &256*A1*MT**2*P1Q2*P2Q1/(3*P1Q1**2*P2Q2)+
44863 &96*A1*P1Q2*P2Q1/(P1Q1*P2Q2)+96*A2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44864 &128*A1*A2*MB**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)+
44865 &256*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2)-
44866 &128*A1*A2*MT**2*P1Q2*P2Q1/(3*P1Q1*P2Q2)-
44867 &512*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2)-
44868 &512*A1*A2*P1Q2**2*P2Q1/(3*P1Q1*P2Q2)+544*A1*A2*P2Q1**2/(3*P2Q2)-
44869 &256*A1*MT**2*P2Q1**2/(3*P1Q1**2*P2Q2)-
44870 &272*A1*P2Q1**2/(3*P1Q1*P2Q2)-
44871 &256*A1*A2*MB*MT*P2Q1**2/(3*P1Q1*P2Q2)+
44872 &256*A1*A2*MT**2*P2Q1**2/(3*P1Q1*P2Q2)
44873 A18=A18+512*A1*A2*P1P2*P2Q1**2/(3*P1Q1*P2Q2)+
44874 &512*A1*A2*P1Q2*P2Q1**2/(3*P1Q1*P2Q2)+224*A12*P2Q2+
44875 &656*A1*A2*P2Q2/3+256*A12*MT**4*P2Q2/(3*P1Q1**2)+
44876 &16*A1*P2Q2/(3*P1Q1)-112*A1*A2*MB*MT*P2Q2/(3*P1Q1)+
44877 &32*A12*MT**2*P2Q2/(3*P1Q1)+64*A1*A2*MT**2*P2Q2/P1Q1+
44878 &368*A1*A2*P1P2*P2Q2/(3*P1Q1)-256*A1*MT**2*P2Q2/(3*P1Q2**2)+
44879 &256*A12*MT**4*P2Q2/(3*P1Q2**2)-256*A1*P2Q2/(3*P1Q2)-
44880 &224*A1*A2*MB*MT*P2Q2/(3*P1Q2)-368*A12*MT**2*P2Q2/(3*P1Q2)+
44881 &448*A1*A2*MT**2*P2Q2/(3*P1Q2)+304*A1*A2*P1P2*P2Q2/(3*P1Q2)+
44882 &16*A1*MT**2*P2Q2/(3*P1Q1*P1Q2)-64*A12*MT**4*P2Q2/(3*P1Q1*P1Q2)+
44883 &32*A12*P1Q1*P2Q2/P1Q2+944*A1*A2*P1Q1*P2Q2/(3*P1Q2)+
44884 &256*A12*MT**2*P1Q2*P2Q2/(3*P1Q1**2)+
44885 &640*A12*P1Q2*P2Q2/(3*P1Q1)+544*A1*A2*P1Q2*P2Q2/(3*P1Q1)-
44886 &256*A2*MB**2*P2Q2/(3*P2Q1**2)+256*A2**2*MB**3*MT*P2Q2/(3*P2Q1**2)+
44887 &64*MB**2*MT**2*P2Q2/(3*P1Q2**2*P2Q1**2)+
44888 &64*MB**2*P2Q2/(3*P1Q2*P2Q1**2)+
44889 &128*A2*MB**3*MT*P2Q2/(3*P1Q2*P2Q1**2)
44890 A18=A18-128*A2*MB**2*MT**2*P2Q2/(3*P1Q2*P2Q1**2)-
44891 &256*A2*MB**2*P1P2*P2Q2/(3*P1Q2*P2Q1**2)-
44892 &256*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1**2)+
44893 &256*A2**2*MB**2*P1Q2*P2Q2/(3*P2Q1**2)+272*A1*P2Q2/(3*P2Q1)+
44894 &112*A2*P2Q2/P2Q1-80*A1*A2*MB**2*P2Q2/P2Q1+
44895 &400*A1*A2*MB*MT*P2Q2/(3*P2Q1)-208*A2**2*MB*MT*P2Q2/(3*P2Q1)-
44896 &272*A1*A2*MT**2*P2Q2/(3*P2Q1)-320*A1*A2*P1P2*P2Q2/P2Q1+
44897 &96*A2**2*P1P2*P2Q2/P2Q1-32*A1*P1P2*P2Q2/(3*P1Q1*P2Q1)-
44898 &32*A1*A2*MB*MT*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44899 &32*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q1*P2Q1)+
44900 &64*A1*A2*P1P2**2*P2Q2/(3*P1Q1*P2Q1)-944*A1*A2*P1Q1*P2Q2/(3*P2Q1)-
44901 &32*A2**2*P1Q1*P2Q2/P2Q1-256*A1*MB*MT**3*P2Q2/(3*P1Q2**2*P2Q1)+
44902 &512*A1*MT**2*P1P2*P2Q2/(3*P1Q2**2*P2Q1)+
44903 &256*A1*MT**2*P1Q1*P2Q2/(3*P1Q2**2*P2Q1)-8*P2Q2/(3*P1Q2*P2Q1)+
44904 &200*A1*MB*MT*P2Q2/(3*P1Q2*P2Q1)+56*A2*MB*MT*P2Q2/(3*P1Q2*P2Q1)+
44905 &272*A1*MT**2*P2Q2/(3*P1Q2*P2Q1)+160*A2*MT**2*P2Q2/(3*P1Q2*P2Q1)+
44906 &256*A1*P1P2*P2Q2/(3*P1Q2*P2Q1)+48*A2*P1P2*P2Q2/(P1Q2*P2Q1)
44907 A18=A18+256*A1*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1)-
44908 &256*A1*A2*MT**2*P1P2*P2Q2/(3*P1Q2*P2Q1)-
44909 &1024*A1*A2*P1P2**2*P2Q2/(3*P1Q2*P2Q1)-
44910 &32*A1*MT**2*P1P2*P2Q2/(3*P1Q1*P1Q2*P2Q1)+
44911 &96*A1*P1Q1*P2Q2/(P1Q2*P2Q1)+96*A2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44912 &128*A1*A2*MB**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)+
44913 &256*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1)-
44914 &128*A1*A2*MT**2*P1Q1*P2Q2/(3*P1Q2*P2Q1)-
44915 &512*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1)-
44916 &512*A1*A2*P1Q1**2*P2Q2/(3*P1Q2*P2Q1)-544*A1*A2*P1Q2*P2Q2/(3*P2Q1)-
44917 &640*A2**2*P1Q2*P2Q2/(3*P2Q1)+
44918 &64*A1*A2*P1P2*P1Q2*P2Q2/(3*P1Q1*P2Q1)+544*A1*A2*P2Q2**2/(3*P2Q1)-
44919 &256*A1*MT**2*P2Q2**2/(3*P1Q2**2*P2Q1)-
44920 &272*A1*P2Q2**2/(3*P1Q2*P2Q1)-
44921 &256*A1*A2*MB*MT*P2Q2**2/(3*P1Q2*P2Q1)+
44922 &256*A1*A2*MT**2*P2Q2**2/(3*P1Q2*P2Q1)+
44923 &512*A1*A2*P1P2*P2Q2**2/(3*P1Q2*P2Q1)
44924 A18=A18+512*A1*A2*P1Q1*P2Q2**2/(3*P1Q2*P2Q1)-
44925 &384*A12*MB*MT*P1Q1**2/S**2+
44926 &384*A12*P1P2*P1Q1**2/S**2-2688*A12*MB*MT*P1Q1*P1Q2/S**2+
44927 &2688*A12*P1P2*P1Q1*P1Q2/S**2-384*A12*MB*MT*P1Q2**2/S**2+
44928 &384*A12*P1P2*P1Q2**2/S**2-768*A1*A2*MB*MT*P1Q1*P2Q1/S**2+
44929 &768*A1*A2*P1P2*P1Q1*P2Q1/S**2-2688*A1*A2*MB*MT*P1Q2*P2Q1/S**2+
44930 &2688*A1*A2*P1P2*P1Q2*P2Q1/S**2-960*A12*P1Q1*P1Q2*P2Q1/S**2-
44931 &960*A1*A2*P1Q1*P1Q2*P2Q1/S**2+960*A12*P1Q2**2*P2Q1/S**2+
44932 &960*A1*A2*P1Q2**2*P2Q1/S**2-384*A2**2*MB*MT*P2Q1**2/S**2+
44933 &384*A2**2*P1P2*P2Q1**2/S**2-960*A1*A2*P1Q2*P2Q1**2/S**2-
44934 &960*A2**2*P1Q2*P2Q1**2/S**2-2688*A1*A2*MB*MT*P1Q1*P2Q2/S**2+
44935 &2688*A1*A2*P1P2*P1Q1*P2Q2/S**2+960*A12*P1Q1**2*P2Q2/S**2+
44936 &960*A1*A2*P1Q1**2*P2Q2/S**2-768*A1*A2*MB*MT*P1Q2*P2Q2/S**2+
44937 &768*A1*A2*P1P2*P1Q2*P2Q2/S**2-960*A12*P1Q1*P1Q2*P2Q2/S**2-
44938 &960*A1*A2*P1Q1*P1Q2*P2Q2/S**2-2688*A2**2*MB*MT*P2Q1*P2Q2/S**2+
44939 &2688*A2**2*P1P2*P2Q1*P2Q2/S**2+960*A1*A2*P1Q1*P2Q1*P2Q2/S**2+
44940 &960*A2**2*P1Q1*P2Q1*P2Q2/S**2+960*A1*A2*P1Q2*P2Q1*P2Q2/S**2
44941 A18=A18+960*A2**2*P1Q2*P2Q1*P2Q2/S**2-
44942 &384*A2**2*MB*MT*P2Q2**2/S**2+
44943 &384*A2**2*P1P2*P2Q2**2/S**2-960*A1*A2*P1Q1*P2Q2**2/S**2-
44944 &960*A2**2*P1Q1*P2Q2**2/S**2-96*A1*MB*MT/S-96*A2*MB*MT/S+
44945 &768*A2**2*MB**3*MT/S+768*A12*MB*MT**3/S-192*A1*P1P2/S-
44946 &192*A2*P1P2/S-768*A2**2*MB**2*P1P2/S+2304*A1*A2*MB*MT*P1P2/S-
44947 &768*A12*MT**2*P1P2/S-2304*A1*A2*P1P2**2/S+
44948 &96*A1*MB*MT**3/(P1Q1*S)+192*A2*MB*MT*P1P2/(P1Q1*S)-
44949 &96*A1*MT**2*P1P2/(P1Q1*S)-192*A2*P1P2**2/(P1Q1*S)-192*A1*P1Q1/S-
44950 &144*A2*P1Q1/S-384*A1*A2*MB**2*P1Q1/S-480*A2**2*MB**2*P1Q1/S+
44951 &480*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S-
44952 &864*A12*P1P2*P1Q1/S-672*A1*A2*P1P2*P1Q1/S-96*A1*A2*P1Q1**2/S+
44953 &96*A1*MB*MT**3/(P1Q2*S)+192*A2*MB*MT*P1P2/(P1Q2*S)-
44954 &96*A1*MT**2*P1P2/(P1Q2*S)-192*A2*P1P2**2/(P1Q2*S)+
44955 &48*A1*MB*MT*P1Q1/(P1Q2*S)-96*A2*MB*MT*P1Q1/(P1Q2*S)-
44956 &48*A1*MT**2*P1Q1/(P1Q2*S)-192*A1*P1P2*P1Q1/(P1Q2*S)-
44957 &192*A2*P1P2*P1Q1/(P1Q2*S)-192*A1*A2*MB*MT*P1P2*P1Q1/(P1Q2*S)
44958 A18=A18+192*A1*A2*P1P2**2*P1Q1/(P1Q2*S)-192*A1*P1Q1**2/(P1Q2*S)-
44959 &192*A2*P1Q1**2/(P1Q2*S)+192*A1*A2*MB**2*P1Q1**2/(P1Q2*S)+
44960 &192*A12*MB*MT*P1Q1**2/(P1Q2*S)-96*A1*A2*MB*MT*P1Q1**2/(P1Q2*S)+
44961 &192*A1*A2*P1P2*P1Q1**2/(P1Q2*S)-192*A1*P1Q2/S-144*A2*P1Q2/S-
44962 &384*A1*A2*MB**2*P1Q2/S-480*A2**2*MB**2*P1Q2/S+
44963 &480*A12*MB*MT*P1Q2/S-96*A1*A2*MB*MT*P1Q2/S-
44964 &864*A12*P1P2*P1Q2/S-672*A1*A2*P1P2*P1Q2/S+
44965 &48*A1*MB*MT*P1Q2/(P1Q1*S)-96*A2*MB*MT*P1Q2/(P1Q1*S)-
44966 &48*A1*MT**2*P1Q2/(P1Q1*S)-192*A1*P1P2*P1Q2/(P1Q1*S)-
44967 &192*A2*P1P2*P1Q2/(P1Q1*S)-192*A1*A2*MB*MT*P1P2*P1Q2/(P1Q1*S)+
44968 &192*A1*A2*P1P2**2*P1Q2/(P1Q1*S)-576*A1*A2*P1Q1*P1Q2/S-
44969 &96*A1*A2*P1Q2**2/S-192*A1*P1Q2**2/(P1Q1*S)-
44970 &192*A2*P1Q2**2/(P1Q1*S)+192*A1*A2*MB**2*P1Q2**2/(P1Q1*S)+
44971 &192*A12*MB*MT*P1Q2**2/(P1Q1*S)-96*A1*A2*MB*MT*P1Q2**2/(P1Q1*S)+
44972 &192*A1*A2*P1P2*P1Q2**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q1*S)+
44973 &96*A2*MB**2*P1P2/(P2Q1*S)-192*A1*MB*MT*P1P2/(P2Q1*S)+
44974 &192*A1*P1P2**2/(P2Q1*S)+96*A1*MB**2*P1Q1/(P2Q1*S)
44975 A18=A18+192*A2*MB**2*P1Q1/(P2Q1*S)-96*A1*MB*MT*P1Q1/(P2Q1*S)-
44976 &192*A1*A2*MB**3*MT*P1Q1/(P2Q1*S)+192*A1*P1P2*P1Q1/(P2Q1*S)+
44977 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q1*S)+
44978 &96*A1*A2*MB**2*P1Q1**2/(P2Q1*S)-
44979 &192*A2*MB**3*MT*P1Q1/(P1Q2*P2Q1*S)+
44980 &192*A2*MB**2*P1P2*P1Q1/(P1Q2*P2Q1*S)-
44981 &96*A1*MB*MT*P1P2*P1Q1/(P1Q2*P2Q1*S)+
44982 &96*A1*P1P2**2*P1Q1/(P1Q2*P2Q1*S)+
44983 &96*A1*MB**2*P1Q1**2/(P1Q2*P2Q1*S)+
44984 &192*A2*MB**2*P1Q1**2/(P1Q2*P2Q1*S)-
44985 &48*A1*MB*MT*P1Q1**2/(P1Q2*P2Q1*S)+
44986 &96*A1*P1P2*P1Q1**2/(P1Q2*P2Q1*S)+96*A1*MB**2*P1Q2/(P2Q1*S)+
44987 &48*A2*MB**2*P1Q2/(P2Q1*S)+192*A1*A2*MB**3*MT*P1Q2/(P2Q1*S)-
44988 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q1*S)-
44989 &96*A1*A2*MB**2*P1Q2**2/(P2Q1*S)+144*A1*P2Q1/S+192*A2*P2Q1/S+
44990 &96*A1*A2*MB*MT*P2Q1/S-480*A2**2*MB*MT*P2Q1/S+
44991 &480*A12*MT**2*P2Q1/S+384*A1*A2*MT**2*P2Q1/S
44992 A18=A18+672*A1*A2*P1P2*P2Q1/S+864*A2**2*P1P2*P2Q1/S-
44993 &96*A2*MB*MT*P2Q1/(P1Q1*S)+192*A1*MT**2*P2Q1/(P1Q1*S)+
44994 &96*A2*MT**2*P2Q1/(P1Q1*S)-192*A1*A2*MB*MT**3*P2Q1/(P1Q1*S)+
44995 &192*A2*P1P2*P2Q1/(P1Q1*S)+192*A1*A2*MT**2*P1P2*P2Q1/(P1Q1*S)-
44996 &192*A12*P1Q1*P2Q1/S-192*A2**2*P1Q1*P2Q1/S+
44997 &48*A1*MT**2*P2Q1/(P1Q2*S)+96*A2*MT**2*P2Q1/(P1Q2*S)+
44998 &192*A1*A2*MB*MT**3*P2Q1/(P1Q2*S)-
44999 &192*A1*A2*MT**2*P1P2*P2Q1/(P1Q2*S)+
45000 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P1Q2*S)-
45001 &192*A12*MT**2*P1Q1*P2Q1/(P1Q2*S)-
45002 &96*A1*A2*MT**2*P1Q1*P2Q1/(P1Q2*S)-
45003 &384*A1*A2*P1P2*P1Q1*P2Q1/(P1Q2*S)-384*A12*P1Q1**2*P2Q1/(P1Q2*S)-
45004 &384*A1*A2*P1Q1**2*P2Q1/(P1Q2*S)-480*A12*P1Q2*P2Q1/S-
45005 &960*A1*A2*P1Q2*P2Q1/S-480*A2**2*P1Q2*P2Q1/S+
45006 &144*A1*P1Q2*P2Q1/(P1Q1*S)+96*A2*P1Q2*P2Q1/(P1Q1*S)+
45007 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P1Q1*S)-
45008 &96*A12*MT**2*P1Q2*P2Q1/(P1Q1*S)
45009 A18=A18+96*A1*A2*MT**2*P1Q2*P2Q1/(P1Q1*S)-
45010 &576*A1*A2*P1P2*P1Q2*P2Q1/(P1Q1*S)-192*A12*P1Q2**2*P2Q1/(P1Q1*S)-
45011 &384*A1*A2*P1Q2**2*P2Q1/(P1Q1*S)-96*A1*A2*P2Q1**2/S-
45012 &96*A1*A2*MT**2*P2Q1**2/(P1Q1*S)+96*A1*A2*MT**2*P2Q1**2/(P1Q2*S)+
45013 &288*A1*A2*P1Q2*P2Q1**2/(P1Q1*S)-96*A2*MB**3*MT/(P2Q2*S)+
45014 &96*A2*MB**2*P1P2/(P2Q2*S)-192*A1*MB*MT*P1P2/(P2Q2*S)+
45015 &192*A1*P1P2**2/(P2Q2*S)+96*A1*MB**2*P1Q1/(P2Q2*S)+
45016 &48*A2*MB**2*P1Q1/(P2Q2*S)+192*A1*A2*MB**3*MT*P1Q1/(P2Q2*S)-
45017 &192*A1*A2*MB**2*P1P2*P1Q1/(P2Q2*S)-
45018 &96*A1*A2*MB**2*P1Q1**2/(P2Q2*S)+96*A1*MB**2*P1Q2/(P2Q2*S)+
45019 &192*A2*MB**2*P1Q2/(P2Q2*S)-96*A1*MB*MT*P1Q2/(P2Q2*S)-
45020 &192*A1*A2*MB**3*MT*P1Q2/(P2Q2*S)+192*A1*P1P2*P1Q2/(P2Q2*S)+
45021 &192*A1*A2*MB**2*P1P2*P1Q2/(P2Q2*S)-
45022 &192*A2*MB**3*MT*P1Q2/(P1Q1*P2Q2*S)+
45023 &192*A2*MB**2*P1P2*P1Q2/(P1Q1*P2Q2*S)-
45024 &96*A1*MB*MT*P1P2*P1Q2/(P1Q1*P2Q2*S)+
45025 &96*A1*P1P2**2*P1Q2/(P1Q1*P2Q2*S)+96*A1*A2*MB**2*P1Q2**2/(P2Q2*S)
45026 A18=A18+96*A1*MB**2*P1Q2**2/(P1Q1*P2Q2*S)+
45027 &192*A2*MB**2*P1Q2**2/(P1Q1*P2Q2*S)-
45028 &48*A1*MB*MT*P1Q2**2/(P1Q1*P2Q2*S)+
45029 &96*A1*P1P2*P1Q2**2/(P1Q1*P2Q2*S)-48*A2*MB**2*P2Q1/(P2Q2*S)-
45030 &96*A1*MB*MT*P2Q1/(P2Q2*S)+48*A2*MB*MT*P2Q1/(P2Q2*S)-
45031 &192*A1*P1P2*P2Q1/(P2Q2*S)-192*A2*P1P2*P2Q1/(P2Q2*S)-
45032 &192*A1*A2*MB*MT*P1P2*P2Q1/(P2Q2*S)+
45033 &192*A1*A2*P1P2**2*P2Q1/(P2Q2*S)+
45034 &192*A1*MB*MT**3*P2Q1/(P1Q1*P2Q2*S)+
45035 &96*A2*MB*MT*P1P2*P2Q1/(P1Q1*P2Q2*S)-
45036 &192*A1*MT**2*P1P2*P2Q1/(P1Q1*P2Q2*S)-
45037 &96*A2*P1P2**2*P2Q1/(P1Q1*P2Q2*S)+
45038 &96*A1*A2*MB**2*P1Q1*P2Q1/(P2Q2*S)+
45039 &192*A2**2*MB**2*P1Q1*P2Q1/(P2Q2*S)-
45040 &96*A1*A2*MB*MT*P1Q1*P2Q1/(P2Q2*S)+
45041 &384*A1*A2*P1P2*P1Q1*P2Q1/(P2Q2*S)-96*A1*P1Q2*P2Q1/(P2Q2*S)-
45042 &144*A2*P1Q2*P2Q1/(P2Q2*S)-96*A1*A2*MB**2*P1Q2*P2Q1/(P2Q2*S)
45043 A18=A18+96*A2**2*MB**2*P1Q2*P2Q1/(P2Q2*S)-
45044 &384*A1*A2*MB*MT*P1Q2*P2Q1/(P2Q2*S)+
45045 &576*A1*A2*P1P2*P1Q2*P2Q1/(P2Q2*S)-
45046 &96*A2*MB**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45047 &48*A1*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45048 &48*A2*MB*MT*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45049 &96*A1*MT**2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45050 &96*A1*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)-
45051 &96*A2*P1P2*P1Q2*P2Q1/(P1Q1*P2Q2*S)+
45052 &96*A1*A2*P1Q1*P1Q2*P2Q1/(P2Q2*S)+288*A1*A2*P1Q2**2*P2Q1/(P2Q2*S)-
45053 &96*A1*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)-96*A2*P1Q2**2*P2Q1/(P1Q1*P2Q2*S)+
45054 &192*A1*P2Q1**2/(P2Q2*S)+192*A2*P2Q1**2/(P2Q2*S)+
45055 &96*A1*A2*MB*MT*P2Q1**2/(P2Q2*S)-192*A2**2*MB*MT*P2Q1**2/(P2Q2*S)-
45056 &192*A1*A2*MT**2*P2Q1**2/(P2Q2*S)-192*A1*A2*P1P2*P2Q1**2/(P2Q2*S)-
45057 &48*A2*MB*MT*P2Q1**2/(P1Q1*P2Q2*S)+
45058 &192*A1*MT**2*P2Q1**2/(P1Q1*P2Q2*S)+
45059 &96*A2*MT**2*P2Q1**2/(P1Q1*P2Q2*S)
45060 A18=A18+96*A2*P1P2*P2Q1**2/(P1Q1*P2Q2*S)-
45061 &384*A1*A2*P1Q1*P2Q1**2/(P2Q2*S)-
45062 &384*A2**2*P1Q1*P2Q1**2/(P2Q2*S)-384*A1*A2*P1Q2*P2Q1**2/(P2Q2*S)-
45063 &192*A2**2*P1Q2*P2Q1**2/(P2Q2*S)+96*A1*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+
45064 &96*A2*P1Q2*P2Q1**2/(P1Q1*P2Q2*S)+144*A1*P2Q2/S+192*A2*P2Q2/S+
45065 &96*A1*A2*MB*MT*P2Q2/S-480*A2**2*MB*MT*P2Q2/S+
45066 &480*A12*MT**2*P2Q2/S+384*A1*A2*MT**2*P2Q2/S+
45067 &672*A1*A2*P1P2*P2Q2/S+864*A2**2*P1P2*P2Q2/S+
45068 &48*A1*MT**2*P2Q2/(P1Q1*S)+96*A2*MT**2*P2Q2/(P1Q1*S)+
45069 &192*A1*A2*MB*MT**3*P2Q2/(P1Q1*S)-
45070 &192*A1*A2*MT**2*P1P2*P2Q2/(P1Q1*S)-480*A12*P1Q1*P2Q2/S-
45071 &960*A1*A2*P1Q1*P2Q2/S-480*A2**2*P1Q1*P2Q2/S-
45072 &96*A2*MB*MT*P2Q2/(P1Q2*S)+192*A1*MT**2*P2Q2/(P1Q2*S)+
45073 &96*A2*MT**2*P2Q2/(P1Q2*S)-192*A1*A2*MB*MT**3*P2Q2/(P1Q2*S)+
45074 &192*A2*P1P2*P2Q2/(P1Q2*S)+192*A1*A2*MT**2*P1P2*P2Q2/(P1Q2*S)+
45075 &144*A1*P1Q1*P2Q2/(P1Q2*S)+96*A2*P1Q1*P2Q2/(P1Q2*S)+
45076 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P1Q2*S)
45077 A18=A18-96*A12*MT**2*P1Q1*P2Q2/(P1Q2*S)+
45078 &96*A1*A2*MT**2*P1Q1*P2Q2/(P1Q2*S)-
45079 &576*A1*A2*P1P2*P1Q1*P2Q2/(P1Q2*S)-192*A12*P1Q1**2*P2Q2/(P1Q2*S)-
45080 &384*A1*A2*P1Q1**2*P2Q2/(P1Q2*S)-192*A12*P1Q2*P2Q2/S-
45081 &192*A2**2*P1Q2*P2Q2/S+96*A1*A2*MB*MT*P1Q2*P2Q2/(P1Q1*S)-
45082 &192*A12*MT**2*P1Q2*P2Q2/(P1Q1*S)-
45083 &96*A1*A2*MT**2*P1Q2*P2Q2/(P1Q1*S)-
45084 &384*A1*A2*P1P2*P1Q2*P2Q2/(P1Q1*S)-384*A12*P1Q2**2*P2Q2/(P1Q1*S)-
45085 &384*A1*A2*P1Q2**2*P2Q2/(P1Q1*S)-48*A2*MB**2*P2Q2/(P2Q1*S)-
45086 &96*A1*MB*MT*P2Q2/(P2Q1*S)+48*A2*MB*MT*P2Q2/(P2Q1*S)-
45087 &192*A1*P1P2*P2Q2/(P2Q1*S)-192*A2*P1P2*P2Q2/(P2Q1*S)-
45088 &192*A1*A2*MB*MT*P1P2*P2Q2/(P2Q1*S)+
45089 &192*A1*A2*P1P2**2*P2Q2/(P2Q1*S)-96*A1*P1Q1*P2Q2/(P2Q1*S)-
45090 &144*A2*P1Q1*P2Q2/(P2Q1*S)-96*A1*A2*MB**2*P1Q1*P2Q2/(P2Q1*S)+
45091 &96*A2**2*MB**2*P1Q1*P2Q2/(P2Q1*S)-
45092 &384*A1*A2*MB*MT*P1Q1*P2Q2/(P2Q1*S)+
45093 &576*A1*A2*P1P2*P1Q1*P2Q2/(P2Q1*S)+288*A1*A2*P1Q1**2*P2Q2/(P2Q1*S)
45094 A18=A18+192*A1*MB*MT**3*P2Q2/(P1Q2*P2Q1*S)+
45095 &96*A2*MB*MT*P1P2*P2Q2/(P1Q2*P2Q1*S)-
45096 &192*A1*MT**2*P1P2*P2Q2/(P1Q2*P2Q1*S)-
45097 &96*A2*P1P2**2*P2Q2/(P1Q2*P2Q1*S)-
45098 &96*A2*MB**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45099 &48*A1*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45100 &48*A2*MB*MT*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45101 &96*A1*MT**2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45102 &96*A1*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45103 &96*A2*P1P2*P1Q1*P2Q2/(P1Q2*P2Q1*S)-
45104 &96*A1*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)-96*A2*P1Q1**2*P2Q2/(P1Q2*P2Q1*S)+
45105 &96*A1*A2*MB**2*P1Q2*P2Q2/(P2Q1*S)+
45106 &192*A2**2*MB**2*P1Q2*P2Q2/(P2Q1*S)-
45107 &96*A1*A2*MB*MT*P1Q2*P2Q2/(P2Q1*S)+
45108 &384*A1*A2*P1P2*P1Q2*P2Q2/(P2Q1*S)+
45109 &96*A1*A2*P1Q1*P1Q2*P2Q2/(P2Q1*S)-576*A1*A2*P2Q1*P2Q2/S+
45110 &96*A1*A2*P1Q1*P2Q1*P2Q2/(P1Q2*S)+96*A1*A2*P1Q2*P2Q1*P2Q2/(P1Q1*S)
45111 A18=A18-96*A1*A2*P2Q2**2/S+96*A1*A2*MT**2*P2Q2**2/(P1Q1*S)-
45112 &96*A1*A2*MT**2*P2Q2**2/(P1Q2*S)+288*A1*A2*P1Q1*P2Q2**2/(P1Q2*S)+
45113 &192*A1*P2Q2**2/(P2Q1*S)+192*A2*P2Q2**2/(P2Q1*S)+
45114 &96*A1*A2*MB*MT*P2Q2**2/(P2Q1*S)-192*A2**2*MB*MT*P2Q2**2/(P2Q1*S)-
45115 &192*A1*A2*MT**2*P2Q2**2/(P2Q1*S)-192*A1*A2*P1P2*P2Q2**2/(P2Q1*S)-
45116 &384*A1*A2*P1Q1*P2Q2**2/(P2Q1*S)-192*A2**2*P1Q1*P2Q2**2/(P2Q1*S)-
45117 &48*A2*MB*MT*P2Q2**2/(P1Q2*P2Q1*S)+
45118 &192*A1*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
45119 &96*A2*MT**2*P2Q2**2/(P1Q2*P2Q1*S)+
45120 &96*A2*P1P2*P2Q2**2/(P1Q2*P2Q1*S)+96*A1*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)+
45121 &96*A2*P1Q1*P2Q2**2/(P1Q2*P2Q1*S)-384*A1*A2*P1Q2*P2Q2**2/(P2Q1*S)-
45122 &384*A2**2*P1Q2*P2Q2**2/(P2Q1*S)+512*A1*A2*S/3-
45123 &128*A1*MT**2*S/(3*P1Q1**2)+128*A12*MB*MT**3*S/(3*P1Q1**2)-
45124 &152*A1*S/(3*P1Q1)-152*A12*MB*MT*S/(3*P1Q1)-
45125 &128*A1*A2*MB*MT*S/(3*P1Q1)+112*A1*A2*MT**2*S/(3*P1Q1)-
45126 &16*A12*P1P2*S/P1Q1+152*A1*A2*P1P2*S/(3*P1Q1)-
45127 &128*A1*MT**2*S/(3*P1Q2**2)+128*A12*MB*MT**3*S/(3*P1Q2**2)
45128 A18=A18-152*A1*S/(3*P1Q2)-152*A12*MB*MT*S/(3*P1Q2)-
45129 &128*A1*A2*MB*MT*S/(3*P1Q2)+112*A1*A2*MT**2*S/(3*P1Q2)-
45130 &16*A12*P1P2*S/P1Q2+152*A1*A2*P1P2*S/(3*P1Q2)+
45131 &16*A1*MB*MT*S/(3*P1Q1*P1Q2)-32*A12*MB*MT**3*S/(3*P1Q1*P1Q2)-
45132 &16*A1*P1P2*S/(3*P1Q1*P1Q2)+272*A1*A2*P1Q1*S/(3*P1Q2)+
45133 &272*A1*A2*P1Q2*S/(3*P1Q1)-128*A2*MB**2*S/(3*P2Q1**2)+
45134 &128*A2**2*MB**3*MT*S/(3*P2Q1**2)+
45135 &32*MB**2*MT**2*S/(3*P1Q2**2*P2Q1**2)+32*MB**2*S/(3*P1Q2*P2Q1**2)
45136
45137 A18BIS=
45138 &64*A2*MB**3*MT*S/(3*P1Q2*P2Q1**2)-
45139 &64*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1**2)-
45140 &128*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1**2)-
45141 &128*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1**2)+
45142 &128*A2**2*MB**2*P1Q2*S/(3*P2Q1**2)+152*A2*S/(3*P2Q1)-
45143 &112*A1*A2*MB**2*S/(3*P2Q1)+128*A1*A2*MB*MT*S/(3*P2Q1)+
45144 &152*A2**2*MB*MT*S/(3*P2Q1)-152*A1*A2*P1P2*S/(3*P2Q1)+
45145 &16*A2**2*P1P2*S/P2Q1-8*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q1)+
45146 &16*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q1)-
45147 &8*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q1)-8*A1*P1P2*S/(3*P1Q1*P2Q1)-
45148 &8*A2*P1P2*S/(3*P1Q1*P2Q1)+8*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1)-
45149 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1)+
45150 &8*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q1)+
45151 &32*A1*A2*P1P2**2*S/(3*P1Q1*P2Q1)-32*A2**2*P1Q1*S/(3*P2Q1)-
45152 &32*MT**2*S/(3*P1Q2**2*P2Q1)+64*A1*MB**2*MT**2*S/(3*P1Q2**2*P2Q1)-
45153 &64*A1*MB*MT**3*S/(3*P1Q2**2*P2Q1)
45154 A18BIS=A18BIS+128*A1*MT**2*P1P2*S/(3*P1Q2**2*P2Q1)-
45155 &12*S/(P1Q2*P2Q1)+
45156 &24*A1*MB**2*S/(P1Q2*P2Q1)+64*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q1)+
45157 &24*A2*MT**2*S/(P1Q2*P2Q1)-128*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q1)+
45158 &64*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q1)+56*A1*P1P2*S/(3*P1Q2*P2Q1)+
45159 &56*A2*P1P2*S/(3*P1Q2*P2Q1)-64*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1)+
45160 &128*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1)-
45161 &64*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q1)-
45162 &256*A1*A2*P1P2**2*S/(3*P1Q2*P2Q1)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
45163 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1)-
45164 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1)+136*A2*P1Q1*S/(3*P1Q2*P2Q1)-
45165 &128*A1*A2*MB**2*P1Q1*S/(3*P1Q2*P2Q1)+
45166 &128*A1*A2*MB*MT*P1Q1*S/(3*P1Q2*P2Q1)-
45167 &256*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1)-160*A2**2*P1Q2*S/(3*P2Q1)+
45168 &16*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1)-32*A12*P2Q1*S/(3*P1Q1)-
45169 &128*A12*MT**2*P2Q1*S/(3*P1Q2**2)-160*A12*P2Q1*S/(3*P1Q2)-
45170 &128*A2*MB**2*S/(3*P2Q2**2)+128*A2**2*MB**3*MT*S/(3*P2Q2**2)
45171 A18BIS=A18BIS+32*MB**2*MT**2*S/(3*P1Q1**2*P2Q2**2)+
45172 &32*MB**2*S/(3*P1Q1*P2Q2**2)+
45173 &64*A2*MB**3*MT*S/(3*P1Q1*P2Q2**2)-
45174 &64*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2**2)-
45175 &128*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2**2)+
45176 &128*A2**2*MB**2*P1Q1*S/(3*P2Q2**2)-
45177 &128*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2**2)+152*A2*S/(3*P2Q2)-
45178 &112*A1*A2*MB**2*S/(3*P2Q2)+128*A1*A2*MB*MT*S/(3*P2Q2)+
45179 &152*A2**2*MB*MT*S/(3*P2Q2)-152*A1*A2*P1P2*S/(3*P2Q2)+
45180 &16*A2**2*P1P2*S/P2Q2-32*MT**2*S/(3*P1Q1**2*P2Q2)+
45181 &64*A1*MB**2*MT**2*S/(3*P1Q1**2*P2Q2)-
45182 &64*A1*MB*MT**3*S/(3*P1Q1**2*P2Q2)+
45183 &128*A1*MT**2*P1P2*S/(3*P1Q1**2*P2Q2)-12*S/(P1Q1*P2Q2)+
45184 &24*A1*MB**2*S/(P1Q1*P2Q2)+64*A1*A2*MB**3*MT*S/(3*P1Q1*P2Q2)+
45185 &24*A2*MT**2*S/(P1Q1*P2Q2)-128*A1*A2*MB**2*MT**2*S/(3*P1Q1*P2Q2)+
45186 &64*A1*A2*MB*MT**3*S/(3*P1Q1*P2Q2)+56*A1*P1P2*S/(3*P1Q1*P2Q2)+
45187 &56*A2*P1P2*S/(3*P1Q1*P2Q2)-64*A1*A2*MB**2*P1P2*S/(3*P1Q1*P2Q2)
45188 A18BIS=A18BIS+128*A1*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q2)-
45189 &64*A1*A2*MT**2*P1P2*S/(3*P1Q1*P2Q2)-
45190 &256*A1*A2*P1P2**2*S/(3*P1Q1*P2Q2)-160*A2**2*P1Q1*S/(3*P2Q2)-
45191 &8*A1*A2*MB**3*MT*S/(3*P1Q2*P2Q2)+
45192 &16*A1*A2*MB**2*MT**2*S/(3*P1Q2*P2Q2)-
45193 &8*A1*A2*MB*MT**3*S/(3*P1Q2*P2Q2)-8*A1*P1P2*S/(3*P1Q2*P2Q2)-
45194 &8*A2*P1P2*S/(3*P1Q2*P2Q2)+8*A1*A2*MB**2*P1P2*S/(3*P1Q2*P2Q2)-
45195 &16*A1*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q2)+
45196 &8*A1*A2*MT**2*P1P2*S/(3*P1Q2*P2Q2)+
45197 &32*A1*A2*P1P2**2*S/(3*P1Q2*P2Q2)+4*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
45198 &8*A1*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q2)-
45199 &8*A1*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q2)+
45200 &16*A1*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q2)-32*A2**2*P1Q2*S/(3*P2Q2)+
45201 &136*A2*P1Q2*S/(3*P1Q1*P2Q2)-128*A1*A2*MB**2*P1Q2*S/(3*P1Q1*P2Q2)+
45202 &128*A1*A2*MB*MT*P1Q2*S/(3*P1Q1*P2Q2)-
45203 &256*A1*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q2)+16*A2*MB*MT*S/(3*P2Q1*P2Q2)-
45204 &32*A2**2*MB**3*MT*S/(3*P2Q1*P2Q2)-16*A2*P1P2*S/(3*P2Q1*P2Q2)
45205 A18BIS=A18BIS-4*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
45206 &8*A2*MB**2*P1P2*S/(3*P1Q1*P2Q1*P2Q2)+
45207 &8*A2*MB*MT*P1P2*S/(3*P1Q1*P2Q1*P2Q2)-4*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
45208 &8*A2*MB**2*P1P2*S/(3*P1Q2*P2Q1*P2Q2)+
45209 &8*A2*MB*MT*P1P2*S/(3*P1Q2*P2Q1*P2Q2)-
45210 &2*MB**3*MT*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
45211 &4*MB**2*MT**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45212 &2*MB*MT**3*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45213 &2*MB**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
45214 &4*MB*MT*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45215 &2*MT**2*P1P2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)-
45216 &8*P1P2**2*S/(3*P1Q1*P1Q2*P2Q1*P2Q2)+
45217 &8*A2*P1P2*P1Q1*S/(3*P1Q2*P2Q1*P2Q2)+
45218 &8*A2*P1P2*P1Q2*S/(3*P1Q1*P2Q1*P2Q2)+272*A1*A2*P2Q1*S/(3*P2Q2)-
45219 &128*A1*MT**2*P2Q1*S/(3*P1Q1**2*P2Q2)-136*A1*P2Q1*S/(3*P1Q1*P2Q2)-
45220 &128*A1*A2*MB*MT*P2Q1*S/(3*P1Q1*P2Q2)+
45221 &128*A1*A2*MT**2*P2Q1*S/(3*P1Q1*P2Q2)
45222 A18BIS=A18BIS+256*A1*A2*P1P2*P2Q1*S/(3*P1Q1*P2Q2)-
45223 &16*A1*A2*P1P2*P2Q1*S/(3*P1Q2*P2Q2)+
45224 &8*A1*P1P2*P2Q1*S/(3*P1Q1*P1Q2*P2Q2)+
45225 &256*A1*A2*P1Q2*P2Q1*S/(3*P1Q1*P2Q2)-
45226 &128*A12*MT**2*P2Q2*S/(3*P1Q1**2)-160*A12*P2Q2*S/(3*P1Q1)-
45227 &32*A12*P2Q2*S/(3*P1Q2)+272*A1*A2*P2Q2*S/(3*P2Q1)-
45228 &16*A1*A2*P1P2*P2Q2*S/(3*P1Q1*P2Q1)-
45229 &128*A1*MT**2*P2Q2*S/(3*P1Q2**2*P2Q1)-136*A1*P2Q2*S/(3*P1Q2*P2Q1)-
45230 &128*A1*A2*MB*MT*P2Q2*S/(3*P1Q2*P2Q1)+
45231 &128*A1*A2*MT**2*P2Q2*S/(3*P1Q2*P2Q1)+
45232 &256*A1*A2*P1P2*P2Q2*S/(3*P1Q2*P2Q1)+
45233 &8*A1*P1P2*P2Q2*S/(3*P1Q1*P1Q2*P2Q1)+
45234 &256*A1*A2*P1Q1*P2Q2*S/(3*P1Q2*P2Q1)-
45235 &8*A12*MB*MT*S**2/(3*P1Q1*P1Q2)+16*A12*P1P2*S**2/(3*P1Q1*P1Q2)-
45236 &8*A1*A2*P1P2*S**2/(3*P1Q1*P2Q1)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1)-
45237 &8*A1*A2*P1P2*S**2/(3*P1Q2*P2Q2)+4*A1*P1P2*S**2/(3*P1Q1*P1Q2*P2Q2)-
45238 &8*A2**2*MB*MT*S**2/(3*P2Q1*P2Q2)+16*A2**2*P1P2*S**2/(3*P2Q1*P2Q2)
45239 A18BIS=A18BIS-4*A2*P1P2*S**2/(3*P1Q1*P2Q1*P2Q2)-
45240 &4*A2*P1P2*S**2/(3*P1Q2*P2Q1*P2Q2)+
45241 &2*P1P2*S**2/(3*P1Q1*P1Q2*P2Q1*P2Q2)
45242C
45243 V18=V18+V18BIS
45244 A18=A18+A18BIS
45245 V910 =-48*A12*MB*MT-48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2-
45246 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2-
45247 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
45248 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
45249 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
45250 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2-
45251 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
45252 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
45253 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
45254 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
45255 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
45256 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
45257 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2+
45258 &96*A12*MB*MT*P1Q1/S-96*A1*A2*MB*MT*P1Q1/S+
45259 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S+96*A12*MB*MT*P1Q2/S-
45260 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S+
45261 &96*A1*A2*MB*MT*P2Q1/S-96*A2**2*MB*MT*P2Q1/S
45262 V910=V910+96*A1*A2*P1P2*P2Q1/S-
45263 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
45264 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S+
45265 &96*A1*A2*MB*MT*P2Q2/S-96*A2**2*MB*MT*P2Q2/S+
45266 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
45267 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
45268C
45269 A910 = 48*A12*MB*MT+48*A2**2*MB*MT-48*A12*P1P2-48*A2**2*P1P2+
45270 &384*A12*MB*MT*P1Q1*P1Q2/S**2-384*A12*P1P2*P1Q1*P1Q2/S**2+
45271 &384*A1*A2*MB*MT*P1Q2*P2Q1/S**2-384*A1*A2*P1P2*P1Q2*P2Q1/S**2+
45272 &192*A12*P1Q1*P1Q2*P2Q1/S**2+192*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
45273 &192*A12*P1Q2**2*P2Q1/S**2-192*A1*A2*P1Q2**2*P2Q1/S**2+
45274 &192*A1*A2*P1Q2*P2Q1**2/S**2+192*A2**2*P1Q2*P2Q1**2/S**2+
45275 &384*A1*A2*MB*MT*P1Q1*P2Q2/S**2-384*A1*A2*P1P2*P1Q1*P2Q2/S**2-
45276 &192*A12*P1Q1**2*P2Q2/S**2-192*A1*A2*P1Q1**2*P2Q2/S**2+
45277 &192*A12*P1Q1*P1Q2*P2Q2/S**2+192*A1*A2*P1Q1*P1Q2*P2Q2/S**2+
45278 &384*A2**2*MB*MT*P2Q1*P2Q2/S**2-384*A2**2*P1P2*P2Q1*P2Q2/S**2-
45279 &192*A1*A2*P1Q1*P2Q1*P2Q2/S**2-192*A2**2*P1Q1*P2Q1*P2Q2/S**2-
45280 &192*A1*A2*P1Q2*P2Q1*P2Q2/S**2-192*A2**2*P1Q2*P2Q1*P2Q2/S**2+
45281 &192*A1*A2*P1Q1*P2Q2**2/S**2+192*A2**2*P1Q1*P2Q2**2/S**2-
45282 &96*A12*MB*MT*P1Q1/S+96*A1*A2*MB*MT*P1Q1/S+
45283 &96*A12*P1P2*P1Q1/S-96*A1*A2*P1P2*P1Q1/S-96*A12*MB*MT*P1Q2/S+
45284 &96*A1*A2*MB*MT*P1Q2/S+96*A12*P1P2*P1Q2/S-96*A1*A2*P1P2*P1Q2/S-
45285 &96*A1*A2*MB*MT*P2Q1/S+96*A2**2*MB*MT*P2Q1/S
45286 A910=A910+96*A1*A2*P1P2*P2Q1/S-
45287 &96*A2**2*P1P2*P2Q1/S+96*A12*P1Q2*P2Q1/S+
45288 &192*A1*A2*P1Q2*P2Q1/S+96*A2**2*P1Q2*P2Q1/S-
45289 &96*A1*A2*MB*MT*P2Q2/S+96*A2**2*MB*MT*P2Q2/S+
45290 &96*A1*A2*P1P2*P2Q2/S-96*A2**2*P1P2*P2Q2/S+96*A12*P1Q1*P2Q2/S+
45291 &192*A1*A2*P1Q1*P2Q2/S+96*A2**2*P1Q1*P2Q2/S
45292C
45293C FINAL RESULT;
45294C
45295 AMP2= FACT*PS*VTB**2*(V**2 *(V18 +V910)+A**2 *(A18+A910) )
45296
45297 END
45298C---------------------------------------------------------
45299C 2) Q QBAR ->TBH^+
45300 SUBROUTINE PYTBHQ(Q1,Q2,P1,P2,P3,MT,MB,RMB,MHP,AMP2)
45301C
45302C AMP2(OUTPUT) =MATRIX ELEMENT (AMPLITUDE**2) FOR Q QBAR->TB H^+
45303C (NB SAME STRUCTURE AS FOR PYTBHG ROUTINE ABOVE)
45304 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45305 IMPLICIT INTEGER(I-N)
45306 DOUBLE PRECISION MW2,MT,MB,MHP,MW
45307 DIMENSION Q1(4),Q2(4),P1(4),P2(4),P3(4)
45308 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45309 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45310 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45311 COMMON/PYCTBH/ ALPHA,ALPHAS,SW2,MW2,TANB,VTB,V,A
45312 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYCTBH/
45313C !THE RELEVANT INPUT PARAMETERS ABOVE ARE NEEDED FOR CALCULATION
45314C BUT ARE NOT DEFINED HERE SO THAT ONE MAY CHOOSE/VARY THEIR VALUES:
45315C ACCORDINGLY, WHEN CALLING THESE SUBROUTINES, PLEASE SUPPLY VIA
45316C THIS COMMON/PARAM/ YOUR PREFERRED ALPHA, ALPHAS,..AND TANB VALUES
45317C
45318C THE NORMALIZED V,A COUPLINGS ARE DEFINED BELOW AND USED BOTH
45319C IN THIS ROUTINE AND IN THE TOP WIDTH CALCULATION PYTBHB(..).
45320C
45321 DIMENSION YY(2,2)
45322
45323 PI = 4*DATAN(1.D0)
45324 MW = DSQRT(MW2)
45325
45326C COLLECTING THE RELEVANT OVERALL FACTORS:
45327C 3X3 INITIAL QUARK COLOR AVERAGE, 2X2 QUARK SPIN AVERAGE
45328 PS=1.D0/(3.D0*3.D0 *2.D0*2.D0)
45329C COUPLING CONSTANT (OVERALL NORMALIZATION)
45330 FACT=(4.D0*PI*ALPHA)*(4.D0*PI*ALPHAS)**2/SW2/2.D0
45331C NB ALPHA IS E^2/4/PI, BUT BETTER DEFINED IN TERMS OF G_FERMI:
45332C ALPHA= DSQRT(2.D0)*GF*SW2*MW**2/PI
45333C ALPHAS IS ALPHA_STRONG;
45334C SW2 IS SIN(THETA_W)**2.
45335C
45336C VTB=.998D0
45337C VTB IS TOP-BOTTOM CKM MATRIX ELEMENT (APPROXIMATE VALUE HERE)
45338C
45339 V = ( MT/MW/TANB +RMB/MW*TANB)/2.D0
45340 A = (-MT/MW/TANB +RMB/MW*TANB)/2.D0
45341C V AND A ARE (NORMALIZED) VECTOR AND AXIAL TBH^+ COUPLINGS
45342C
45343C REDEFINING P2 INGOING FROM OVERALL MOMENTUM CONSERVATION
45344C (BECAUSE P2 INGOING WAS USED IN OUR GRAPH CALCULATION CONVENTIONS)
45345 DO 100 KK=1,4
45346 P2(KK)=P3(KK)-Q1(KK)-Q2(KK)+P1(KK)
45347 100 CONTINUE
45348C DEFINING VARIOUS RELEVANT 4-SCALAR PRODUCTS:
45349 S = 2*PYTBHS(Q1,Q2)
45350 P1Q1=PYTBHS(Q1,P1)
45351 P1Q2=PYTBHS(P1,Q2)
45352 P2Q1=PYTBHS(P2,Q1)
45353 P2Q2=PYTBHS(P2,Q2)
45354 P1P2=PYTBHS(P1,P2)
45355C
45356C TOP WIDTH CALCULATION
45357 CALL PYTBHB(MT,MB,MHP,BR,GAMT)
45358C GAMT IS THE TOP WIDTH: T->BH^+ AND/OR T->B W^+
45359C THEN DEFINE TOP (RESONANT) PROPAGATOR:
45360 A1INV= S -2*P1Q1 -2*P1Q2
45361 A1 =A1INV/(A1INV**2+ (GAMT*MT)**2)
45362C (I.E. INTRODUCE THE TOP WIDTH IN A1 TO REGULARISE THE POLE)
45363C NB A12 = A1*A1 BUT WITH CORRECT WIDTH TREATMENT
45364 A12 = 1.D0/(A1INV**2+ (GAMT*MT)**2)
45365 A2 =1.D0/(S +2*P2Q1 +2*P2Q2)
45366C NOTE A2 IS B PROPAGATOR, DOES NOT NEED A WIDTH
45367C NOW COMES THE AMP**2:
45368C NB COLOR FACTOR (COMING FORM GRAPHS) ALREADY INCLUDED IN
45369C THE EXPRESSIONS BELOW
45370 YY(1, 1) = -16*A**2*A2**2*MB*MT+
45371 &64*A**2*A2**2*P1Q2*P2Q1**2/S**2+
45372 &128*A**2*A2**2*MB*MT*P2Q1*P2Q2/S**2-
45373 &128*A**2*A2**2*P1P2*P2Q1*P2Q2/S**2-
45374 &64*A**2*A2**2*P1Q1*P2Q1*P2Q2/S**2-
45375 &64*A**2*A2**2*P1Q2*P2Q1*P2Q2/S**2+
45376 &64*A**2*A2**2*P1Q1*P2Q2**2/S**2-
45377 &32*A**2*A2**2*MB**3*MT/S+32*A**2*A2**2*MB**2*P1P2/S+
45378 &32*A**2*A2**2*MB**2*P1Q1/S+32*A**2*A2**2*MB**2*P1Q2/S-
45379 &32*A**2*A2**2*P1P2*P2Q1/S-32*A**2*A2**2*P1Q1*P2Q1/S-
45380 &32*A**2*A2**2*P1P2*P2Q2/S-32*A**2*A2**2*P1Q2*P2Q2/S+
45381 &16*A2**2*MB*MT*V**2+64*A2**2*P1Q2*P2Q1**2*V**2/S**2-
45382 &128*A2**2*MB*MT*P2Q1*P2Q2*V**2/S**2-
45383 &128*A2**2*P1P2*P2Q1*P2Q2*V**2/S**2-
45384 &64*A2**2*P1Q1*P2Q1*P2Q2*V**2/S**2-
45385 &64*A2**2*P1Q2*P2Q1*P2Q2*V**2/S**2+
45386 &64*A2**2*P1Q1*P2Q2**2*V**2/S**2
45387 YY(1, 1)=YY(1, 1)+32*A2**2*MB**3*MT*V**2/S+
45388 &32*A2**2*MB**2*P1P2*V**2/S+
45389 &32*A2**2*MB**2*P1Q1*V**2/S+32*A2**2*MB**2*P1Q2*V**2/S-
45390 &32*A2**2*P1P2*P2Q1*V**2/S-32*A2**2*P1Q1*P2Q1*V**2/S-
45391 &32*A2**2*P1P2*P2Q2*V**2/S-32*A2**2*P1Q2*P2Q2*V**2/S
45392 YY(1, 1)=2*YY(1, 1)
45393
45394 YY(1, 2) = -32*A**2*A1*A2*MB*MT+
45395 &128*A**2*A1*A2*MB*MT*P1Q2*P2Q1/S**2-
45396 &128*A**2*A1*A2*P1P2*P1Q2*P2Q1/S**2+
45397 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q1/S**2-
45398 &64*A**2*A1*A2*P1Q2**2*P2Q1/S**2+
45399 &64*A**2*A1*A2*P1Q2*P2Q1**2/S**2+
45400 &128*A**2*A1*A2*MB*MT*P1Q1*P2Q2/S**2-
45401 &128*A**2*A1*A2*P1P2*P1Q1*P2Q2/S**2-
45402 &64*A**2*A1*A2*P1Q1**2*P2Q2/S**2+
45403 &64*A**2*A1*A2*P1Q1*P1Q2*P2Q2/S**2-
45404 &64*A**2*A1*A2*P1Q1*P2Q1*P2Q2/S**2-
45405 &64*A**2*A1*A2*P1Q2*P2Q1*P2Q2/S**2+
45406 &64*A**2*A1*A2*P1Q1*P2Q2**2/S**2-
45407 &64*A**2*A1*A2*MB*MT*P1P2/S+
45408 &64*A**2*A1*A2*P1P2**2/S+32*A**2*A1*A2*MB**2*P1Q1/S+
45409 &32*A**2*A1*A2*P1P2*P1Q1/S+32*A**2*A1*A2*MB**2*P1Q2/S+
45410 &32*A**2*A1*A2*P1P2*P1Q2/S-32*A**2*A1*A2*MT**2*P2Q1/S
45411 YY(1, 2)=YY(1, 2)-32*A**2*A1*A2*P1P2*P2Q1/S-
45412 &64*A**2*A1*A2*P1Q1*P2Q1/S-
45413 &32*A**2*A1*A2*MT**2*P2Q2/S-32*A**2*A1*A2*P1P2*P2Q2/S-
45414 &64*A**2*A1*A2*P1Q2*P2Q2/S+32*A1*A2*MB*MT*V**2-
45415 &128*A1*A2*MB*MT*P1Q2*P2Q1*V**2/S**2 -
45416 &128*A1*A2*P1P2*P1Q2*P2Q1*V**2/S**2+
45417 &64*A1*A2*P1Q1*P1Q2*P2Q1*V**2/S**2-
45418 &64*A1*A2*P1Q2**2*P2Q1*V**2/S**2+
45419 &64*A1*A2*P1Q2*P2Q1**2*V**2/S**2-
45420 &128*A1*A2*MB*MT*P1Q1*P2Q2*V**2/S**2-
45421 &128*A1*A2*P1P2*P1Q1*P2Q2*V**2/S**2-
45422 &64*A1*A2*P1Q1**2*P2Q2*V**2/S**2+
45423 &64*A1*A2*P1Q1*P1Q2*P2Q2*V**2/S**2-
45424 &64*A1*A2*P1Q1*P2Q1*P2Q2*V**2/S**2-
45425 &64*A1*A2*P1Q2*P2Q1*P2Q2*V**2/S**2+
45426 &64*A1*A2*P1Q1*P2Q2**2*V**2/S**2+
45427 &64*A1*A2*MB*MT*P1P2*V**2/S+64*A1*A2*P1P2**2*V**2/S
45428 YY(1, 2)=YY(1, 2)+32*A1*A2*MB**2*P1Q1*V**2/S+
45429 &32*A1*A2*P1P2*P1Q1*V**2/S+
45430 &32*A1*A2*MB**2*P1Q2*V**2/S+32*A1*A2*P1P2*P1Q2*V**2/S-
45431 &32*A1*A2*MT**2*P2Q1*V**2/S-32*A1*A2*P1P2*P2Q1*V**2/S-
45432 &64*A1*A2*P1Q1*P2Q1*V**2/S-32*A1*A2*MT**2*P2Q2*V**2/S-
45433 &32*A1*A2*P1P2*P2Q2*V**2/S-64*A1*A2*P1Q2*P2Q2*V**2/S
45434
45435
45436 YY(2, 2) =-16*A**2*A12*MB*MT+
45437 &128*A**2*A12*MB*MT*P1Q1*P1Q2/S**2-
45438 &128*A**2*A12*P1P2*P1Q1*P1Q2/S**2+
45439 &64*A**2*A12*P1Q1*P1Q2*P2Q1/S**2-
45440 &64*A**2*A12*P1Q2**2*P2Q1/S**2-64*A**2*A12*P1Q1**2*P2Q2/S**2+
45441 &64*A**2*A12*P1Q1*P1Q2*P2Q2/S**2-32*A**2*A12*MB*MT**3/S+
45442 &32*A**2*A12*MT**2*P1P2/S+32*A**2*A12*P1P2*P1Q1/S+
45443 &32*A**2*A12*P1P2*P1Q2/S-32*A**2*A12*MT**2*P2Q1/S-
45444 &32*A**2*A12*P1Q1*P2Q1/S-32*A**2*A12*MT**2*P2Q2/S-
45445 &32*A**2*A12*P1Q2*P2Q2/S+16*A12*MB*MT*V**2-
45446 &128*A12*MB*MT*P1Q1*P1Q2*V**2/S**2-
45447 &128*A12*P1P2*P1Q1*P1Q2*V**2/S**2+
45448 &64*A12*P1Q1*P1Q2*P2Q1*V**2/S**2-
45449 &64*A12*P1Q2**2*P2Q1*V**2/S**2-64*A12*P1Q1**2*P2Q2*V**2/S**2+
45450 &64*A12*P1Q1*P1Q2*P2Q2*V**2/S**2+32*A12*MB*MT**3*V**2/S+
45451 &32*A12*MT**2*P1P2*V**2/S+32*A12*P1P2*P1Q1*V**2/S+
45452 &32*A12*P1P2*P1Q2*V**2/S-32*A12*MT**2*P2Q1*V**2/S
45453 YY(2, 2)=YY(2, 2)-32*A12*P1Q1*P2Q1*V**2/S-
45454 &32*A12*MT**2*P2Q2*V**2/S-
45455 &32*A12*P1Q2*P2Q2*V**2/S
45456 YY(2, 2)=2*YY(2, 2)
45457
45458 RES=YY(1,1)+2*YY(1,2)+YY(2,2)
45459 AMP2= FACT*PS*VTB**2*RES
45460
45461 END
45462C=====================================================================
45463C ************* FUNCTION SCALAR PRODUCTS *************************
45464 DOUBLE PRECISION FUNCTION PYTBHS(A,B)
45465 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45466 IMPLICIT INTEGER(I-N)
45467 DIMENSION A(4),B(4)
45468 DUM=A(4)*B(4)
45469 DO 100 ID=1,3
45470 DUM=DUM-A(ID)*B(ID)
45471 100 CONTINUE
45472 PYTBHS=DUM
45473 RETURN
45474 END
45475
45476C*********************************************************************
45477
45478C...PYMSIN
45479C...Initializes supersymmetry: finds sparticle masses and
45480C...branching ratios and stores this information.
45481C...AUTHOR: STEPHEN MRENNA
45482C...Author: P. Skands (SLHA + RPV + ISASUSY Interface, NMSSM)
45483
45484 SUBROUTINE PYMSIN
45485
45486C...Double precision and integer declarations.
45487 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
45488 IMPLICIT INTEGER(I-N)
45489 INTEGER PYK,PYCHGE,PYCOMP
45490C...Parameter statement to help give large particle numbers.
45491 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
45492 &KEXCIT=4000000,KDIMEN=5000000)
45493C...Commonblocks.
45494 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
45495 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
45496 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
45497 COMMON/PYDAT4/CHAF(500,2)
45498 CHARACTER CHAF*16
45499 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
45500 COMMON/PYINT4/MWID(500),WIDS(500,5)
45501 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
45502 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
45503 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
45504 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
45505 COMMON/PYHTRI/HHH(7)
45506 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
45507 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/,
45508 &/PYMSSM/,/PYMSRV/,/PYSSMT/
45509
45510C...Local variables.
45511 DOUBLE PRECISION ALFA,BETA
45512 DOUBLE PRECISION TANB,AL,BE,COSA,COSB,SINA,SINB,XW
45513 INTEGER I,J,J1,I1,K1
45514 INTEGER KC,LKNT,IDLAM(400,3)
45515 DOUBLE PRECISION XLAM(0:400)
45516 DOUBLE PRECISION WDTP(0:400),WDTE(0:400,0:5)
45517 DOUBLE PRECISION XARG,COS2B,XMW2,XMZ2
45518 DOUBLE PRECISION DELM,XMDIF
45519 DOUBLE PRECISION DX,DY,DS,DMU2,DMA2,DQ2,DU2,DD2,DL2,DE2,DHU2,DHD2
45520 DOUBLE PRECISION ARG,SGNMU,R
45521 INTEGER IMSSM
45522 INTEGER IRPRTY
45523 INTEGER KFSUSY(50),MWIDSU(36),MDCYSU(36)
45524 SAVE MWIDSU,MDCYSU
45525 DATA KFSUSY/
45526 &1000001,2000001,1000002,2000002,1000003,2000003,
45527 &1000004,2000004,1000005,2000005,1000006,2000006,
45528 &1000011,2000011,1000012,2000012,1000013,2000013,
45529 &1000014,2000014,1000015,2000015,1000016,2000016,
45530 &1000021,1000022,1000023,1000025,1000035,1000024,
45531 &1000037,1000039, 25, 35, 36, 37,
45532 & 6, 24, 45, 46,1000045, 9*0/
45533 DATA INIT/0/
45534
45535C...Automatically read QNUMBERS, MASS, and DECAY tables
45536 IF (IMSS(21).NE.0.OR.MSTP(161).NE.0) THEN
45537 NQNUM=0
45538 CALL PYSLHA(0,0,IFAIL)
45539 CALL PYSLHA(5,0,IFAIL)
45540 ENDIF
45541 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) CALL PYSLHA(2,0,IFAIL)
45542
45543C...Do nothing further if SUSY not requested
45544 IMSSM=IMSS(1)
45545 IF(IMSSM.EQ.0) RETURN
45546
45547C...Save copy of MWID(KC) and MDCY(KC,1) values before
45548C...they are set to zero for the LSP.
45549 IF(INIT.EQ.0) THEN
45550 INIT=1
45551 DO 100 I=1,36
45552 KF=KFSUSY(I)
45553 KC=PYCOMP(KF)
45554 MWIDSU(I)=MWID(KC)
45555 MDCYSU(I)=MDCY(KC,1)
45556 100 CONTINUE
45557 ENDIF
45558
45559C...Restore MWID(KC) and MDCY(KC,1) values previously zeroed for LSP.
45560 DO 110 I=1,36
45561 KF=KFSUSY(I)
45562 KC=PYCOMP(KF)
45563 IF(MDCY(KC,1).EQ.0.AND.MDCYSU(I).NE.0) THEN
45564 MWID(KC)=MWIDSU(I)
45565 MDCY(KC,1)=MDCYSU(I)
45566 ENDIF
45567 110 CONTINUE
45568
45569C...First part of routine: set masses and couplings.
45570
45571C...Reset mixing values in sfermion sector to pure left/right.
45572 DO 120 I=1,16
45573 SFMIX(I,1)=1D0
45574 SFMIX(I,4)=1D0
45575 SFMIX(I,2)=0D0
45576 SFMIX(I,3)=0D0
45577 120 CONTINUE
45578
45579C...Add NMSSM states if NMSSM switched on, and change old names.
45580 IF (IMSS(13).NE.0.AND.PYCOMP(1000045).EQ.0) THEN
45581C... Switch on NMSSM
45582 WRITE(MSTU(11),*) '(PYMSIN:) switching on NMSSM'
45583
45584 KFN=25
45585 KCN=KFN
45586 CHAF(KCN,1)='h_10'
45587 CHAF(KCN,2)=' '
45588
45589 KFN=35
45590 KCN=KFN
45591 CHAF(KCN,1)='h_20'
45592 CHAF(KCN,2)=' '
45593
45594 KFN=45
45595 KCN=KFN
45596 CHAF(KCN,1)='h_30'
45597 CHAF(KCN,2)=' '
45598
45599 KFN=36
45600 KCN=KFN
45601 CHAF(KCN,1)='A_10'
45602 CHAF(KCN,2)=' '
45603
45604 KFN=46
45605 KCN=KFN
45606 CHAF(KCN,1)='A_20'
45607 CHAF(KCN,2)=' '
45608
45609 KFN=1000045
45610 KCN=PYCOMP(KFN)
45611 IF (KCN.EQ.0) THEN
45612 DO 123 KCT=100,MSTU(6)
45613 IF(KCHG(KCT,4).GT.100) KCN=KCT
45614 123 CONTINUE
45615 KCN=KCN+1
45616 KCHG(KCN,4)=KFN
45617 MSTU(20)=0
45618 ENDIF
45619C... Set stable for now
45620 PMAS(KCN,2)=1D-6
45621 MWID(KCN)=0
45622 MDCY(KCN,1)=0
45623 MDCY(KCN,2)=0
45624 MDCY(KCN,3)=0
45625 CHAF(KCN,1)='~chi_50'
45626 CHAF(KCN,2)=' '
45627 ENDIF
45628
45629C...Read spectrum from SLHA file.
45630 IF (IMSSM.EQ.11) THEN
45631 CALL PYSLHA(1,0,IFAIL)
45632 ENDIF
45633
45634C...Common couplings.
45635 TANB=RMSS(5)
45636 BETA=ATAN(TANB)
45637 COSB=COS(BETA)
45638 SINB=TANB*COSB
45639 COS2B=COS(2D0*BETA)
45640 ALFA=RMSS(18)
45641 XMW2=PMAS(24,1)**2
45642 XMZ2=PMAS(23,1)**2
45643 XW=PARU(102)
45644
45645C...Define sparticle masses for a general MSSM simulation.
45646 IF(IMSSM.EQ.1) THEN
45647 IF(IMSS(9).EQ.0) RMSS(22)=RMSS(9)
45648 DO 130 I=1,5,2
45649 KC=PYCOMP(KSUSY1+I)
45650 PMAS(KC,1)=SQRT(RMSS(8)**2-(2D0*XMW2+XMZ2)*COS2B/6D0)
45651 KC=PYCOMP(KSUSY2+I)
45652 PMAS(KC,1)=SQRT(RMSS(9)**2+(XMW2-XMZ2)*COS2B/3D0)
45653 KC=PYCOMP(KSUSY1+I+1)
45654 PMAS(KC,1)=SQRT(RMSS(8)**2+(4D0*XMW2-XMZ2)*COS2B/6D0)
45655 KC=PYCOMP(KSUSY2+I+1)
45656 PMAS(KC,1)=SQRT(RMSS(22)**2-(XMW2-XMZ2)*COS2B*2D0/3D0)
45657 130 CONTINUE
45658 XARG=RMSS(6)**2-PMAS(24,1)**2*ABS(COS(2D0*BETA))
45659 IF(XARG.LT.0D0) THEN
45660 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
45661 & ' FROM THE SUM RULE. '
45662 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
45663 RETURN
45664 ELSE
45665 XARG=SQRT(XARG)
45666 ENDIF
45667 DO 140 I=11,15,2
45668 PMAS(PYCOMP(KSUSY1+I),1)=RMSS(6)
45669 PMAS(PYCOMP(KSUSY2+I),1)=RMSS(7)
45670 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
45671 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
45672 140 CONTINUE
45673 IF(IMSS(8).EQ.1) THEN
45674 RMSS(13)=RMSS(6)
45675 RMSS(14)=RMSS(7)
45676 ENDIF
45677
45678C...Alternatively derive masses from SUGRA relations.
45679 ELSEIF(IMSSM.EQ.2) THEN
45680 RMSS(36)=RMSS(16)
45681 CALL PYAPPS
45682C...Or use ISASUSY
45683 ELSEIF(IMSSM.EQ.12.OR.IMSSM.EQ.13) THEN
45684 RMSS(36)=RMSS(16)
45685 CALL PYSUGI
45686 ALFA=RMSS(18)
45687 GOTO 170
45688 ELSE
45689 GOTO 170
45690 ENDIF
45691
45692C...Add in extra D-term contributions.
45693 IF(IMSS(7).EQ.1) THEN
45694 R=0.43D0
45695 DX=RMSS(23)
45696 DY=RMSS(24)
45697 DS=RMSS(25)
45698 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45699 WRITE(MSTU(11),*) 'C NEW DTERMS ADDED TO SCALAR MASSES '
45700 WRITE(MSTU(11),*) 'C IN A U(B-L) THEORY '
45701 WRITE(MSTU(11),*) 'C DX = ',DX
45702 WRITE(MSTU(11),*) 'C DY = ',DY
45703 WRITE(MSTU(11),*) 'C DS = ',DS
45704 WRITE(MSTU(11),*) 'C '
45705 DY=R*DY-4D0/33D0*(1D0-R)*DX+(1D0-R)/33D0*DS
45706 WRITE(MSTU(11),*) 'C DY AT THE WEAK SCALE = ',DY
45707 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45708 DQ2=DY/6D0-DX/3D0-DS/3D0
45709 DU2=-2D0*DY/3D0-DX/3D0-DS/3D0
45710 DD2=DY/3D0+DX-2D0*DS/3D0
45711 DL2=-DY/2D0+DX-2D0*DS/3D0
45712 DE2=DY-DX/3D0-DS/3D0
45713 DHU2=DY/2D0+2D0*DX/3D0+2D0*DS/3D0
45714 DHD2=-DY/2D0-2D0*DX/3D0+DS
45715 DMU2=(-DY/2D0-2D0/3D0*DX+(COSB**2-2D0*SINB**2/3D0)*DS)
45716 & /ABS(COS2B)
45717 DMA2 = 2D0*DMU2+DHU2+DHD2
45718 DO 150 I=1,5,2
45719 KC=PYCOMP(KSUSY1+I)
45720 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
45721 KC=PYCOMP(KSUSY2+I)
45722 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DD2)
45723 KC=PYCOMP(KSUSY1+I+1)
45724 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DQ2)
45725 KC=PYCOMP(KSUSY2+I+1)
45726 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DU2)
45727 150 CONTINUE
45728 DO 160 I=11,15,2
45729 KC=PYCOMP(KSUSY1+I)
45730 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
45731 KC=PYCOMP(KSUSY2+I)
45732 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DE2)
45733 KC=PYCOMP(KSUSY1+I+1)
45734 PMAS(KC,1)=SQRT(PMAS(KC,1)**2+DL2)
45735 160 CONTINUE
45736 IF(RMSS(4)**2+DMU2.LT.0D0) THEN
45737 WRITE(MSTU(11),*) ' MU2 DRIVEN NEGATIVE '
45738 CALL PYSTOP(104)
45739 ENDIF
45740 SGNMU=SIGN(1D0,RMSS(4))
45741 RMSS(4)=SGNMU*SQRT(RMSS(4)**2+DMU2)
45742 ARG=RMSS(10)**2*SIGN(1D0,RMSS(10))+DQ2
45743 RMSS(10)=SIGN(SQRT(ABS(ARG)),ARG)
45744 ARG=RMSS(11)**2*SIGN(1D0,RMSS(11))+DD2
45745 RMSS(11)=SIGN(SQRT(ABS(ARG)),ARG)
45746 ARG=RMSS(12)**2*SIGN(1D0,RMSS(12))+DU2
45747 RMSS(12)=SIGN(SQRT(ABS(ARG)),ARG)
45748 ARG=RMSS(13)**2*SIGN(1D0,RMSS(13))+DL2
45749 RMSS(13)=SIGN(SQRT(ABS(ARG)),ARG)
45750 ARG=RMSS(14)**2*SIGN(1D0,RMSS(14))+DE2
45751 RMSS(14)=SIGN(SQRT(ABS(ARG)),ARG)
45752 IF( RMSS(19)**2 + DMA2 .LE. 50D0 ) THEN
45753 WRITE(MSTU(11),*) ' MA DRIVEN TOO LOW '
45754 CALL PYSTOP(104)
45755 ENDIF
45756 RMSS(19)=SQRT(RMSS(19)**2+DMA2)
45757 RMSS(6)=SQRT(RMSS(6)**2+DL2)
45758 RMSS(7)=SQRT(RMSS(7)**2+DE2)
45759 WRITE(MSTU(11),*) ' MTL = ',RMSS(10)
45760 WRITE(MSTU(11),*) ' MBR = ',RMSS(11)
45761 WRITE(MSTU(11),*) ' MTR = ',RMSS(12)
45762 WRITE(MSTU(11),*) ' SEL = ',RMSS(6),RMSS(13)
45763 WRITE(MSTU(11),*) ' SER = ',RMSS(7),RMSS(14)
45764 ENDIF
45765
45766C...Fix the third generation sfermions.
45767 CALL PYTHRG
45768
45769C...Fix the neutralino--chargino--gluino sector.
45770 CALL PYINOM
45771
45772C...Fix the Higgs sector.
45773 CALL PYHGGM(ALFA)
45774
45775C...Choose the Gunion-Haber convention.
45776 ALFA=-ALFA
45777 RMSS(18)=ALFA
45778
45779C...Print information on mass parameters.
45780 IF(IMSSM.EQ.2.AND.MSTP(122).GT.0) THEN
45781 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45782 WRITE(MSTU(11),*) ' USING APPROXIMATE SUGRA RELATIONS '
45783 WRITE(MSTU(11),*) ' M0 = ',RMSS(8)
45784 WRITE(MSTU(11),*) ' M1/2=',RMSS(1)
45785 WRITE(MSTU(11),*) ' TANB=',RMSS(5)
45786 WRITE(MSTU(11),*) ' MU = ',RMSS(4)
45787 WRITE(MSTU(11),*) ' AT = ',RMSS(16)
45788 WRITE(MSTU(11),*) ' MA = ',RMSS(19)
45789 WRITE(MSTU(11),*) ' MTOP=',PMAS(6,1)
45790 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45791 ENDIF
45792 IF(IMSS(20).EQ.1) THEN
45793 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45794 WRITE(MSTU(11),*) ' DEBUG MODE '
45795 WRITE(MSTU(11),*) ' UMIX = ',UMIX(1,1),UMIX(1,2),
45796 & UMIX(2,1),UMIX(2,2)
45797 WRITE(MSTU(11),*) ' UMIXI = ',UMIXI(1,1),UMIXI(1,2),
45798 & UMIXI(2,1),UMIXI(2,2)
45799 WRITE(MSTU(11),*) ' VMIX = ',VMIX(1,1),VMIX(1,2),
45800 & VMIX(2,1),VMIX(2,2)
45801 WRITE(MSTU(11),*) ' VMIXI = ',VMIXI(1,1),VMIXI(1,2),
45802 & VMIXI(2,1),VMIXI(2,2)
45803 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(1,I),I=1,4)
45804 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(1,I),I=1,4)
45805 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(2,I),I=1,4)
45806 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(2,I),I=1,4)
45807 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(3,I),I=1,4)
45808 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(3,I),I=1,4)
45809 WRITE(MSTU(11),*) ' ZMIX = ',(ZMIX(4,I),I=1,4)
45810 WRITE(MSTU(11),*) ' ZMIXI = ',(ZMIXI(4,I),I=1,4)
45811 WRITE(MSTU(11),*) ' ALFA = ',ALFA
45812 WRITE(MSTU(11),*) ' BETA = ',BETA
45813 WRITE(MSTU(11),*) ' STOP = ',(SFMIX(6,I),I=1,4)
45814 WRITE(MSTU(11),*) ' SBOT = ',(SFMIX(5,I),I=1,4)
45815 WRITE(MSTU(11),*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
45816 ENDIF
45817
45818C...Set up the Higgs couplings - needed here since initialization
45819C...in PYINRE did not yet occur when PYWIDT is called below.
45820 170 AL=ALFA
45821 BE=BETA
45822 SINA=SIN(AL)
45823 COSA=COS(AL)
45824 COSB=COS(BE)
45825 SINB=TANB*COSB
45826 SBMA=SIN(BE-AL)
45827 SAPB=SIN(AL+BE)
45828 CAPB=COS(AL+BE)
45829 CBMA=COS(BE-AL)
45830 C2A=COS(2D0*AL)
45831 C2B=COSB**2-SINB**2
45832C...tanb (used for H+)
45833 PARU(141)=TANB
45834
45835C...Firstly: h
45836C...Coupling to d-type quarks
45837 PARU(161)=SINA/COSB
45838C...Coupling to u-type quarks
45839 PARU(162)=-COSA/SINB
45840C...Coupling to leptons
45841 PARU(163)=PARU(161)
45842C...Coupling to Z
45843 PARU(164)=SBMA
45844C...Coupling to W
45845 PARU(165)=PARU(164)
45846
45847C...Secondly: H
45848C...Coupling to d-type quarks
45849 PARU(171)=-COSA/COSB
45850C...Coupling to u-type quarks
45851 PARU(172)=-SINA/SINB
45852C...Coupling to leptons
45853 PARU(173)=PARU(171)
45854C...Coupling to Z
45855 PARU(174)=CBMA
45856C...Coupling to W
45857 PARU(175)=PARU(174)
45858C...Coupling to h
45859 IF(IMSS(4).GE.2) THEN
45860 PARU(176)=COS(2D0*AL)*COS(BE+AL)-2D0*SIN(2D0*AL)*SIN(BE+AL)
45861 ELSE
45862 HHH(3)=HHH(3)+HHH(4)+HHH(5)
45863 PARU(176)=-3D0/HHH(1)*(HHH(1)*SINA**2*COSB*COSA+
45864 1 HHH(2)*COSA**2*SINB*SINA+HHH(3)*(SINA**3*SINB+COSA**3*COSB-
45865 2 2D0/3D0*CBMA)-HHH(6)*SINA*(COSB*C2A+COSA*CAPB)+
45866 3 HHH(7)*COSA*(SINB*C2A+SINA*CAPB))
45867 ENDIF
45868C...Coupling to H+
45869C...Define later
45870 IF(IMSS(4).GE.2) THEN
45871 PARU(168)=-SBMA-COS(2D0*BE)*SAPB/2D0/(1D0-XW)
45872 ELSE
45873 PARU(168)=1D0/HHH(1)*(HHH(1)*SINB**2*COSB*SINA-
45874 1 HHH(2)*COSB**2*SINB*COSA-HHH(3)*(SINB**3*COSA-COSB**3*SINA)+
45875 2 2D0*HHH(5)*SBMA-HHH(6)*SINB*(COSB*SAPB+SINA*C2B)-
45876 3 HHH(7)*COSB*(COSA*C2B-SINB*SAPB)-(HHH(5)-HHH(4))*SBMA)
45877 ENDIF
45878C...Coupling to A
45879 IF(IMSS(4).GE.2) THEN
45880 PARU(177)=COS(2D0*BE)*COS(BE+AL)
45881 ELSE
45882 PARU(177)=-1D0/HHH(1)*(HHH(1)*SINB**2*COSB*COSA+
45883 1 HHH(2)*COSB**2*SINB*SINA+HHH(3)*(SINB**3*SINA+COSB**3*COSA)-
45884 2 2D0*HHH(5)*CBMA-HHH(6)*SINB*(COSB*CAPB+COSA*C2B)+
45885 3 HHH(7)*COSB*(SINB*CAPB+SINA*C2B))
45886 ENDIF
45887C...Coupling to H+
45888 IF(IMSS(4).GE.2) THEN
45889 PARU(178)=PARU(177)
45890 ELSE
45891 PARU(178)=PARU(177)-(HHH(5)-HHH(4))/HHH(1)*CBMA
45892 ENDIF
45893C...Thirdly, A
45894C...Coupling to d-type quarks
45895 PARU(181)=TANB
45896C...Coupling to u-type quarks
45897 PARU(182)=1D0/PARU(181)
45898C...Coupling to leptons
45899 PARU(183)=PARU(181)
45900 PARU(184)=0D0
45901 PARU(185)=0D0
45902C...Coupling to Z h
45903 PARU(186)=COS(BE-AL)
45904C...Coupling to Z H
45905 PARU(187)=SIN(BE-AL)
45906 PARU(188)=0D0
45907 PARU(189)=0D0
45908 PARU(190)=0D0
45909
45910C...Finally: H+
45911C...Coupling to W h
45912 PARU(195)=COS(BE-AL)
45913
45914C...Tell that all Higgs couplings have been set.
45915 MSTP(4)=1
45916
45917C...Set R-Violating couplings.
45918C...Set lambda couplings to common value or "natural values".
45919 IF ((IMSS(51).NE.3).AND.(IMSS(51).NE.0)) THEN
45920 VIR3=1D0/(126D0)**3
45921 DO 200 IRK=1,3
45922 DO 190 IRI=1,3
45923 DO 180 IRJ=1,3
45924 IF (IRI.NE.IRJ) THEN
45925 IF (IRI.LT.IRJ) THEN
45926 RVLAM(IRI,IRJ,IRK)=RMSS(51)
45927 IF (IMSS(51).EQ.2) RVLAM(IRI,IRJ,IRK)=RMSS(51)*
45928 & SQRT(PMAS(9+2*IRI,1)*PMAS(9+2*IRJ,1)*
45929 & PMAS(9+2*IRK,1)*VIR3)
45930 ELSE
45931 RVLAM(IRI,IRJ,IRK)=-RVLAM(IRJ,IRI,IRK)
45932 ENDIF
45933 ELSE
45934 RVLAM(IRI,IRJ,IRK)=0D0
45935 ENDIF
45936 180 CONTINUE
45937 190 CONTINUE
45938 200 CONTINUE
45939 ENDIF
45940C...Set lambda' couplings to common value or "natural values".
45941 IF ((IMSS(52).NE.3).AND.(IMSS(52).NE.0)) THEN
45942 VIR3=1D0/(126D0)**3
45943 DO 230 IRI=1,3
45944 DO 220 IRJ=1,3
45945 DO 210 IRK=1,3
45946 RVLAMP(IRI,IRJ,IRK)=RMSS(52)
45947 IF (IMSS(52).EQ.2) RVLAMP(IRI,IRJ,IRK)=RMSS(52)*
45948 & SQRT(PMAS(9+2*IRI,1)*0.5D0*(PMAS(2*IRJ,1)+
45949 & PMAS(2*IRJ-1,1))*PMAS(2*IRK-1,1)*VIR3)
45950 210 CONTINUE
45951 220 CONTINUE
45952 230 CONTINUE
45953 ENDIF
45954C...Set lambda'' couplings to common value or "natural values".
45955 IF ((IMSS(53).NE.3).AND.(IMSS(53).NE.0)) THEN
45956 VIR3=1D0/(126D0)**3
45957 DO 260 IRI=1,3
45958 DO 250 IRJ=1,3
45959 DO 240 IRK=1,3
45960 IF (IRJ.NE.IRK) THEN
45961 IF (IRJ.LT.IRK) THEN
45962 RVLAMB(IRI,IRJ,IRK)=RMSS(53)
45963 IF (IMSS(53).EQ.2) RVLAMB(IRI,IRJ,IRK)=
45964 & RMSS(53)*SQRT(PMAS(2*IRI,1)*PMAS(2*IRJ-1,1)*
45965 & PMAS(2*IRK-1,1)*VIR3)
45966 ELSE
45967 RVLAMB(IRI,IRJ,IRK)=-RVLAMB(IRI,IRK,IRJ)
45968 ENDIF
45969 ELSE
45970 RVLAMB(IRI,IRJ,IRK) = 0D0
45971 ENDIF
45972 240 CONTINUE
45973 250 CONTINUE
45974 260 CONTINUE
45975 ENDIF
45976
45977C...Antisymmetrize couplings set by user
45978 IF (IMSS(51).EQ.3.OR.IMSS(53).EQ.3) THEN
45979 DO 290 IRI=1,3
45980 DO 280 IRJ=1,3
45981 DO 270 IRK=1,3
45982 IF (RVLAM(IRI,IRJ,IRK).NE.-RVLAM(IRJ,IRI,IRK)) THEN
45983 RVLAM(IRJ,IRI,IRK)=-RVLAM(IRI,IRJ,IRK)
45984 IF (IRI.EQ.IRJ) RVLAM(IRI,IRJ,IRK)=0D0
45985 ENDIF
45986 IF (RVLAMB(IRI,IRJ,IRK).NE.-RVLAMB(IRI,IRK,IRJ)) THEN
45987 RVLAMB(IRI,IRK,IRJ)=-RVLAMB(IRI,IRJ,IRK)
45988 IF (IRJ.EQ.IRK) RVLAMB(IRI,IRJ,IRK)=0D0
45989 ENDIF
45990 270 CONTINUE
45991 280 CONTINUE
45992 290 CONTINUE
45993 ENDIF
45994
45995C...Write spectrum to SLHA file
45996 IF (IMSS(23).NE.0) THEN
45997 IFAIL=0
45998 CALL PYSLHA(3,0,IFAIL)
45999 ENDIF
46000
46001C...Second part of routine: set decay modes and branching ratios.
46002
46003C...Allow chi10 -> gravitino + gamma or not.
46004 KC=PYCOMP(KSUSY1+39)
46005 IF( IMSS(11) .NE. 0 ) THEN
46006 PMAS(KC,1)=RMSS(21)/1D9
46007 PMAS(KC,2)=0D0
46008 IRPRTY=0
46009 WRITE(MSTU(11),*) ' ALLOWING DECAYS TO GRAVITINOS '
46010 ELSE IF (IMSS(51).GE.1.OR.IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
46011 IRPRTY=0
46012 IF (IMSS(51).GE.1) WRITE(MSTU(11),*)
46013 & ' ALLOWING SUSY LLE DECAYS'
46014 IF (IMSS(52).GE.1) WRITE(MSTU(11),*)
46015 & ' ALLOWING SUSY LQD DECAYS'
46016 IF (IMSS(53).GE.1) WRITE(MSTU(11),*)
46017 & ' ALLOWING SUSY UDD DECAYS'
46018 IF (IMSS(53).GE.1.AND.IMSS(52).GE.1) WRITE(MSTU(11),*)
46019 & ' --- Warning: R-Violating couplings possibly',
46020 & ' incompatible with proton decay'
46021 ELSE
46022 PMAS(KC,1)=9999D0
46023 IRPRTY=1
46024 ENDIF
46025
46026C...Loop over sparticle and Higgs species.
46027 PMCHI1=PMAS(PYCOMP(KSUSY1+22),1)
46028C...Find the LSP or NLSP for a gravitino LSP
46029 ILSP=0
46030 PMLSP=1D20
46031 DO 300 I=1,36
46032 KF=KFSUSY(I)
46033 IF(KF.EQ.1000039) GOTO 300
46034 KC=PYCOMP(KF)
46035 IF(PMAS(KC,1).LT.PMLSP) THEN
46036 ILSP=I
46037 PMLSP=PMAS(KC,1)
46038 ENDIF
46039 300 CONTINUE
46040 DO 370 I=1,50
46041 IF (I.GT.39.AND.IMSS(13).NE.1) GOTO 370
46042 KF=KFSUSY(I)
46043 IF (KF.EQ.0) GOTO 370
46044 KC=PYCOMP(KF)
46045 LKNT=0
46046
46047C...Check if there are any decays listed for this sparticle
46048C...in a file
46049 IF (IMSS(22).NE.0.OR.MSTP(161).NE.0) THEN
46050 IFAIL=0
46051 CALL PYSLHA(2,KF,IFAIL)
46052 IF (IFAIL.EQ.0.OR.KF.EQ.6.OR.KF.EQ.24) GOTO 370
46053 ELSEIF (I.GE.37) THEN
46054 GOTO 370
46055 ENDIF
46056
46057C...Sfermion decays.
46058 IF(I.LE.24) THEN
46059C...First check to see if sneutrino is lighter than chi10.
46060 IF((I.EQ.15.OR.I.EQ.19.OR.I.EQ.23).AND.
46061 & PMAS(KC,1).LT.PMCHI1) THEN
46062 ELSE
46063 CALL PYSFDC(KF,XLAM,IDLAM,LKNT)
46064 ENDIF
46065
46066C...Gluino decays.
46067 ELSEIF(I.EQ.25) THEN
46068 CALL PYGLUI(KF,XLAM,IDLAM,LKNT)
46069 IF(I.EQ.ILSP.AND.IRPRTY.EQ.1) LKNT=0
46070
46071C...Neutralino decays.
46072 ELSEIF(I.GE.26.AND.I.LE.29) THEN
46073 CALL PYNJDC(KF,XLAM,IDLAM,LKNT)
46074C...chi10 stable or chi10 -> gravitino + gamma.
46075 IF(I.EQ.26.AND.IRPRTY.EQ.1) THEN
46076 PMAS(KC,2)=1D-6
46077 MDCY(KC,1)=0
46078 MWID(KC)=0
46079 ENDIF
46080
46081C...Chargino decays.
46082 ELSEIF(I.GE.30.AND.I.LE.31) THEN
46083 CALL PYCJDC(KF,XLAM,IDLAM,LKNT)
46084
46085C...Gravitino is stable.
46086 ELSEIF(I.EQ.32) THEN
46087 MDCY(KC,1)=0
46088 MWID(KC)=0
46089
46090C...Higgs decays.
46091 ELSEIF(I.GE.33.AND.I.LE.36) THEN
46092C...Calculate decays to non-SUSY particles.
46093 CALL PYWIDT(KF,PMAS(KC,1)**2,WDTP,WDTE)
46094 LKNT=0
46095 DO 310 I1=0,100
46096 XLAM(I1)=0D0
46097 310 CONTINUE
46098 DO 330 I1=1,MDCY(KC,3)
46099 K1=MDCY(KC,2)+I1-1
46100 IF(IABS(KFDP(K1,1)).GT.KSUSY1.OR.
46101 & IABS(KFDP(K1,2)).GT.KSUSY1) GOTO 330
46102 XLAM(I1)=WDTP(I1)
46103 XLAM(0)=XLAM(0)+XLAM(I1)
46104 DO 320 J1=1,3
46105 IDLAM(I1,J1)=KFDP(K1,J1)
46106 320 CONTINUE
46107 LKNT=LKNT+1
46108 330 CONTINUE
46109C...Add the decays to SUSY particles.
46110 CALL PYHEXT(KF,XLAM,IDLAM,LKNT)
46111 ENDIF
46112C...Zero the branching ratios for use in loop mode
46113C...thanks to K. Matchev (FNAL)
46114 DO 340 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
46115 BRAT(IDC)=0D0
46116 340 CONTINUE
46117
46118C...Set stable particles.
46119 IF(LKNT.EQ.0) THEN
46120 MDCY(KC,1)=0
46121 MWID(KC)=0
46122 PMAS(KC,2)=1D-6
46123 PMAS(KC,3)=1D-5
46124 PMAS(KC,4)=0D0
46125
46126C...Store branching ratios in the standard tables.
46127 ELSE
46128 IDC=MDCY(KC,2)+MDCY(KC,3)-1
46129 DELM=1D6
46130 DO 360 IL=1,LKNT
46131 IDCSV=IDC
46132 350 IDC=IDC+1
46133 BRAT(IDC)=0D0
46134 IF(IDC.EQ.MDCY(KC,2)+MDCY(KC,3)) IDC=MDCY(KC,2)
46135 IF(IDLAM(IL,1).EQ.KFDP(IDC,1).AND.IDLAM(IL,2).EQ.
46136 & KFDP(IDC,2).AND.IDLAM(IL,3).EQ.KFDP(IDC,3)) THEN
46137 BRAT(IDC)=XLAM(IL)/XLAM(0)
46138 XMDIF=PMAS(KC,1)
46139 IF(MDME(IDC,1).GE.1) THEN
46140 XMDIF=XMDIF-PMAS(PYCOMP(KFDP(IDC,1)),1)-
46141 & PMAS(PYCOMP(KFDP(IDC,2)),1)
46142 IF(KFDP(IDC,3).NE.0) XMDIF=XMDIF-
46143 & PMAS(PYCOMP(KFDP(IDC,3)),1)
46144 ENDIF
46145 IF(I.LE.32) THEN
46146 IF(XMDIF.GE.0D0) THEN
46147 DELM=MIN(DELM,XMDIF)
46148 ELSE
46149 WRITE(MSTU(11),*) ' ERROR WITH DELM ',DELM,XMDIF
46150 WRITE(MSTU(11),*) ' KF = ',KF
46151 WRITE(MSTU(11),*) ' KF(decay) = ',(KFDP(IDC,J),J=1,3)
46152 ENDIF
46153 ENDIF
46154 GOTO 360
46155 ELSEIF(IDC.EQ.IDCSV) THEN
46156 WRITE(MSTU(11),*) ' Error in PYMSIN: SUSY decay ',
46157 & 'channel not recognized:'
46158 WRITE(MSTU(11),*) KF,' -> ',(IDLAM(IL,J),J=1,3)
46159 GOTO 360
46160 ELSE
46161 GOTO 350
46162 ENDIF
46163 360 CONTINUE
46164
46165C...Store width, cutoff and lifetime.
46166 PMAS(KC,2)=XLAM(0)
46167 IF(PMAS(KC,2).LT.0.1D0*DELM) THEN
46168 PMAS(KC,3)=PMAS(KC,2)*10D0
46169 ELSE
46170 PMAS(KC,3)=0.95D0*DELM
46171 ENDIF
46172 IF(PMAS(KC,2).NE.0D0) THEN
46173 PMAS(KC,4)=PARU(3)/PMAS(KC,2)*1D-12
46174 ENDIF
46175C...Write decays to SLHA file
46176 IF (IMSS(24).NE.0) THEN
46177 IFAIL=0
46178 CALL PYSLHA(4,KF,IFAIL)
46179 ENDIF
46180
46181 ENDIF
46182 370 CONTINUE
46183
46184 RETURN
46185 END
46186C*********************************************************************
46187
46188C...PYSLHA
46189C...Read/write spectrum or decay data from SLHA standard file(s).
46190C...P. Skands
46191C...DECAY TABLE writeout by Nils-Erik Bomark (2010)
46192
46193C...MUPDA=0 : READ QNUMBERS/PARTICLE ON LUN=IMSS(21)
46194C...MUPDA=1 : READ SLHA SPECTRUM ON LUN=IMSS(21)
46195C...MUPDA=2 : LOOK FOR DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(22)
46196C... (KFORIG=0 : read all decay tables)
46197C...MUPDA=3 : WRITE SPECTRUM ON LUN=IMSS(23)
46198C...MUPDA=4 : WRITE DECAY TABLE FOR KF=KFORIG ON LUN=IMSS(24)
46199C...MUPDA=5 : READ MASS FOR KF=KFORIG ONLY
46200C... (KFORIG=0 : read all MASS entries)
46201
46202 SUBROUTINE PYSLHA(MUPDA,KFORIG,IRETRN)
46203
46204C...Double precision and integer declarations.
46205 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
46206 IMPLICIT INTEGER(I-N)
46207 INTEGER PYK,PYCHGE,PYCOMP
46208 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
46209 &KEXCIT=4000000,KDIMEN=5000000)
46210C...Commonblocks.
46211 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
46212 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
46213 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
46214 COMMON/PYDAT4/CHAF(500,2)
46215 CHARACTER CHAF*16
46216 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
46217 CHARACTER*40 ISAVER,VISAJE
46218 COMMON/PYINT4/MWID(500),WIDS(500,5)
46219 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYPARS/,/PYINT4/
46220C...SUSY blocks
46221 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
46222 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
46223 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
46224 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
46225 SAVE /PYMSSM/,/PYSSMT/,/PYMSRV/
46226
46227C...Local arrays, character variables and data.
46228 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
46229 & AU(3,3),AD(3,3),AE(3,3)
46230 COMMON/PYLH3C/CPRO(2),CVER(2)
46231C...The common block of new states (QNUMBERS / PARTICLE)
46232 COMMON/PYQNUM/NQNUM,NQDUM,KQNUM(500,0:9)
46233C...- NQNUM : Number of QNUMBERS blocks that have been read in
46234C...- KQNUM(I,0) : KF of new state
46235C...- KQNUM(I,1) : 3 times electric charge
46236C...- KQNUM(I,2) : Number of spin states: (2S + 1)
46237C...- KQNUM(I,3) : Colour rep (1: singlet, 3: triplet, 8: octet)
46238C...- KQNUM(I,4) : Particle/Antiparticle distinction (0=own anti)
46239C...- KQNUM(I,5:9) : space available for further quantum numbers
46240 DIMENSION MMOD(100),MSPC(100),KFDEC(100)
46241 SAVE /PYLH3P/,/PYLH3C/,/PYQNUM/,MMOD,MSPC,KFDEC
46242C...MMOD: flags to set for each block read in.
46243C... 1: MODSEL 2: MINPAR 3: EXTPAR 4: SMINPUTS
46244C...MSPC: Flags to set for each block read in.
46245C... 1: MASS 2: NMIX 3: UMIX 4: VMIX 5: SBOTMIX
46246C... 6: STOPMIX 7: STAUMIX 8: HMIX 9: GAUGE 10: AU
46247C...11: AD 12: AE 13: YU 14: YD 15: YE
46248C...16: SPINFO 17: ALPHA 18: MSOFT 19: QNUMBERS
46249 CHARACTER CPRO*12,CVER*12,CHNLIN*6
46250 CHARACTER DOC*11, CHDUM*120, CHBLCK*60
46251 CHARACTER CHINL*120,CHKF*9,CHTMP*16
46252 INTEGER VERBOS
46253 SAVE VERBOS
46254C...Date of last Change
46255 PARAMETER (DOC='10 Jun 2010')
46256C...Local arrays and initial values
46257 DIMENSION IDC(5),KFSUSY(50)
46258 SAVE KFSUSY
46259 DATA NQNUM /0/
46260 DATA NDECAY /0/
46261 DATA VERBOS /1/
46262 DATA NHELLO /0/
46263 DATA MLHEF /0/
46264 DATA MLHEFD /0/
46265 DATA KFSUSY/
46266 &1000001,1000002,1000003,1000004,1000005,1000006,
46267 &2000001,2000002,2000003,2000004,2000005,2000006,
46268 &1000011,1000012,1000013,1000014,1000015,1000016,
46269 &2000011,2000012,2000013,2000014,2000015,2000016,
46270 &1000021,1000022,1000023,1000025,1000035,1000024,
46271 &1000037,1000039, 25, 35, 36, 37,
46272 & 6, 24, 45, 46,1000045, 9*0/
46273 DATA KFDEC/100*0/
46274 RMFUN(IP)=PMAS(PYCOMP(IP),1)
46275
46276C...Shorthand for spectrum and decay table unit numbers
46277 IMSS21=IMSS(21)
46278 IMSS22=IMSS(22)
46279
46280C...Default for LHEF input: read header information
46281 IF (IMSS21.EQ.0.AND.MSTP(161).NE.0) IMSS21=MSTP(161)
46282 IF (IMSS22.EQ.0.AND.MSTP(161).NE.0) IMSS22=MSTP(161)
46283 IF (IMSS21.EQ.MSTP(161).AND.IMSS21.NE.0) MLHEF=1
46284 IF (IMSS22.EQ.MSTP(161).AND.IMSS22.NE.0) MLHEFD=1
46285
46286C...Hello World
46287 IF (NHELLO.EQ.0) THEN
46288 IF ((MLHEF.NE.1.AND.MLHEFD.NE.1).OR.(IMSS(1).NE.0)) THEN
46289 WRITE(MSTU(11),5000) DOC
46290 NHELLO=1
46291 ENDIF
46292 ENDIF
46293
46294C...SLHA file assumed opened by user on unit LFN, stored in IMSS(20
46295C...+MUPDA).
46296 LFN=IMSS21
46297 IF (MUPDA.EQ.2) LFN=IMSS22
46298 IF (MUPDA.EQ.3) LFN=IMSS(23)
46299 IF (MUPDA.EQ.4) LFN=IMSS(24)
46300C...Flag that we have not yet found whatever we were asked to find.
46301 IRETRN=1
46302C...Flag that we are skipping until <slha> tag found (if LHEF)
46303 ISKIP=0
46304 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) ISKIP=1
46305
46306C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
46307 IF (LFN.EQ.0) THEN
46308 WRITE(MSTU(11),*) '* (PYSLHA:) No valid unit given in IMSS'
46309 GOTO 9999
46310 ENDIF
46311
46312C...If reading LHEF header, start by rewinding file
46313 IF (MLHEF.EQ.1.OR.MLHEFD.EQ.1) REWIND(LFN)
46314
46315C...If told to read spectrum, first zero all previous information.
46316 IF (MUPDA.EQ.1) THEN
46317C...Zero all block read flags
46318 DO 100 M=1,100
46319 MMOD(M)=0
46320 MSPC(M)=0
46321 100 CONTINUE
46322C...Zero all (MSSM) masses, widths, and lifetimes in PYTHIA
46323 DO 110 ISUSY=1,36
46324 KC=PYCOMP(KFSUSY(ISUSY))
46325 PMAS(KC,1)=0D0
46326 110 CONTINUE
46327C...Zero all (3rd gen sfermion + gaugino/higgsino) mixing matrices.
46328 DO 130 J=1,4
46329 SFMIX(5,J) =0D0
46330 SFMIX(6,J) =0D0
46331 SFMIX(15,J)=0D0
46332 DO 120 L=1,4
46333 ZMIX(L,J) =0D0
46334 ZMIXI(L,J)=0D0
46335 IF (J.LE.2.AND.L.LE.2) THEN
46336 UMIX(L,J) =0D0
46337 UMIXI(L,J)=0D0
46338 VMIX(L,J) =0D0
46339 VMIXI(L,J)=0D0
46340 ENDIF
46341 120 CONTINUE
46342C...Zero signed masses.
46343 SMZ(J)=0D0
46344 IF (J.LE.2) SMW(J)=0D0
46345 130 CONTINUE
46346
46347C...If reading decays, reset PYTHIA decay counters.
46348 ELSEIF (MUPDA.EQ.2) THEN
46349C...Check if DECAY for this KF already read
46350 IF (KFORIG.NE.0) THEN
46351 DO 140 IDEC=1,NDECAY
46352 IF (KFORIG.EQ.KFDEC(IDEC)) THEN
46353 IRETRN=0
46354 RETURN
46355 ENDIF
46356 140 CONTINUE
46357 ENDIF
46358 KCC=100
46359 NDC=0
46360 BRSUM=0D0
46361 DO 150 KC=1,MSTU(6)
46362 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
46363 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
46364 150 CONTINUE
46365 ELSEIF (MUPDA.EQ.5) THEN
46366C...Zero block read flags
46367 DO 160 M=1,100
46368 MSPC(M)=0
46369 160 CONTINUE
46370 ENDIF
46371
46372C............READ
46373C...(QNUMBERS, spectrum, or decays of KF=KFORIG or MASS of KF=KFORIG)
46374 IF(MUPDA.EQ.0.OR.MUPDA.EQ.1.OR.MUPDA.EQ.2.OR.MUPDA.EQ.5) THEN
46375C...Initialize program and version strings
46376 IF(MUPDA.EQ.1.OR.MUPDA.EQ.2) THEN
46377 CPRO(MUPDA)=' '
46378 CVER(MUPDA)=' '
46379 ENDIF
46380
46381C...Initialize read loop
46382 MERR=0
46383 NLINE=0
46384 CHBLCK=' '
46385C...READ NEW LINE INTO CHINL. GOTO 300 AT END-OF-FILE.
46386 170 CHINL=' '
46387 READ(LFN,'(A120)',END=400) CHINL
46388C...Count which line number we're at.
46389 NLINE=NLINE+1
46390 WRITE(CHNLIN,'(I6)') NLINE
46391
46392C...Skip comment and empty lines without processing.
46393 IF (CHINL(1:1).EQ.'#'.OR.CHINL.EQ.' ') GOTO 170
46394
46395C...We assume all upper case below. Rewrite CHINL to all upper case.
46396 INL=0
46397 IGOOD=0
46398 180 INL=INL+1
46399 IF (CHINL(INL:INL).NE.'#') THEN
46400 DO 190 ICH=97,122
46401 IF (CHAR(ICH).EQ.CHINL(INL:INL)) CHINL(INL:INL)=CHAR(ICH-32)
46402 190 CONTINUE
46403C...Extra safety. Chek for sensible input on line
46404 IF (IGOOD.EQ.0) THEN
46405 DO 200 ICH=48,90
46406 IF (CHAR(ICH).EQ.CHINL(INL:INL)) IGOOD=1
46407 200 CONTINUE
46408 ENDIF
46409 IF (INL.LT.120) GOTO 180
46410 ENDIF
46411 IF (IGOOD.EQ.0) GOTO 170
46412
46413C...If reading from LHEF file, skip until <slha> begin tag found
46414 IF (ISKIP.NE.0) THEN
46415 DO 205 I1=1,10
46416 IF (CHINL(I1:I1+4).EQ.'<SLHA') ISKIP=0
46417 205 CONTINUE
46418 IF (ISKIP.NE.0) GOTO 170
46419 ENDIF
46420
46421C...Exit when </slha>, <init>, or first <event> tag reached in LHEF file
46422 DO 210 I1=1,10
46423 IF (CHINL(I1:I1+5).EQ.'</SLHA'
46424 & .OR.CHINL(I1:I1+5).EQ.'<EVENT'
46425 & .OR.CHINL(I1:I1+4).EQ.'<INIT') THEN
46426 REWIND(LFN)
46427 GOTO 400
46428 ENDIF
46429 210 CONTINUE
46430
46431C...Check for BLOCK begin statement (spectrum).
46432 IF (CHINL(1:5).EQ.'BLOCK') THEN
46433 MERR=0
46434 READ(CHINL,'(A6,A)',ERR=580) CHDUM,CHBLCK
46435C...Check if another of this type of block was already read.
46436C...(logarithmic interpolation not yet implemented, so duplicates always
46437C...give errors)
46438 IF (CHBLCK(1:6).EQ.'MODSEL'.AND.MMOD(1).NE.0) MERR=7
46439 IF (CHBLCK(1:6).EQ.'MINPAR'.AND.MMOD(2).NE.0) MERR=7
46440 IF (CHBLCK(1:6).EQ.'EXTPAR'.AND.MMOD(3).NE.0) MERR=7
46441 IF (CHBLCK(1:8).EQ.'SMINPUTS'.AND.MMOD(4).NE.0) MERR=7
46442 IF (CHBLCK(1:4).EQ.'MASS'.AND.MSPC(1).NE.0) MERR=7
46443 IF (CHBLCK(1:4).EQ.'NMIX'.AND.MSPC(2).NE.0) MERR=7
46444 IF (CHBLCK(1:4).EQ.'UMIX'.AND.MSPC(3).NE.0) MERR=7
46445 IF (CHBLCK(1:4).EQ.'VMIX'.AND.MSPC(4).NE.0) MERR=7
46446 IF (CHBLCK(1:7).EQ.'SBOTMIX'.AND.MSPC(5).NE.0) MERR=7
46447 IF (CHBLCK(1:7).EQ.'STOPMIX'.AND.MSPC(6).NE.0) MERR=7
46448 IF (CHBLCK(1:7).EQ.'STAUMIX'.AND.MSPC(7).NE.0) MERR=7
46449 IF (CHBLCK(1:4).EQ.'HMIX'.AND.MSPC(8).NE.0) MERR=7
46450 IF (CHBLCK(1:5).EQ.'ALPHA'.AND.MSPC(17).NE.0) MERR=7
46451 IF (CHBLCK(1:5).EQ.'AU'.AND.MSPC(10).NE.0) MERR=7
46452 IF (CHBLCK(1:5).EQ.'AD'.AND.MSPC(11).NE.0) MERR=7
46453 IF (CHBLCK(1:5).EQ.'AE'.AND.MSPC(12).NE.0) MERR=7
46454 IF (CHBLCK(1:5).EQ.'MSOFT'.AND.MSPC(18).NE.0) MERR=7
46455C...Check for new particles
46456 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
46457 & THEN
46458 MSPC(19)=MSPC(19)+1
46459C...Read PDG code
46460 READ(CHBLCK(9:60),*) KFQ
46461
46462 DO 220 MQ=1,NQNUM
46463 IF (KQNUM(MQ,0).EQ.KFQ) THEN
46464 MERR=17
46465 GOTO 380
46466 ENDIF
46467 220 CONTINUE
46468 IF (NHELLO.EQ.0) THEN
46469 WRITE(MSTU(11),5000) DOC
46470 NHELLO=1
46471 ENDIF
46472 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46473 & ' * (PYSLHA:) Reading '//CHBLCK(1:8)//
46474 & ' for KF =',KFQ
46475 NQNUM=NQNUM+1
46476 KQNUM(NQNUM,0)=KFQ
46477 MSPC(19)=MSPC(19)+1
46478 KCQ=PYCOMP(KFQ)
46479C...Only read in new codes (also OK to overwrite if KF > 3000000)
46480 IF (KCQ.EQ.0.OR.IABS(KFQ).GE.3000000) THEN
46481 IF (KCQ.EQ.0) THEN
46482 DO 230 KCT=100,MSTU(6)
46483 IF(KCHG(KCT,4).GT.100) KCQ=KCT
46484 230 CONTINUE
46485 KCQ=KCQ+1
46486 ENDIF
46487 KCC=KCQ
46488 KCHG(KCQ,4)=KFQ
46489C...First write PDG code as name
46490 WRITE(CHTMP,*) KFQ
46491 WRITE(CHTMP,'(A)') CHTMP(2:10)
46492C...Then look for real name
46493 IBEG=9
46494 240 IBEG=IBEG+1
46495 IF (CHBLCK(IBEG:IBEG).NE.'#'.AND.IBEG.LT.59) GOTO 240
46496 250 IBEG=IBEG+1
46497 IF (CHBLCK(IBEG:IBEG).EQ.' '.AND.IBEG.LT.59) GOTO 250
46498 IEND=IBEG-1
46499 260 IEND=IEND+1
46500 IF (CHBLCK(IEND+1:IEND+1).NE.' '.AND.IEND.LT.59) GOTO 260
46501 IF (IEND.LT.59) THEN
46502 READ(CHBLCK(IBEG:IEND),'(A)',ERR=270) CHDUM
46503 IF (CHDUM.NE.' ') CHTMP=CHDUM
46504 ENDIF
46505 270 READ(CHTMP,'(A)') CHAF(KCQ,1)
46506 MSTU(20)=0
46507C...Set stable for now
46508 PMAS(KCQ,2)=1D-6
46509 MWID(KCQ)=0
46510 MDCY(KCQ,1)=0
46511 MDCY(KCQ,2)=0
46512 MDCY(KCQ,3)=0
46513 ELSE
46514 WRITE(MSTU(11),*)
46515 & '* (PYSLHA:) KF =',KFQ,' already exists: ',
46516 & CHAF(KCQ,1), '. Entry ignored.'
46517 MERR=7
46518 ENDIF
46519 ENDIF
46520C...Finalize this line and read next.
46521 GOTO 380
46522C...Check for DECAY begin statement (decays).
46523 ELSEIF (CHINL(1:3).EQ.'DEC') THEN
46524 MERR=0
46525 BRSUM=0D0
46526 CHBLCK='DECAY'
46527C...Read KF code and WIDTH
46528 MPSIGN=1
46529 READ(CHINL(7:INL),*,ERR=590) KF, WIDTH
46530 IF (KF.LE.0) THEN
46531 KF=-KF
46532 MPSIGN=-1
46533 ENDIF
46534C...If this is not the KF we're looking for...
46535 IF ((KFORIG.NE.0.AND.KF.NE.KFORIG).OR.MUPDA.NE.2) THEN
46536C...Set block skip flag and read next line.
46537 MERR=16
46538 GOTO 380
46539 ELSE
46540C...Check whether decay table for this particle already read in
46541 DO 280 IDECAY=1,NDECAY
46542 IF (KFDEC(IDECAY).EQ.KF) THEN
46543 WRITE(MSTU(11),'(A,A,I9,A,A6,A)')
46544 & ' * (PYSLHA:) Ignoring DECAY table ',
46545 & 'for KF =',KF,' on line ',CHNLIN,
46546 & ' (duplicate)'
46547 MERR=16
46548 GOTO 380
46549 ENDIF
46550 280 CONTINUE
46551 ENDIF
46552
46553C...Determine PYTHIA KC code of particle
46554 KCREP=0
46555 IF(KF.LE.100) THEN
46556 KCREP=KF
46557 ELSE
46558 DO 290 KCR=101,KCC
46559 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
46560 290 CONTINUE
46561 ENDIF
46562 KC=KCREP
46563 IF (KCREP.NE.0) THEN
46564C...Particle is already known. Do not overwrite low-mass SM particles,
46565C...since this could give problems at hadronization / hadron decay stage.
46566 IF (IABS(KF).LT.1000000.AND.PMAS(KC,1).LT.20D0) THEN
46567C...Set block skip flag and read next line
46568 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46569 & ' * (PYSLHA:) Ignoring DECAY table for KF =',
46570 & KF, ' (SLHA read-in not allowed)'
46571 MERR=16
46572 GOTO 380
46573 ELSEIF (IABS(KF).EQ.6.OR.IABS(KF).EQ.23.OR.IABS(KF).EQ.24)
46574 & THEN
46575C...Set block skip flag and read next line
46576 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46577 & ' * (PYSLHA:) Allowing DECAY table for KF =',
46578 & KF, ' but this is NOT recommended.'
46579 ENDIF
46580 ELSE
46581C... Add new particle. Actually, this should not happen.
46582C... New particles should be added already when reading the spectrum
46583C... information, so go under previously stable category.
46584 KCC=KCC+1
46585 KC=KCC
46586 ENDIF
46587
46588 IF (WIDTH.LE.0D0) THEN
46589C...Stable (i.e. LSP)
46590 WRITE(MSTU(11),'(A,I9,A,A)')
46591 & ' * (PYSLHA:) Reading SLHA stable particle KF =',
46592 & KF,', ',CHAF(KCREP,1)(1:16)
46593 IF (WIDTH.LT.0D0) THEN
46594 CALL PYERRM(19,'(PYSLHA:) Negative width forced to'//
46595 & ' zero !')
46596 WIDTH=0D0
46597 ENDIF
46598 PMAS(KC,2)=1D-6
46599 MWID(KC)=0
46600 MDCY(KC,1)=0
46601C...Ignore any decay lines that may be present for this KF
46602 MERR=16
46603 MDCY(KC,2)=0
46604 MDCY(KC,3)=0
46605C...Return ok
46606 IRETRN=0
46607 ENDIF
46608C...Finalize and start reading in decay modes.
46609 GOTO 380
46610 ELSEIF (MOD(MERR,10).GE.6) THEN
46611C...If ignore block flag set, skip directly to next line.
46612 GOTO 170
46613 ENDIF
46614
46615C...READ SPECTRUM
46616 IF (MUPDA.EQ.0.AND.MERR.EQ.0) THEN
46617 IF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.CHBLCK(1:8).EQ.'PARTICLE')
46618 & THEN
46619 READ(CHINL,*) INDX, IVAL
46620 IF (INDX.GE.1.AND.INDX.LE.9) KQNUM(NQNUM,INDX)=IVAL
46621 IF (INDX.EQ.1) KCHG(KCQ,1)=IVAL
46622 IF (INDX.EQ.3) KCHG(KCQ,2)=0
46623 IF (INDX.EQ.3.AND.IVAL.EQ.3) KCHG(KCQ,2)=1
46624 IF (INDX.EQ.3.AND.IVAL.EQ.-3) KCHG(KCQ,2)=-1
46625 IF (INDX.EQ.3.AND.IVAL.EQ.8) KCHG(KCQ,2)=2
46626 IF (INDX.EQ.4) THEN
46627 KCHG(KCQ,3)=IVAL
46628 IF (IVAL.EQ.1) THEN
46629 CHTMP=CHAF(KCQ,1)
46630 IF (CHTMP.EQ.' ') THEN
46631 WRITE(CHAF(KCQ,1),*) KCHG(KCQ,4)
46632 WRITE(CHAF(KCQ,2),*) -KCHG(KCQ,4)
46633 ELSE
46634 ILAST=17
46635 300 ILAST=ILAST-1
46636 IF (CHTMP(ILAST:ILAST).EQ.' ') GOTO 300
46637 IF (CHTMP(ILAST:ILAST).EQ.'+') THEN
46638 CHTMP(ILAST:ILAST)='-'
46639 ELSE
46640 CHTMP(ILAST+1:MIN(16,ILAST+4))='bar'
46641 ENDIF
46642 CHAF(KCQ,2)=CHTMP
46643 ENDIF
46644 ENDIF
46645 ENDIF
46646 ELSE
46647 MERR=8
46648 ENDIF
46649 ELSEIF ((MUPDA.EQ.1.OR.MUPDA.EQ.5).AND.MERR.EQ.0) THEN
46650C...MASS: Mass spectrum
46651 IF (CHBLCK(1:4).EQ.'MASS') THEN
46652 READ(CHINL,*) KF, VAL
46653 MERR=1
46654 KC=0
46655 IF (MUPDA.EQ.1.OR.KF.EQ.KFORIG.OR.KFORIG.EQ.0) THEN
46656C...Read in masses for almost anything
46657 MERR=0
46658 KC=PYCOMP(KF)
46659 IF (KC.NE.0) THEN
46660C...Don't read in masses for special code particles
46661 IF (IABS(KF).GE.80.AND.IABS(KF).LT.100) THEN
46662 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46663 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
46664 & KF, ' (KF reserved by PYTHIA)'
46665 GOTO 170
46666 ENDIF
46667C...Be careful with light SM particles / hadrons
46668 IF (PMAS(KC,1).LE.20D0) THEN
46669 IF (IABS(KF).LE.22) THEN
46670 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46671 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
46672 & KF, ' (SLHA read-in not allowed)'
46673
46674 GOTO 170
46675 ELSEIF (IABS(KF).GE.100.AND.IABS(KF).LT.1000000) THEN
46676 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46677 & ' * (PYSLHA:) Ignoring MASS entry for KF =',
46678 & KF, ' (SLHA read-in not allowed)'
46679 GOTO 170
46680 ENDIF
46681 ENDIF
46682 MSPC(1)=MSPC(1)+1
46683 PMAS(KC,1) = ABS(VAL)
46684 IF (MUPDA.EQ.5.AND.IMSS(1).EQ.0) THEN
46685 WRITE(MSTU(11),'(A,I9,A,F12.3)')
46686 & ' * (PYSLHA:) Reading MASS entry for KF =',
46687 & KF, ', pole mass =', VAL
46688 IRETRN=0
46689 ENDIF
46690C...Check Z, W and top masses
46691 IF (KF.EQ.23.AND.ABS(PMAS(PYCOMP(23),1)-91.2D0).GT.1D0)
46692 & THEN
46693 WRITE(CHTMP,8500) PMAS(PYCOMP(23),1)
46694 CALL PYERRM(9,'(PYSLHA:) Note Z boson mass, M ='
46695 & //CHTMP)
46696 ENDIF
46697 IF (KF.EQ.24.AND.ABS(PMAS(PYCOMP(24),1)-80.4D0).GT.1D0)
46698 & THEN
46699 WRITE(CHTMP,8500) PMAS(PYCOMP(24),1)
46700 CALL PYERRM(9,'(PYSLHA:) Note W boson mass, M ='
46701 & //CHTMP)
46702 ENDIF
46703 IF (KF.EQ.6.AND.ABS(PMAS(PYCOMP(6),1)-175D0).GT.25D0)
46704 & THEN
46705 WRITE(CHTMP,8500) PMAS(PYCOMP(6),1)
46706 CALL PYERRM(9,'(PYSLHA:) Note top quark mass, M ='
46707 & //CHTMP//'GeV')
46708 ENDIF
46709C... Signed masses
46710 IF (KF.EQ.1000021.AND.MSPC(18).EQ.0) RMSS(3)=VAL
46711 IF (KF.EQ.1000022) SMZ(1)=VAL
46712 IF (KF.EQ.1000023) SMZ(2)=VAL
46713 IF (KF.EQ.1000025) SMZ(3)=VAL
46714 IF (KF.EQ.1000035) SMZ(4)=VAL
46715 IF (KF.EQ.1000024) SMW(1)=VAL
46716 IF (KF.EQ.1000037) SMW(2)=VAL
46717 ENDIF
46718 ELSEIF (MUPDA.EQ.5) THEN
46719 MERR=0
46720 ENDIF
46721C... MODSEL: Model selection and global switches
46722 ELSEIF (CHBLCK(1:6).EQ.'MODSEL') THEN
46723 READ(CHINL,*) INDX, IVAL
46724 IF (INDX.LE.200.AND.INDX.GT.0) THEN
46725 IF (IMSS(1).EQ.0) IMSS(1)=11
46726 MODSEL(INDX)=IVAL
46727 MMOD(1)=MMOD(1)+1
46728 IF (INDX.EQ.3.AND.IVAL.EQ.1.AND.PYCOMP(1000045).EQ.0) THEN
46729C... Switch on NMSSM
46730 WRITE(MSTU(11),*) '* (PYSLHA:) switching on NMSSM'
46731 IMSS(13)=MAX(1,IMSS(13))
46732C... Add NMSSM states if not already done
46733
46734 KFN=25
46735 KCN=KFN
46736 CHAF(KCN,1)='h_10'
46737 CHAF(KCN,2)=' '
46738
46739 KFN=35
46740 KCN=KFN
46741 CHAF(KCN,1)='h_20'
46742 CHAF(KCN,2)=' '
46743
46744 KFN=45
46745 KCN=KFN
46746 CHAF(KCN,1)='h_30'
46747 CHAF(KCN,2)=' '
46748
46749 KFN=36
46750 KCN=KFN
46751 CHAF(KCN,1)='A_10'
46752 CHAF(KCN,2)=' '
46753
46754 KFN=46
46755 KCN=KFN
46756 CHAF(KCN,1)='A_20'
46757 CHAF(KCN,2)=' '
46758
46759 KFN=1000045
46760 KCN=PYCOMP(KFN)
46761 IF (KCN.EQ.0) THEN
46762 DO 310 KCT=100,MSTU(6)
46763 IF(KCHG(KCT,4).GT.100) KCN=KCT
46764 310 CONTINUE
46765 KCN=KCN+1
46766 KCHG(KCN,4)=KFN
46767 MSTU(20)=0
46768 ENDIF
46769C... Set stable for now
46770 PMAS(KCN,2)=1D-6
46771 MWID(KCN)=0
46772 MDCY(KCN,1)=0
46773 MDCY(KCN,2)=0
46774 MDCY(KCN,3)=0
46775 CHAF(KCN,1)='~chi_50'
46776 CHAF(KCN,2)=' '
46777 ENDIF
46778 ELSE
46779 MERR=1
46780 ENDIF
46781 ELSEIF (MUPDA.EQ.5) THEN
46782C...If MUPDA = 5, skip all except MASS, return if MODSEL
46783 MERR=8
46784 ELSEIF (CHBLCK(1:8).EQ.'QNUMBERS'.OR.
46785 & CHBLCK(1:8).EQ.'PARTICLE') THEN
46786C...Don't print a warning for QNUMBERS when reading spectrum
46787 MERR=8
46788C...MINPAR: Minimal model parameters
46789 ELSEIF (CHBLCK(1:6).EQ.'MINPAR') THEN
46790 READ(CHINL,*) INDX, VAL
46791 IF (INDX.LE.100.AND.INDX.GT.0) THEN
46792 PARMIN(INDX)=VAL
46793 MMOD(2)=MMOD(2)+1
46794 ELSE
46795 MERR=1
46796 ENDIF
46797 IF (MMOD(3).NE.0) THEN
46798 WRITE(MSTU(11),*)
46799 & '* (PYSLHA:) MINPAR should come before EXTPAR !'
46800 MERR=1
46801 ENDIF
46802C...tan(beta)
46803 IF (INDX.EQ.3) RMSS(5)=VAL
46804C...EXTPAR: non-minimal model parameters.
46805 ELSEIF (CHBLCK(1:6).EQ.'EXTPAR') THEN
46806 IF (MMOD(1).NE.0) THEN
46807 READ(CHINL,*) INDX, VAL
46808 IF (INDX.LE.200.AND.INDX.GT.0) THEN
46809 PAREXT(INDX)=VAL
46810 MMOD(3)=MMOD(3)+1
46811 ELSE
46812 MERR=1
46813 ENDIF
46814 ELSE
46815 WRITE(MSTU(11),*)
46816 & '* (PYSLHA:) Reading EXTPAR, but no MODSEL !'
46817 MERR=1
46818 ENDIF
46819C...tan(beta)
46820 IF (INDX.EQ.25) RMSS(5)=VAL
46821 ELSEIF (CHBLCK(1:8).EQ.'SMINPUTS') THEN
46822 READ(CHINL,*) INDX, VAL
46823 IF (INDX.LE.3.OR.INDX.EQ.5.OR.INDX.GE.7) THEN
46824 MERR=1
46825 ELSEIF (INDX.EQ.4) THEN
46826 PMAS(PYCOMP(23),1)=VAL
46827 ELSEIF (INDX.EQ.6) THEN
46828 PMAS(PYCOMP(6),1)=VAL
46829 ENDIF
46830 ELSEIF (CHBLCK(1:4).EQ.'NMIX'.OR.CHBLCK(1:4).EQ.'VMIX'.OR
46831 $ .CHBLCK(1:4).EQ.'UMIX'.OR.CHBLCK(1:7).EQ.'STOPMIX'.OR
46832 $ .CHBLCK(1:7).EQ.'SBOTMIX'.OR.CHBLCK(1:7).EQ.'STAUMIX')
46833 $ THEN
46834C...NMIX,UMIX,VMIX,STOPMIX,SBOTMIX, and STAUMIX. Mixing.
46835 IM=0
46836 IF (CHBLCK(5:6).EQ.'IM') IM=1
46837 320 READ(CHINL,*) INDX1, INDX2, VAL
46838 IF (CHBLCK(1:1).EQ.'N'.AND.INDX1.LE.4.AND.INDX2.LE.4) THEN
46839 IF (IM.EQ.0) ZMIX(INDX1,INDX2) = VAL
46840 IF (IM.EQ.1) ZMIXI(INDX1,INDX2)= VAL
46841 MSPC(2)=MSPC(2)+1
46842 ELSEIF (CHBLCK(1:1).EQ.'U') THEN
46843 IF (IM.EQ.0) UMIX(INDX1,INDX2) = VAL
46844 IF (IM.EQ.1) UMIXI(INDX1,INDX2)= VAL
46845 MSPC(3)=MSPC(3)+1
46846 ELSEIF (CHBLCK(1:1).EQ.'V') THEN
46847 IF (IM.EQ.0) VMIX(INDX1,INDX2) = VAL
46848 IF (IM.EQ.1) VMIXI(INDX1,INDX2)= VAL
46849 MSPC(4)=MSPC(4)+1
46850 ELSEIF (CHBLCK(1:4).EQ.'STOP'.OR.CHBLCK(1:4).EQ.'SBOT'.OR
46851 $ .CHBLCK(1:4).EQ.'STAU') THEN
46852 IF (CHBLCK(1:4).EQ.'STOP') THEN
46853 KFSM=6
46854 ISPC=6
46855 ELSEIF (CHBLCK(1:4).EQ.'SBOT') THEN
46856 KFSM=5
46857 ISPC=5
46858 ELSEIF (CHBLCK(1:4).EQ.'STAU') THEN
46859 KFSM=15
46860 ISPC=7
46861 ENDIF
46862C...Set SFMIX element
46863 SFMIX(KFSM,2*(INDX1-1)+INDX2)=VAL
46864 MSPC(ISPC)=MSPC(ISPC)+1
46865 ENDIF
46866C...Running parameters
46867 ELSEIF (CHBLCK(1:4).EQ.'HMIX') THEN
46868 READ(CHBLCK(8:25),*,ERR=620) Q
46869 READ(CHINL,*) INDX, VAL
46870 MSPC(8)=MSPC(8)+1
46871 IF (INDX.EQ.1) THEN
46872 RMSS(4) = VAL
46873 ELSE
46874 MERR=1
46875 MSPC(8)=MSPC(8)-1
46876 ENDIF
46877 ELSEIF (CHBLCK(1:5).EQ.'ALPHA') THEN
46878 READ(CHINL,*,ERR=630) VAL
46879 RMSS(18)= VAL
46880 MSPC(17)=MSPC(17)+1
46881C...Higgs parameters set manually or with FeynHiggs.
46882 IMSS(4)=MAX(2,IMSS(4))
46883 ELSEIF (CHBLCK(1:2).EQ.'AU'.OR.CHBLCK(1:2).EQ.'AD'.OR
46884 & .CHBLCK(1:2).EQ.'AE') THEN
46885 READ(CHBLCK(9:26),*,ERR=620) Q
46886 READ(CHINL,*) INDX1, INDX2, VAL
46887 IF (CHBLCK(2:2).EQ.'U') THEN
46888 AU(INDX1,INDX2)=VAL
46889 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(16)=VAL
46890 MSPC(11)=MSPC(11)+1
46891 ELSEIF (CHBLCK(2:2).EQ.'D') THEN
46892 AD(INDX1,INDX2)=VAL
46893 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(15)=VAL
46894 MSPC(10)=MSPC(10)+1
46895 ELSEIF (CHBLCK(2:2).EQ.'E') THEN
46896 AE(INDX1,INDX2)=VAL
46897 IF (INDX1.EQ.3.AND.INDX2.EQ.3) RMSS(17)=VAL
46898 MSPC(12)=MSPC(12)+1
46899 ELSE
46900 MERR=1
46901 ENDIF
46902 ELSEIF (CHBLCK(1:5).EQ.'MSOFT') THEN
46903 IF (MSPC(18).EQ.0) THEN
46904 READ(CHBLCK(9:25),*,ERR=620) Q
46905 RMSOFT(0)=Q
46906 ENDIF
46907 READ(CHINL,*) INDX, VAL
46908 RMSOFT(INDX)=VAL
46909 MSPC(18)=MSPC(18)+1
46910 ELSEIF (CHBLCK(1:5).EQ.'GAUGE') THEN
46911 MERR=8
46912 ELSEIF (CHBLCK(1:2).EQ.'YU'.OR.CHBLCK(1:2).EQ.'YD'.OR
46913 & .CHBLCK(1:2).EQ.'YE') THEN
46914 MERR=8
46915 ELSEIF (CHBLCK(1:6).EQ.'SPINFO') THEN
46916 READ(CHINL(1:6),*) INDX
46917 IT=0
46918 MIRD=0
46919 330 IT=IT+1
46920 IF (CHINL(IT:IT).EQ.' ') GOTO 330
46921C...Don't read index
46922 IF (CHINL(IT:IT).EQ.CHAR(INDX+48).AND.MIRD.EQ.0) THEN
46923 MIRD=1
46924 GOTO 330
46925 ENDIF
46926 IF (INDX.EQ.1) CPRO(1)=CHINL(IT:IT+12)
46927 IF (INDX.EQ.2) CVER(1)=CHINL(IT:IT+12)
46928 ELSE
46929C... Set unrecognized block flag.
46930 MERR=6
46931 ENDIF
46932
46933C...DECAY TABLES
46934C...Read in decay information
46935 ELSEIF (MUPDA.EQ.2.AND.MERR.EQ.0) THEN
46936C...Read new decay chanel
46937 IF(CHINL(1:1).EQ.' '.AND.CHBLCK(1:5).EQ.'DECAY') THEN
46938 NDC=NDC+1
46939C...Read in branching ratio and number of daughters for this mode.
46940 READ(CHINL(4:50),*,ERR=390) BRAT(NDC)
46941 READ(CHINL(4:50),*,ERR=600) DUM, NDA
46942 IF (NDA.LE.5) THEN
46943 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
46944 & '(PYSLHA:) Decay data arrays full by KF = '
46945 $ //CHAF(KC,1))
46946C...If first decay channel, set decays start point in decay table
46947 IF(BRSUM.LE.0D0.AND.BRAT(NDC).NE.0D0) THEN
46948 IF (KFORIG.EQ.0) WRITE(MSTU(11),'(1x,A,I9,A,A16)')
46949 & '* (PYSLHA:) Reading DECAY table for '//
46950 & 'KF =',KF,', ',CHAF(KCREP,1)(1:16)
46951C...Set particle parameters (mass set when reading BLOCK MASS above)
46952 PMAS(KC,2)=WIDTH
46953 IF (KF.EQ.25.OR.KF.EQ.35.OR.KF.EQ.36) THEN
46954 WRITE(MSTU(11),'(1x,A)')
46955 & '* Note: the Pythia gg->h/H/A cross section'//
46956 & ' is proportional to the h/H/A->gg width'
46957 ELSEIF (KF.EQ.23.OR.KF.EQ.24.OR.KF.EQ.6.OR.KF.EQ.32
46958 & .OR.KF.EQ.33.OR.KF.EQ.34) THEN
46959 WRITE(MSTU(11),'(1x,A,A16)')
46960 & '* Warning: will use DECAY table (fixed-width,'//
46961 & ' flat PS) for ',CHAF(KC,1)(1:16)
46962 ENDIF
46963 PMAS(KC,3)=0D0
46964 PMAS(KC,4)=PARU(3)*1D-12/WIDTH
46965 MWID(KC)=2
46966 MDCY(KC,1)=1
46967 MDCY(KC,2)=NDC
46968 MDCY(KC,3)=0
46969C...Add to list of DECAY blocks currently read
46970 NDECAY=NDECAY+1
46971 KFDEC(NDECAY)=KF
46972C...Return ok
46973 IRETRN=0
46974 ENDIF
46975C... Count up number of decay modes for this particle
46976 MDCY(KC,3)=MDCY(KC,3)+1
46977C... Read in decay daughters.
46978 READ(CHINL(4:120),*,ERR=610) DUM,IDM, (IDC(IDA),IDA=1,NDA)
46979C... Flip sign if reading antiparticle decays (if antipartner exists)
46980 DO 340 IDA=1,NDA
46981 IF (KCHG(PYCOMP(IDC(IDA)),3).NE.0)
46982 & IDC(IDA)=MPSIGN*IDC(IDA)
46983 340 CONTINUE
46984C...Switch on decay channel, with products ordered in decreasing ABS(KF)
46985 MDME(NDC,1)=1
46986 IF (BRAT(NDC).LE.0D0) MDME(NDC,1)=0
46987 BRSUM=BRSUM+ABS(BRAT(NDC))
46988 BRAT(NDC)=ABS(BRAT(NDC))
46989 350 IFLIP=0
46990 DO 360 IDA=1,NDA-1
46991 IF (IABS(IDC(IDA+1)).GT.IABS(IDC(IDA))) THEN
46992 ITMP=IDC(IDA)
46993 IDC(IDA)=IDC(IDA+1)
46994 IDC(IDA+1)=ITMP
46995 IFLIP=IFLIP+1
46996 ENDIF
46997 360 CONTINUE
46998 IF (IFLIP.GT.0) GOTO 350
46999C...Treat as ordinary decay, no fancy stuff.
47000 MDME(NDC,2)=0
47001 DO 370 IDA=1,5
47002 IF (IDA.LE.NDA) THEN
47003 KFDP(NDC,IDA)=IDC(IDA)
47004 ELSE
47005 KFDP(NDC,IDA)=0
47006 ENDIF
47007 370 CONTINUE
47008C WRITE(MSTU(11),7510) NDC, BRAT(NDC), NDA,
47009C & (KFDP(NDC,J),J=1,NDA)
47010 ELSE
47011 CALL PYERRM(7,'(PYSLHA:) Too many daughters on line '//
47012 & CHNLIN)
47013 MERR=11
47014 NDC=NDC-1
47015 ENDIF
47016 ELSEIF(CHINL(1:1).EQ.'+') THEN
47017 MERR=11
47018 ELSEIF(CHBLCK(1:6).EQ.'DCINFO') THEN
47019 MERR=16
47020 ELSE
47021 MERR=16
47022 ENDIF
47023 ENDIF
47024C... Error check.
47025 380 IF (MOD(MERR,10).EQ.1.AND.(MUPDA.EQ.1.OR.MUPDA.EQ.2)) THEN
47026 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring line '//CHNLIN//': '
47027 & //CHINL(1:40)
47028 MERR=0
47029 ELSEIF (MERR.EQ.6.AND.MUPDA.EQ.1) THEN
47030 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//
47031 & CHBLCK(1:MIN(INL,40))//'... on line '//CHNLIN
47032 ELSEIF (MERR.EQ.8.AND.MUPDA.EQ.1) THEN
47033 WRITE(MSTU(11),*) '* (PYSLHA:) PYTHIA will not use BLOCK '
47034 & //CHBLCK(1:INL)//'... on line'//CHNLIN
47035 ELSEIF (MERR.EQ.16.AND.MUPDA.EQ.2.AND.IMSS21.EQ.0.AND.
47036 & CHBLCK(1:1).NE.'D'.AND.VERBOS.EQ.1) THEN
47037 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring BLOCK '//CHBLCK(1:INL)
47038 & //'... on line'//CHNLIN
47039 ELSEIF (MERR.EQ.7.AND.MUPDA.EQ.1) THEN
47040 WRITE(MSTU(11),*) '* (PYSLHA:) Ignoring extra BLOCK '/
47041 & /CHBLCK(1:INL)//'... on line'//CHNLIN
47042 ELSEIF (MERR.EQ.2.AND.MUPDA.EQ.1) THEN
47043 WRITE (CHTMP,*) KF
47044 WRITE(MSTU(11),*)
47045 & '* (PYSLHA:) Ignoring extra MASS entry for KF='//
47046 & CHTMP(1:9)//' on line'//CHNLIN
47047 ENDIF
47048C...Iterate read loop
47049 GOTO 170
47050C...Error catching
47051 390 WRITE(*,*) '* (PYSLHA:) read BR error on line',NLINE,
47052 & ', ignoring subsequent lines.'
47053 WRITE(*,*) '* (PYSLHA:) Offending line:',CHINL(1:46)
47054 CHBLCK=' '
47055 GOTO 170
47056C...End of read loop
47057 400 CONTINUE
47058C...Set flag that KC codes have been rearranged.
47059 MSTU(20)=0
47060 VERBOS=0
47061
47062C...Perform possible tests that new information is consistent.
47063 IF (MUPDA.EQ.1) THEN
47064 MSTU23=MSTU(23)
47065 MSTU27=MSTU(27)
47066C...Check masses
47067 DO 410 ISUSY=1,37
47068 KF=KFSUSY(ISUSY)
47069C...Don't complain about right-handed neutrinos
47070 IF (KF.EQ.KSUSY2+12.OR.KF.EQ.KSUSY2+14.OR.KF.EQ.KSUSY2
47071 & +16) GOTO 410
47072C...Only check gravitino in GMSB scenarios
47073 IF (MODSEL(1).NE.2.AND.KF.EQ.KSUSY1+39) GOTO 410
47074 KC=PYCOMP(KF)
47075 IF (PMAS(KC,1).EQ.0D0) THEN
47076 WRITE(CHTMP,*) KF
47077 CALL PYERRM(9
47078 & ,'(PYSLHA:) No mass information found for KF ='
47079 & //CHTMP)
47080 ENDIF
47081 410 CONTINUE
47082C...Check mixing matrices (MSSM only)
47083 IF (IMSS(13).EQ.0) THEN
47084 IF (MSPC(2).NE.16.AND.MSPC(2).NE.32) CALL PYERRM(9
47085 & ,'(PYSLHA:) Inconsistent # of elements in NMIX')
47086 IF (MSPC(3).NE.4.AND.MSPC(3).NE.8) CALL PYERRM(9
47087 & ,'(PYSLHA:) Inconsistent # of elements in UMIX')
47088 IF (MSPC(4).NE.4.AND.MSPC(4).NE.8) CALL PYERRM(9
47089 & ,'(PYSLHA:) Inconsistent # of elements in VMIX')
47090 IF (MSPC(5).NE.4) CALL PYERRM(9
47091 & ,'(PYSLHA:) Inconsistent # of elements in SBOTMIX')
47092 IF (MSPC(6).NE.4) CALL PYERRM(9
47093 & ,'(PYSLHA:) Inconsistent # of elements in STOPMIX')
47094 IF (MSPC(7).NE.4) CALL PYERRM(9
47095 & ,'(PYSLHA:) Inconsistent # of elements in STAUMIX')
47096 IF (MSPC(8).LT.1) CALL PYERRM(9
47097 & ,'(PYSLHA:) Too few elements in HMIX')
47098 IF (MSPC(10).EQ.0) CALL PYERRM(9
47099 & ,'(PYSLHA:) Missing A_b trilinear coupling')
47100 IF (MSPC(11).EQ.0) CALL PYERRM(9
47101 & ,'(PYSLHA:) Missing A_t trilinear coupling')
47102 IF (MSPC(12).EQ.0) CALL PYERRM(9
47103 & ,'(PYSLHA:) Missing A_tau trilinear coupling')
47104 IF (MSPC(17).LT.1) CALL PYERRM(9
47105 & ,'(PYSLHA:) Missing Higgs mixing angle alpha')
47106 ENDIF
47107C...Check wavefunction normalizations.
47108C...Sfermions
47109 DO 420 ISPC=5,7
47110 IF (MSPC(ISPC).EQ.4) THEN
47111 KFSM=ISPC
47112 IF (ISPC.EQ.7) KFSM=15
47113 CHECK=ABS(SFMIX(KFSM,1)*SFMIX(KFSM,4)-SFMIX(KFSM,2)
47114 & *SFMIX(KFSM,3))
47115 IF (ABS(1D0-CHECK).GT.1D-3) THEN
47116 KCSM=PYCOMP(KFSM)
47117 CALL PYERRM(17
47118 & ,'(PYSLHA:) Non-orthonormal mixing matrix for ~'
47119 & //CHAF(KCSM,1))
47120 ENDIF
47121C...Bug fix 30/09 2008: PS
47122C...Translate to Pythia's internal convention: (1,1) same sign as (2,2)
47123 IF (SFMIX(KFSM,1)*SFMIX(KFSM,4).LT.0D0) THEN
47124 SFMIX(KFSM,3) = -SFMIX(KFSM,3)
47125 SFMIX(KFSM,4) = -SFMIX(KFSM,4)
47126 ENDIF
47127 ENDIF
47128 420 CONTINUE
47129C...Neutralinos + charginos
47130 DO 440 J=1,4
47131 CN1=0D0
47132 CN2=0D0
47133 CU1=0D0
47134 CU2=0D0
47135 CV1=0D0
47136 CV2=0D0
47137 DO 430 L=1,4
47138 CN1=CN1+ZMIX(J,L)**2
47139 CN2=CN2+ZMIX(L,J)**2
47140 IF (J.LE.2.AND.L.LE.2) THEN
47141 CU1=CU1+UMIX(J,L)**2
47142 CU2=CU2+UMIX(L,J)**2
47143 CV1=CV1+VMIX(J,L)**2
47144 CV2=CV2+VMIX(L,J)**2
47145 ENDIF
47146 430 CONTINUE
47147C...NMIX normalization
47148 IF (MSPC(2).EQ.16.AND.(ABS(1D0-CN1).GT.1D-3.OR.ABS(1D0-CN2)
47149 & .GT.1D-3).AND.IMSS(13).EQ.0) THEN
47150 CALL PYERRM(19,
47151 & '(PYSLHA:) NMIX: Inconsistent normalization.')
47152 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F7.4))') J, CN1, CN2
47153 ENDIF
47154C...UMIX, VMIX normalizations
47155 IF (MSPC(3).EQ.4.OR.MSPC(4).EQ.4.AND.IMSS(13).EQ.0) THEN
47156 IF (J.LE.2) THEN
47157 IF (ABS(1D0-CU1).GT.1D-3.OR.ABS(1D0-CU2).GT.1D-3) THEN
47158 CALL PYERRM(19
47159 & ,'(PYSLHA:) UMIX: Inconsistent normalization.')
47160 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CU1,
47161 & CU2
47162 ENDIF
47163 IF (ABS(1D0-CV1).GT.1D-3.OR.ABS(1D0-CV2).GT.1D-3) THEN
47164 CALL PYERRM(19,
47165 & '(PYSLHA:) VMIX: Inconsistent normalization.')
47166 WRITE(MSTU(11),'(7x,I2,1x,":",2(1x,F6.2))') J, CV1,
47167 & CV2
47168 ENDIF
47169 ENDIF
47170 ENDIF
47171 440 CONTINUE
47172 IF (MSTU(27).EQ.MSTU27.AND.MSTU(23).EQ.MSTU23) THEN
47173 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*")')
47174 & '* (PYSLHA:) No spectrum inconsistencies were found.'
47175 ELSE
47176 WRITE(MSTU(11),'(1x,"*"/1x,A/1x,"*",A/1x,"*",A/)')
47177 & '* (PYSLHA:) INCONSISTENT SPECTRUM WARNING.'
47178 & ,' Warning: one or more (serious)'//
47179 & ' inconsistencies were found in the spectrum !'
47180 & ,' Read the error messages above and check your'//
47181 & ' input file.'
47182 ENDIF
47183C...Increase precision in Higgs sector using FeynHiggs
47184 IF (IMSS(4).EQ.3) THEN
47185C...FeynHiggs needs MSOFT.
47186 IERR=0
47187 IF (MSPC(18).EQ.0) THEN
47188 WRITE(MSTU(11),'(1x,"*"/1x,A/)')
47189 & '* (PYSLHA:) BLOCK MSOFT not found in SLHA file.'//
47190 & ' Cannot call FeynHiggs.'
47191 IERR=-1
47192 ELSE
47193 WRITE(MSTU(11),'(1x,/1x,A/)')
47194 & '* (PYSLHA:) Now calling FeynHiggs.'
47195 CALL PYFEYN(IERR)
47196 IF (IERR.NE.0) IMSS(4)=2
47197 ENDIF
47198 ENDIF
47199 ELSEIF (MUPDA.EQ.2.AND.IRETRN.EQ.0.AND.MERR.NE.16) THEN
47200 IBEG=1
47201 IF (KFORIG.NE.0) IBEG=NDECAY
47202 DO 490 IDECAY=IBEG,NDECAY
47203 KF = KFDEC(IDECAY)
47204 KC = PYCOMP(KF)
47205 WRITE(CHKF,8300) KF
47206 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3
47207 $ ),PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0.OR.(MDCY(KC,3)
47208 $ .EQ.0.AND.MDCY(KC,1).GE.1)) CALL PYERRM(17
47209 $ ,'(PYSLHA:) Mass/width/life/(# channels) wrong for KF='
47210 $ //CHKF)
47211 BRSUM=0D0
47212 BROPN=0D0
47213 DO 460 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47214 IF(MDME(IDA,2).GT.80) GOTO 460
47215 KQ=KCHG(KC,1)
47216 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
47217 MERR=0
47218 DO 450 J=1,5
47219 KP=KFDP(IDA,J)
47220 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
47221 IF(KP.EQ.81) KQ=0
47222 ELSEIF(PYCOMP(KP).EQ.0) THEN
47223 MERR=3
47224 ELSE
47225 KQ=KQ-PYCHGE(KP)
47226 KPC=PYCOMP(KP)
47227 PMS=PMS-PMAS(KPC,1)
47228 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
47229 & PMAS(KPC,3))
47230 ENDIF
47231 450 CONTINUE
47232 IF(KQ.NE.0) MERR=MAX(2,MERR)
47233 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
47234 & MERR=MAX(1,MERR)
47235 IF(MERR.EQ.3) CALL PYERRM(17,
47236 & '(PYSLHA:) Unknown particle code in decay of KF ='
47237 $ //CHKF)
47238 IF(MERR.EQ.2) CALL PYERRM(17,
47239 & '(PYSLHA:) Charge not conserved in decay of KF ='
47240 $ //CHKF)
47241 IF(MERR.EQ.1) CALL PYERRM(7,
47242 & '(PYSLHA:) Kinematically unallowed decay of KF ='
47243 $ //CHKF)
47244 BRSUM=BRSUM+BRAT(IDA)
47245 IF (MDME(IDA,1).GT.0) BROPN=BROPN+BRAT(IDA)
47246 460 CONTINUE
47247C...Check branching ratio sum.
47248 IF (BROPN.LE.0D0) THEN
47249C...If zero, set stable.
47250 WRITE(CHTMP,8500) BROPN
47251 CALL PYERRM(7
47252 & ,"(PYSLHA:) Effective BR sum for KF="//CHKF//' is '//
47253 & CHTMP(9:16)//'. Changed to stable.')
47254 PMAS(KC,2)=1D-6
47255 MWID(KC)=0
47256C...If BR's > 1, rescale.
47257 ELSEIF (BRSUM.GT.(1D0+1D-6)) THEN
47258 WRITE(CHTMP,8500) BRSUM
47259 IF (BRSUM.GT.(1D0+1D-3)) CALL PYERRM(7
47260 & ,"(PYSLHA:) Forced rescaling of BR's for KF="//CHKF//
47261 & ' ; sum was'//CHTMP(9:16)//'.')
47262 FAC=1D0/BRSUM
47263 DO 470 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47264 IF(MDME(IDA,2).GT.80) GOTO 470
47265 BRAT(IDA)=FAC*BRAT(IDA)
47266 470 CONTINUE
47267 ELSEIF (BRSUM.LT.(1D0-1D-6)) THEN
47268C...If BR's < 1, insert dummy mode for proper cross section rescaling.
47269 WRITE(CHTMP,8500) BRSUM
47270 IF (BRSUM.LT.(1D0-1D-3)) CALL PYERRM(7
47271 & ,"(PYSLHA:) Sum of BR's for KF="//CHKF//' is '//
47272 & CHTMP(9:16)//'. Dummy mode will be inserted.')
47273C...Move table and insert dummy mode
47274 DO 480 IDA=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47275 NDC=NDC+1
47276 BRAT(NDC)=BRAT(IDA)
47277 KFDP(NDC,1)=KFDP(IDA,1)
47278 KFDP(NDC,2)=KFDP(IDA,2)
47279 KFDP(NDC,3)=KFDP(IDA,3)
47280 KFDP(NDC,4)=KFDP(IDA,4)
47281 KFDP(NDC,5)=KFDP(IDA,5)
47282 MDME(NDC,1)=MDME(IDA,1)
47283 480 CONTINUE
47284 NDC=NDC+1
47285 BRAT(NDC)=1D0-BRSUM
47286 KFDP(NDC,1)=0
47287 KFDP(NDC,2)=0
47288 KFDP(NDC,3)=0
47289 KFDP(NDC,4)=0
47290 KFDP(NDC,5)=0
47291 MDME(NDC,1)=0
47292 BRSUM=1D0
47293C...Update MDCY
47294 MDCY(KC,3)=MDCY(KC,3)+1
47295 MDCY(KC,2)=NDC-MDCY(KC,3)+1
47296 ENDIF
47297 490 CONTINUE
47298 ENDIF
47299
47300
47301C...WRITE SPECTRUM ON SLHA FILE
47302 ELSEIF(MUPDA.EQ.3) THEN
47303C...If SPYTHIA or ISASUSY runtime was called for SUGRA, update PARMIN.
47304 IF (IMSS(1).EQ.2.OR.IMSS(1).EQ.12) THEN
47305 MODSEL(1)=1
47306 PARMIN(1)=RMSS(8)
47307 PARMIN(2)=RMSS(1)
47308 PARMIN(3)=RMSS(5)
47309 PARMIN(4)=SIGN(1D0,RMSS(4))
47310 PARMIN(5)=RMSS(36)
47311 ENDIF
47312C...Write spectrum
47313 WRITE(LFN,7000) 'SLHA MSSM spectrum'
47314 WRITE(LFN,7000) 'Pythia 6.4: T. Sjostrand, S. Mrenna,'
47315 & // ' P. Skands.'
47316 WRITE(LFN,7010) 'MODSEL', 'Model selection'
47317 WRITE(LFN,7110) 1, MODSEL(1)
47318 WRITE(LFN,7010) 'MINPAR', 'Parameters for minimal model.'
47319 IF (MODSEL(1).EQ.1) THEN
47320 WRITE(LFN,7210) 1, PARMIN(1), 'm0'
47321 WRITE(LFN,7210) 2, PARMIN(2), 'm12'
47322 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
47323 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
47324 WRITE(LFN,7210) 5, PARMIN(5), 'a0'
47325 ELSEIF(MODSEL(2).EQ.2) THEN
47326 WRITE(LFN,7210) 1, PARMIN(1), 'Lambda'
47327 WRITE(LFN,7210) 2, PARMIN(2), 'M'
47328 WRITE(LFN,7210) 3, PARMIN(3), 'tan(beta)'
47329 WRITE(LFN,7210) 4, PARMIN(4), 'sign(mu)'
47330 WRITE(LFN,7210) 5, PARMIN(5), 'N5'
47331 WRITE(LFN,7210) 6, PARMIN(6), 'c_grav'
47332 ENDIF
47333 WRITE(LFN,7000) ' '
47334 WRITE(LFN,7010) 'MASS', 'Mass spectrum'
47335 DO 500 I=1,36
47336 KF=KFSUSY(I)
47337 KC=PYCOMP(KF)
47338 IF (KF.EQ.1000039.AND.MODSEL(1).NE.2) GOTO 500
47339 KFSM=KF-KSUSY1
47340 IF (KFSM.GE.22.AND.KFSM.LE.37) THEN
47341 IF (KFSM.EQ.22) WRITE(LFN,7220) KF, SMZ(1), CHAF(KC,1)
47342 IF (KFSM.EQ.23) WRITE(LFN,7220) KF, SMZ(2), CHAF(KC,1)
47343 IF (KFSM.EQ.25) WRITE(LFN,7220) KF, SMZ(3), CHAF(KC,1)
47344 IF (KFSM.EQ.35) WRITE(LFN,7220) KF, SMZ(4), CHAF(KC,1)
47345 IF (KFSM.EQ.24) WRITE(LFN,7220) KF, SMW(1), CHAF(KC,1)
47346 IF (KFSM.EQ.37) WRITE(LFN,7220) KF, SMW(2), CHAF(KC,1)
47347 ELSE
47348 WRITE(LFN,7220) KF, PMAS(KC,1), CHAF(KC,1)
47349 ENDIF
47350 500 CONTINUE
47351C...SUSY scale
47352 RMSUSY=SQRT(PMAS(PYCOMP(KSUSY1+6),1)*PMAS(PYCOMP(KSUSY2+6),1))
47353 WRITE(LFN,7020) 'HMIX',RMSUSY,'Higgs parameters'
47354 WRITE(LFN,7210) 1, RMSS(4),'mu'
47355 WRITE(LFN,7010) 'ALPHA',' '
47356C WRITE(LFN,7210) 1, RMSS(18), 'alpha'
47357 WRITE(LFN,7200) RMSS(18), 'alpha'
47358 WRITE(LFN,7020) 'AU',RMSUSY
47359 WRITE(LFN,7410) 3, 3, RMSS(16), 'A_t'
47360 WRITE(LFN,7020) 'AD',RMSUSY
47361 WRITE(LFN,7410) 3, 3, RMSS(15), 'A_b'
47362 WRITE(LFN,7020) 'AE',RMSUSY
47363 WRITE(LFN,7410) 3, 3, RMSS(17), 'A_tau'
47364 WRITE(LFN,7010) 'STOPMIX','~t mixing matrix'
47365 WRITE(LFN,7410) 1, 1, SFMIX(6,1)
47366 WRITE(LFN,7410) 1, 2, SFMIX(6,2)
47367 WRITE(LFN,7410) 2, 1, SFMIX(6,3)
47368 WRITE(LFN,7410) 2, 2, SFMIX(6,4)
47369 WRITE(LFN,7010) 'SBOTMIX','~b mixing matrix'
47370 WRITE(LFN,7410) 1, 1, SFMIX(5,1)
47371 WRITE(LFN,7410) 1, 2, SFMIX(5,2)
47372 WRITE(LFN,7410) 2, 1, SFMIX(5,3)
47373 WRITE(LFN,7410) 2, 2, SFMIX(5,4)
47374 WRITE(LFN,7010) 'STAUMIX','~tau mixing matrix'
47375 WRITE(LFN,7410) 1, 1, SFMIX(15,1)
47376 WRITE(LFN,7410) 1, 2, SFMIX(15,2)
47377 WRITE(LFN,7410) 2, 1, SFMIX(15,3)
47378 WRITE(LFN,7410) 2, 2, SFMIX(15,4)
47379 WRITE(LFN,7010) 'NMIX','~chi0 mixing matrix'
47380 DO 520 I1=1,4
47381 DO 510 I2=1,4
47382 WRITE(LFN,7410) I1, I2, ZMIX(I1,I2)
47383 510 CONTINUE
47384 520 CONTINUE
47385 WRITE(LFN,7010) 'UMIX','~chi^+ U mixing matrix'
47386 DO 540 I1=1,2
47387 DO 530 I2=1,2
47388 WRITE(LFN,7410) I1, I2, UMIX(I1,I2)
47389 530 CONTINUE
47390 540 CONTINUE
47391 WRITE(LFN,7010) 'VMIX','~chi^+ V mixing matrix'
47392 DO 560 I1=1,2
47393 DO 550 I2=1,2
47394 WRITE(LFN,7410) I1, I2, VMIX(I1,I2)
47395 550 CONTINUE
47396 560 CONTINUE
47397 WRITE(LFN,7010) 'SPINFO'
47398 IF (IMSS(1).EQ.2) THEN
47399 CPRO(1)='PYTHIA'
47400 CVER(1)='6.4'
47401 ELSEIF (IMSS(1).EQ.12) THEN
47402 ISAVER=VISAJE()
47403 CPRO(1)='ISASUSY'
47404 CVER(1)=ISAVER(1:12)
47405 ENDIF
47406 WRITE(LFN,7310) 1, CPRO(1), 'Spectrum Calculator'
47407 WRITE(LFN,7310) 2, CVER(1), 'Version number'
47408 ENDIF
47409
47410C...Print user information about spectrum
47411 IF (MUPDA.EQ.1.OR.MUPDA.EQ.3) THEN
47412 IF (CPRO(MOD(MUPDA,2)).NE.' '.AND.CVER(MOD(MUPDA,2)).NE.' ')
47413 & WRITE(MSTU(11),5030) CPRO(1), CVER(1)
47414 IF (IMSS(4).EQ.3) WRITE(MSTU(11),5040)
47415 IF (MUPDA.EQ.1) THEN
47416 WRITE(MSTU(11),5020) LFN
47417 ELSE
47418 WRITE(MSTU(11),5010) LFN
47419 ENDIF
47420
47421 WRITE(MSTU(11),5400)
47422 WRITE(MSTU(11),5500) 'Pole masses'
47423 WRITE(MSTU(11),5700) (RMFUN(KSUSY1+IP),IP=1,6)
47424 $ ,(RMFUN(KSUSY2+IP),IP=1,6)
47425 WRITE(MSTU(11),5800) (RMFUN(KSUSY1+IP),IP=11,16)
47426 $ ,(RMFUN(KSUSY2+IP),IP=11,16)
47427 IF (IMSS(13).EQ.0) THEN
47428 WRITE(MSTU(11),5900) RMFUN(KSUSY1+21),RMFUN(KSUSY1+22)
47429 $ ,RMFUN(KSUSY1+23),RMFUN(KSUSY1+25),RMFUN(KSUSY1+35),
47430 $ RMFUN(KSUSY1+24),RMFUN(KSUSY1+37)
47431 WRITE(MSTU(11),6000) CHAF(25,1),CHAF(35,1),CHAF(36,1),
47432 & CHAF(37,1), ' ', ' ',' ',' ',
47433 & RMFUN(25), RMFUN(35), RMFUN(36), RMFUN(37)
47434 ELSEIF (IMSS(13).EQ.1) THEN
47435 KF1=KSUSY1+21
47436 KF2=KSUSY1+22
47437 KF3=KSUSY1+23
47438 KF4=KSUSY1+25
47439 KF5=KSUSY1+35
47440 KF6=KSUSY1+45
47441 KF7=KSUSY1+24
47442 KF8=KSUSY1+37
47443 WRITE(MSTU(11),6000) CHAF(PYCOMP(KF1),1),CHAF(PYCOMP(KF2),1),
47444 & CHAF(PYCOMP(KF3),1),CHAF(PYCOMP(KF4),1),
47445 & CHAF(PYCOMP(KF5),1),CHAF(PYCOMP(KF6),1),
47446 & CHAF(PYCOMP(KF7),1),CHAF(PYCOMP(KF8),1),
47447 & RMFUN(KF1),RMFUN(KF2),RMFUN(KF3),RMFUN(KF4),
47448 & RMFUN(KF5),RMFUN(KF6),RMFUN(KF7),RMFUN(KF8)
47449 WRITE(MSTU(11),6000) CHAF(25,1), CHAF(35,1), CHAF(45,1),
47450 & CHAF(36,1), CHAF(46,1), CHAF(37,1),' ',' ',
47451 & RMFUN(25), RMFUN(35), RMFUN(45), RMFUN(36), RMFUN(46),
47452 & RMFUN(37)
47453 ENDIF
47454 WRITE(MSTU(11),5400)
47455 WRITE(MSTU(11),5500) 'Mixing structure'
47456 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
47457 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
47458 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
47459 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
47460 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
47461 & ),(SFMIX(15,J),J=3,4)
47462 WRITE(MSTU(11),5400)
47463 WRITE(MSTU(11),5500) 'Couplings'
47464 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17)
47465 WRITE(MSTU(11),6450) RMSS(18), RMSS(5), RMSS(4)
47466 WRITE(MSTU(11),5400)
47467 WRITE(MSTU(11),6500)
47468
47469C...DECAY TABLES writeout
47470C...Write decay information by Nils-Erik Bomark 3/29/2010
47471 ELSEIF (MUPDA.EQ.4) THEN
47472 KF = KFORIG
47473 KC = PYCOMP(KF)
47474 IF (KC.NE.0) THEN
47475 WRITE(LFN,7000) ''
47476 WRITE(LFN,7000) ' PDG Width'
47477 WRITE(LFN,7500) KF,PMAS(KC,2), CHAF(KC,1)
47478 WRITE(LFN,7000)
47479 & ' BR NDA ID1 ID2 ID3'
47480 DO 575 I=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
47481 NDA = 0
47482 DO 570 J=1,5
47483 IF (KFDP(I,J).NE.0) NDA = NDA+1
47484 570 CONTINUE
47485 IF (NDA.EQ.2)
47486 & WRITE(LFN,7512) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47487 & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47488 & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47489 IF (NDA.EQ.3)
47490 & WRITE(LFN,7513) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47491 & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47492 & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47493 IF (NDA.EQ.4)
47494 & WRITE(LFN,7514) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47495 & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47496 & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47497 IF (NDA.EQ.5)
47498 & WRITE(LFN,7515) BRAT(I),NDA,(KFDP(I,K),K=1,NDA),
47499 & CHAF(KC,1),(CHAF(PYCOMP(KFDP(I,K)),
47500 & (3-KFDP(I,K)/ABS(KFDP(I,K)))/2),K=1,NDA)
47501 575 CONTINUE
47502 ENDIF
47503C....End of DECAY TABLES writeout
47504
47505 ENDIF
47506
47507C...Only rewind when reading
47508 IF (MUPDA.LE.2.OR.MUPDA.EQ.5) REWIND(LFN)
47509
47510 9999 RETURN
47511
47512C...Serious error catching
47513 580 write(*,*) '* (PYSLHA:) read BLOCK error on line',NLINE
47514 write(*,*) CHINL(1:80)
47515 CALL PYSTOP(106)
47516 590 WRITE(*,*) '* (PYSLHA:) read DECAY error on line',NLINE
47517 WRITE(*,*) CHINL(1:72)
47518 CALL PYSTOP(106)
47519 600 WRITE(*,*) '* (PYSLHA:) read NDA error on line',NLINE
47520 WRITE(*,*) CHINL(1:80)
47521 CALL PYSTOP(106)
47522 610 WRITE(*,*) '* (PYSLHA:) decay daughter read error on line',NLINE
47523 WRITE(*,*) CHINL(1:80)
47524 620 WRITE(*,*) '* (PYSLHA:) read Q error in BLOCK ',CHBLCK
47525 CALL PYSTOP(106)
47526 630 WRITE(*,*) '* (PYSLHA:) read error in line ',NLINE,':'
47527 WRITE(*,*) CHINL(1:80)
47528 CALL PYSTOP(106)
47529
47530 8300 FORMAT(I9)
47531 8500 FORMAT(F16.5)
47532
47533C...Formats for user information printout.
47534 5000 FORMAT(1x,18('*'),1x,'PYSLHA v1.14: SUSY/BSM SPECTRUM '
47535 & ,'INTERFACE',1x,17('*')/1x,'*',1x
47536 & ,'(PYSLHA:) Last Change',1x,A,1x,'-',1x,'P.Z. Skands')
47537 5010 FORMAT(1x,'*',3x,'Wrote spectrum file on unit: ',I3)
47538 5020 FORMAT(1x,'*',3x,'Read spectrum file on unit: ',I3)
47539 5030 FORMAT(1x,'*',3x,'Spectrum Calculator was: ',A,' version ',A)
47540 5040 FORMAT(1x,'*',3x,'Higgs sector corrected with FeynHiggs')
47541 5100 FORMAT(1x,'*',1x,'Model parameters:'/1x,'*',1x,'----------------')
47542 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
47543 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
47544 5300 FORMAT(1x,'*'/1x,'*',1x,'Model spectrum :'/1x,'*',1x
47545 & ,'----------------')
47546 5400 FORMAT(1x,'*',1x,A)
47547 5500 FORMAT(1x,'*',1x,A,':')
47548 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
47549 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
47550 5700 FORMAT(1x,'*',4x,1x,'~d',2x,1x,4x,'~u',2x,1x,4x,'~s',2x,1x,
47551 & 4x,'~c',2x,1x,4x,'~b(12)',1x,1x,1x,'~t(12)'/1x,'*',2x,'L',1x
47552 & ,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
47553 5800 FORMAT(1x,'*'/1x,'*',4x,1x,'~e',2x,1x,4x,'~nu_e',2x,1x,1x,'~mu',2x
47554 & ,1x,3x,'~nu_mu',2x,1x,'~tau(12)',1x,'~nu_tau'/1x,'*',2x
47555 & ,'L',1x,6(F8.2,1x)/1x,'*',2x,'R',1x,6(F8.2,1x))
47556 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
47557 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
47558 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
47559 6000 FORMAT(1x,'*'/1x,'*',3x,1x,8(1x,A7,1x)/1x,'*',3x,1x,8(F8.2,1x))
47560 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
47561 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
47562 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
47563 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
47564 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
47565 & ,1x,F6.3,1x),'|')
47566 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
47567 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
47568 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
47569 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
47570 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
47571 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
47572 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
47573 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
47574 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
47575 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
47576 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
47577 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
47578 6400 FORMAT(1x,'*',3x,' A_b = ',F8.2,4x,' A_t = ',F8.2,4x
47579 & ,'A_tau = ',F8.2)
47580 6450 FORMAT(1x,'*',3x,'alpha = ',F8.2,4x,'tan(beta) = ',F8.2,4x
47581 & ,' mu = ',F8.2)
47582 6500 FORMAT(1x,32('*'),1x,'END OF PYSLHA',1x,31('*'))
47583
47584C...Format to use for comments
47585 7000 FORMAT('# ',A)
47586C...Format to use for block statements
47587 7010 FORMAT('Block',1x,A,3x,'#',1x,A)
47588 7020 FORMAT('Block',1x,A,1x,'Q=',1P,E16.8,0P,3x,'#',1x,A)
47589C...Indexed Int
47590 7110 FORMAT(1x,I4,1x,I4,3x,'#')
47591C...Non-Indexed Double
47592 7200 FORMAT(9x,1P,E16.8,0P,3x,'#',1x,A)
47593C...Indexed Double
47594 7210 FORMAT(1x,I4,3x,1P,E16.8,0P,3x,'#',1x,A)
47595C...Long Indexed Double (PDG + double)
47596 7220 FORMAT(1x,I9,3x,1P,E16.8,0P,3x,'#',1x,A)
47597C...Indexed Char(12)
47598 7310 FORMAT(1x,I4,3x,A12,3x,'#',1x,A)
47599C...Single matrix
47600 7410 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,0P,3x,'#',1x,A)
47601C...Double Matrix
47602 7420 FORMAT(1x,I2,1x,I2,3x,1P,E16.8,3x,E16.8,0P,3x,'#',1x,A)
47603C...Write Decay Table
47604 7500 FORMAT('Decay',1x,I9,1x,1P,E16.8,0P,3x,'#',1x,A)
47605 7510 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,'IDA=',1x,5(1x,I9),3x,'#',1x,A)
47606 7512 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,2(1x,I9),13x,
47607 & '#',1x,'BR(',A10,1x,'->',2(1x,A10),')')
47608 7513 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,3(1x,I9),3x,
47609 & '#',1x,'BR(',A10,1x,'->',3(1x,A10),')')
47610 7514 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,4(1x,I9),3x,
47611 & '#',1x,'BR(',A10,1x,'->',4(1x,A10),')')
47612 7515 FORMAT(4x,1P,E16.8,0P,3x,I2,3x,1x,5(1x,I9),3x,
47613 & '#',1x,'BR(',A10,1x,'->',5(1x,A10),')')
47614
47615 END
47616
47617
47618C*********************************************************************
47619
47620C...PYAPPS
47621C...Uses approximate analytical formulae to determine the full set of
47622C...MSSM parameters from SUGRA input.
47623C...See M. Drees and S.P. Martin, hep-ph/9504124
47624
47625 SUBROUTINE PYAPPS
47626
47627C...Double precision and integer declarations.
47628 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47629 IMPLICIT INTEGER(I-N)
47630 INTEGER PYK,PYCHGE,PYCOMP
47631C...Parameter statement to help give large particle numbers.
47632 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47633 &KEXCIT=4000000,KDIMEN=5000000)
47634C...Commonblocks.
47635 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47636 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47637 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47638 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/
47639
47640 WRITE(MSTU(11),*) '(PYAPPS:) approximate mSUGRA relations'//
47641 &' not intended for serious physics studies'
47642 IMSS(5)=0
47643 IMSS(8)=0
47644 XMT=PMAS(6,1)
47645 XMZ2=PMAS(23,1)**2
47646 XMW2=PMAS(24,1)**2
47647 TANB=RMSS(5)
47648 BETA=ATAN(TANB)
47649 XW=PARU(102)
47650 XMG=RMSS(1)
47651 XMG2=XMG*XMG
47652 XM0=RMSS(8)
47653 XM02=XM0*XM0
47654C...Temporary sign change for AT. Others unchanged.
47655 AT=-RMSS(16)
47656 RMSS(15)=RMSS(16)
47657 RMSS(17)=RMSS(16)
47658 SINB=TANB/SQRT(TANB**2+1D0)
47659 COSB=SINB/TANB
47660
47661 DTERM=XMZ2*COS(2D0*BETA)
47662 XMER=SQRT(XM02+0.15D0*XMG2-XW*DTERM)
47663 XMEL=SQRT(XM02+0.52D0*XMG2-(0.5D0-XW)*DTERM)
47664 RMSS(6)=XMEL
47665 RMSS(7)=XMER
47666 XMUR=SQRT(PYRNMQ(2,2D0/3D0*XW*DTERM))
47667 XMDR=SQRT(PYRNMQ(3,-1D0/3D0*XW*DTERM))
47668 XMUL=SQRT(PYRNMQ(1,(0.5D0-2D0/3D0*XW)*DTERM))
47669 XMDL=SQRT(PYRNMQ(1,-(0.5D0-1D0/3D0*XW)*DTERM))
47670 DO 100 I=1,5,2
47671 PMAS(PYCOMP(KSUSY1+I),1)=XMDL
47672 PMAS(PYCOMP(KSUSY2+I),1)=XMDR
47673 PMAS(PYCOMP(KSUSY1+I+1),1)=XMUL
47674 PMAS(PYCOMP(KSUSY2+I+1),1)=XMUR
47675 100 CONTINUE
47676 XARG=XMEL**2-XMW2*ABS(COS(2D0*BETA))
47677 IF(XARG.LT.0D0) THEN
47678 WRITE(MSTU(11),*) ' SNEUTRINO MASS IS NEGATIVE'//
47679 & ' FROM THE SUM RULE. '
47680 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
47681 RETURN
47682 ELSE
47683 XARG=SQRT(XARG)
47684 ENDIF
47685 DO 110 I=11,15,2
47686 PMAS(PYCOMP(KSUSY1+I),1)=XMEL
47687 PMAS(PYCOMP(KSUSY2+I),1)=XMER
47688 PMAS(PYCOMP(KSUSY1+I+1),1)=XARG
47689 PMAS(PYCOMP(KSUSY2+I+1),1)=9999D0
47690 110 CONTINUE
47691 RMT=PYMRUN(6,PMAS(6,1)**2)
47692 XTOP=(RMT/150D0/SINB)**2*(.9D0*XM02+2.1D0*XMG2+
47693 &(1D0-(RMT/190D0/SINB)**3)*(.24D0*AT**2+AT*XMG))
47694 RMB=PYMRUN(5,PMAS(6,1)**2)
47695 XBOT=(RMB/150D0/COSB)**2*(.9D0*XM02+2.1D0*XMG2+
47696 &(1D0-(RMB/190D0/COSB)**3)*(.24D0*AT**2+AT*XMG))
47697 XTAU=1D-4/COSB**2*(XM02+0.15D0*XMG2+AT**2/3D0)
47698 ATP=AT*(1D0-(RMT/190D0/SINB)**2)+XMG*(3.47D0-1.9D0*(RMT/190D0/
47699 &SINB)**2)
47700 RMSS(16)=-ATP
47701 XMU2=-.5D0*XMZ2+(SINB**2*(XM02+.52D0*XMG2-XTOP)-
47702 &COSB**2*(XM02+.52D0*XMG2-XBOT-XTAU/3D0))/(COSB**2-SINB**2)
47703 XMA2=2D0*(XM02+.52D0*XMG2+XMU2)-XTOP-XBOT-XTAU/3D0
47704 XMU=SIGN(SQRT(XMU2),RMSS(4))
47705 RMSS(4)=XMU
47706 IF(XMA2.GT.0D0) THEN
47707 RMSS(19)=SQRT(XMA2)
47708 ELSE
47709 WRITE(MSTU(11),*) ' PYAPPS:: PSEUDOSCALAR MASS**2 < 0 '
47710 CALL PYSTOP(102)
47711 ENDIF
47712 ARG=XM02+0.15D0*XMG2-2D0*XTAU/3D0-XW*DTERM
47713 IF(ARG.GT.0D0) THEN
47714 RMSS(14)=SQRT(ARG)
47715 ELSE
47716 WRITE(MSTU(11),*) ' PYAPPS:: RIGHT STAU MASS**2 < 0 '
47717 CALL PYSTOP(102)
47718 ENDIF
47719 ARG=XM02+0.52D0*XMG2-XTAU/3D0-(0.5D0-XW)*DTERM
47720 IF(ARG.GT.0D0) THEN
47721 RMSS(13)=SQRT(ARG)
47722 ELSE
47723 WRITE(MSTU(11),*) ' PYAPPS:: LEFT STAU MASS**2 < 0 '
47724 CALL PYSTOP(102)
47725 ENDIF
47726 ARG=PYRNMQ(1,-(XBOT+XTOP)/3D0)
47727 IF(ARG.GT.0D0) THEN
47728 RMSS(10)=SQRT(ARG)
47729 ELSE
47730 RMSS(10)=-SQRT(-ARG)
47731 ENDIF
47732 ARG=PYRNMQ(2,-2D0*XTOP/3D0)
47733 IF(ARG.GT.0D0) THEN
47734 RMSS(12)=SQRT(ARG)
47735 ELSE
47736 RMSS(12)=-SQRT(-ARG)
47737 ENDIF
47738 ARG=PYRNMQ(3,-2D0*XBOT/3D0)
47739 IF(ARG.GT.0D0) THEN
47740 RMSS(11)=SQRT(ARG)
47741 ELSE
47742 RMSS(11)=-SQRT(-ARG)
47743 ENDIF
47744
47745 RETURN
47746 END
47747
47748C*********************************************************************
47749
47750C...PYSUGI
47751C...Interface to ISASUSY version 7.71.
47752C...Warning: this interface should not be used with earlier versions
47753C...of ISASUSY, since common block incompatibilities may then arise.
47754C...Calls SUGRA (in ISAJET) to perform RGE evolution.
47755C...Then converts to Gunion-Haber conventions.
47756
47757 SUBROUTINE PYSUGI
47758 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
47759
47760 INTEGER PYK,PYCHGE,PYCOMP
47761 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
47762 &KEXCIT=4000000,KDIMEN=5000000)
47763
47764C...Date of Change
47765 CHARACTER DOC*11
47766 PARAMETER (DOC='01 May 2006')
47767
47768C...ISASUGRA Input:
47769 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
47770C...XISAIN contains the MSSMi inputs in natural order.
47771 COMMON /SUGXIN/ XISAIN(24),XSUGIN(7),XGMIN(14),XNRIN(4),
47772 $XAMIN(7)
47773 REAL XISAIN,XSUGIN,XGMIN,XNRIN,XAMIN
47774 SAVE /SUGXIN/
47775C...ISASUGRA Output
47776 CHARACTER*40 ISAVER,VISAJE
47777 REAL SUPER
47778 COMMON /SSPAR/ SUPER(72)
47779 COMMON /SUGMG/ MSS(32),GSS(31),MGUTSS,GGUTSS,AGUTSS,FTGUT,
47780 $FBGUT,FTAGUT,FNGUT
47781 REAL MSS,GSS,MGUTSS,GGUTSS,AGUTSS,FTGUT,FBGUT,FTAGUT,FNGUT
47782 COMMON /SUGPAS/ XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
47783 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
47784 $FNMZ,AMNRMJ,NOGOOD,IAL3UN,ITACHY,MHPNEG,ASM3,
47785 $VUMT,VDMT,ASMTP,ASMSS,M3Q
47786 REAL XTANB,MSUSY,AMT,MGUT,MU,G2,GP,V,VP,XW,
47787 $A1MZ,A2MZ,ASMZ,FTAMZ,FBMZ,B,SIN2B,FTMT,G3MT,VEV,HIGFRZ,
47788 $FNMZ,AMNRMJ,ASM3,VUMT,VDMT,ASMTP,ASMSS,M3Q
47789 INTEGER NOGOOD,IAL3UN,ITACHY,MHPNEG
47790 INTEGER IALLOW
47791 SAVE /SUGMG/,/SSPAR/
47792C SUPER: Filled by ISASUGRA.
47793C SUPER(1) = mass of ~g
47794C SUPER(2:17) = mass of ~u_L,~u_R,~d_L,~d_R,~s_L,~s_R,~c_L,~c_R,~b_L
47795C ,~b_R,~b_1,~b_2,~t_L,~t_R,~t_1,~t_2
47796C SUPER(18:25) = mass of ~e_L,~e_R,~mu_L,~mu_R,~tau_L,~tau_R,~tau_1
47797C ,~tau_2
47798C SUPER(26:28) = mass of ~nu_e,~nu_mu,~nu_tau
47799C SUPER(29) = Higgsino mass = - mu
47800C SUPER(30) = ratio v2/v1 of vev's
47801C SUPER(31:34) = Signed neutralino masses
47802C SUPER(35:50) = Neutralino mixing matrix
47803C SUPER(51:52) = Signed chargino masses
47804C SUPER(53:54) = Chargino left, right mixing angles
47805C SUPER(55:58) = mass of h0, H0, A0, H+
47806C SUPER(59) = Higgs mixing angle alpha
47807C SUPER(60:65) = A_t, theta_t, A_b, theta_b, A_tau, theta_tau
47808C SUPER(66) = Gravitino mass
47809C SUPER(67:69) = Top,Bottom, and Tau masses at MSUSY (not used)
47810C SUPER(70) = b-Yukawa at mA scale (not used)
47811C SUPER(71:72) = H_u, H_d vev's at MSUSY (not used)
47812C GSS: Filled by ISASUGRA
47813C GSS( 1) = g_1 GSS( 2) = g_2 GSS( 3) = g_3
47814C GSS( 4) = y_tau GSS( 5) = y_b GSS( 6) = y_t
47815C GSS( 7) = M_1 GSS( 8) = M_2 GSS( 9) = M_3
47816C GSS(10) = A_tau GSS(11) = A_b GSS(12) = A_t
47817C GSS(13) = M_h12 GSS(14) = M_h22 GSS(15) = M_er2
47818C GSS(16) = M_el2 GSS(17) = M_dnr2 GSS(18) = M_upr2
47819C GSS(19) = M_upl2 GSS(20) = M_taur2 GSS(21) = M_taul2
47820C GSS(22) = M_btr2 GSS(23) = M_tpr2 GSS(24) = M_tpl2
47821C GSS(25) = mu GSS(26) = B GSS(27) = Y_N
47822C GSS(28) = M_nr GSS(29) = A_n GSS(30) = log(vdq)
47823C GSS(31) = log(vuq)
47824C MSS: Filled by ISASUGRA
47825C MSS( 1) = glss MSS( 2) = upl MSS( 3) = upr
47826C MSS( 4) = dnl MSS( 5) = dnr MSS( 6) = stl
47827C MSS( 7) = str MSS( 8) = chl MSS( 9) = chr
47828C MSS(10) = b1 MSS(11) = b2 MSS(12) = t1
47829C MSS(13) = t2 MSS(14) = nuel MSS(15) = numl
47830C MSS(16) = nutl MSS(17) = el- MSS(18) = er-
47831C MSS(19) = mul- MSS(20) = mur- MSS(21) = tau1
47832C MSS(22) = tau2 MSS(23) = z1ss MSS(24) = z2ss
47833C MSS(25) = z3ss MSS(26) = z4ss MSS(27) = w1ss
47834C MSS(28) = w2ss MSS(29) = hl0 MSS(30) = hh0
47835C MSS(31) = ha0 MSS(32) = h+
47836C Unification, filled by ISASUGRA if applicable.
47837C MGUTSS = M_GUT GGUTSS = g_GUT AGUTSS = alpha_GUTC
47838
47839C...SPYTHIA Input/Output
47840 INTEGER IMSS
47841 DOUBLE PRECISION RMSS
47842 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
47843 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
47844 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
47845C...SLHA Input/Output
47846 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
47847 & AU(3,3),AD(3,3),AE(3,3)
47848C...PYTHIA common blocks
47849 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
47850 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
47851 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
47852
47853 SAVE /PYMSSM/,/PYSSMT/,/PYLH3P/,/PYDAT1/,/PYPARS/,/PYDAT2/
47854CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
47855 INTEGER IMODEL
47856 REAL M0,MHF,A0,MT
47857 CHARACTER*20 CHMOD(5)
47858 CHARACTER*32 FNAME
47859
47860 COMMON /SUGNU/ XNUSUG(18)
47861 REAL XNUSUG
47862 SAVE /SUGNU/
47863
47864 DATA CHMOD/'mSUGRA','mGMSB','non-universal SUGRA',
47865 & 'truly unified SUGRA', 'non-minimal GMSB'/
47866
47867C...Start by checking for incompatibilities/inconsistencies:
47868 DO 100 ICHK=2,9
47869 IF (ICHK.NE.8.AND.ICHK.NE.4.AND.IMSS(ICHK).NE.0) THEN
47870 WRITE (MSTU(11),*) '(PYSUGI:) IMSS(',ICHK,')=',IMSS(ICHK)
47871 & ,' option not used by PYSUGI'
47872 ENDIF
47873 100 CONTINUE
47874C...ISAJET works with REAL numbers.
47875 MZERO=REAL(RMSS(8))
47876 MHLF=REAL(RMSS(1))
47877 AZERO=REAL(RMSS(16))
47878 TANB=REAL(RMSS(5))
47879 SGNMU=REAL(RMSS(4))
47880 MTOP=REAL(PMAS(6,1))
47881 IMODEL=0
47882 IF (IMSS(1).EQ.12) THEN
47883 IMODEL=1
47884 GOTO 130
47885 ELSEIF(IMSS(1).EQ.13) THEN
47886C...Read from isajet par file in IMSS(20)
47887 LFN=IMSS(20)
47888C...STOP IF LFN IS ZERO (i.e. if no LFN was given).
47889 IF (LFN.EQ.0) THEN
47890 WRITE(MSTU(11),*) '(PYSUGI:) No valid unit given in IMSS(20)'
47891 GOTO 9999
47892 ENDIF
47893 WRITE(MSTU(11),*) 'READING SUSY MODEL FROM FILE...'
47894CMrenna change to allow any susy model
47895 WRITE(MSTU(11),*) 'ENTER 1 for mSUGRA:'
47896 WRITE(MSTU(11),*) 'ENTER 2 for mGMSB:'
47897 WRITE(MSTU(11),*) 'ENTER 3 for non-universal SUGRA:'
47898 WRITE(MSTU(11),*) 'ENTER 4 for SUGRA with truly unified'//
47899 & ' gauge couplings:'
47900 WRITE(MSTU(11),*) 'ENTER 5 for non-minimal GMSB:'
47901 READ(LFN,*) IMODEL
47902 IF (IMODEL.EQ.4) THEN
47903 IAL3UN=1
47904 IMODEL=1
47905 ENDIF
47906 IF (IMODEL.EQ.1.OR.IMODEL.EQ.3) THEN
47907 WRITE(MSTU(11),*) 'ENTER M_0, M_(1/2), A_0, tan(beta),'
47908 & //' sgn(mu), M_t:'
47909 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT
47910 IF (IMODEL.EQ.3) THEN
47911 IMODEL=1
47912 110 WRITE(MSTU(11),*) ' ENTER 1,...,5 for NUSUGx keyword;'
47913 & //' 0 to continue:'
47914 WRITE(MSTU(11),*) ' NUSUG1 = GUT scale gaugino masses'
47915 WRITE(MSTU(11),*) ' NUSUG2 = GUT scale A terms'
47916 WRITE(MSTU(11),*) ' NUSUG3 = GUT scale Higgs masses'
47917 WRITE(MSTU(11),*) ' NUSUG4 = GUT scale 1st/2nd'
47918 & //' generation masses'
47919 WRITE(MSTU(11),*)
47920 & ' NUSUG5 = GUT scale 3rd generation masses'
47921 READ(LFN,*) INUSUG
47922 IF (INUSUG.EQ.0) THEN
47923 GOTO 120
47924 ELSEIF (INUSUG.EQ.1) THEN
47925 WRITE(MSTU(11),*) 'Enter GUT scale M_1, M_2, M_3:'
47926 READ(LFN,*) XNUSUG(1),XNUSUG(2),XNUSUG(3)
47927 IF (XNUSUG(3).LE.0.) THEN
47928 WRITE(MSTU(11),*) ' NEGATIVE M_3 IS NOT ALLOWED'
47929 CALL PYSTOP(109)
47930 END IF
47931 ELSEIF (INUSUG.EQ.2) THEN
47932 WRITE(MSTU(11),*) 'Enter GUT scale A_t, A_b, A_tau:'
47933 READ(LFN,*) XNUSUG(6),XNUSUG(5),XNUSUG(4)
47934 ELSEIF (INUSUG.EQ.3) THEN
47935 WRITE(MSTU(11),*) 'Enter GUT scale m_Hd, m_Hu:'
47936 READ(LFN,*) XNUSUG(7),XNUSUG(8)
47937 ELSEIF (INUSUG.EQ.4) THEN
47938 WRITE(MSTU(11),*) 'Enter GUT scale M(ul), M(dr),'
47939 & //' M(ur), M(el), M(er):'
47940 READ(LFN,*) XNUSUG(13),XNUSUG(11),XNUSUG(12),
47941 & XNUSUG(10),XNUSUG(9)
47942 ELSEIF (INUSUG.EQ.5) THEN
47943 WRITE(MSTU(11),*) 'Enter GUT scale M(tl), M(br), M(tr),'
47944 & //' M(Ll), M(Lr):'
47945 READ(LFN,*) XNUSUG(18),XNUSUG(16),XNUSUG(17),
47946 & XNUSUG(15),XNUSUG(14)
47947 ENDIF
47948 GOTO 110
47949 ENDIF
47950 ELSEIF (IMODEL.EQ.2.OR.IMODEL.EQ.5) THEN
47951 IMSS(11)=1
47952 WRITE(MSTU(11),*) 'ENTER Lambda, M_mes, N_5, tan(beta),'
47953 & ,' sgn(mu), M_t, C_gv:'
47954 READ(LFN,*) M0,MHF,A0,TANB,SGNMU,MT,XCMGV
47955 XGMIN(7)=XCMGV
47956 XGMIN(8)=1.
47957C...Planck scale: AMPL = 2.4 E18 GeV = {8 pi G_newton}^{1/2}
47958 AMPL=2.4D18
47959 AMGVSS=M0*MHF*XCMGV/SQRT(3D0)/AMPL
47960 IF (IMODEL.EQ.5) THEN
47961 IMODEL=2
47962 WRITE(MSTU(11),*) 'Rsl = factor multiplying gaugino'
47963 & ,' masses at M_mes'
47964 WRITE(MSTU(11),*) 'dmH_d2, dmH_u2 = Higgs mass**2'
47965 & ,' shifts at M_mes'
47966 WRITE(MSTU(11),*) 'd_Y = mass**2 shifts proportional to',
47967 & ' Y at M_mes'
47968 WRITE(MSTU(11),*) 'n5_1,n5_2,n5_3 = n5 values for U(1),'
47969 & ,'SU(2),SU(3)'
47970 WRITE(MSTU(11),*) 'ENTER Rsl, dmH_d2, dmH_u2, d_Y, n5_1,'
47971 & ,' n5_2, n5_3'
47972 READ(LFN,*) XGMIN(8),XGMIN(9),XGMIN(10),XGMIN(11),XGMIN(12),
47973 $ XGMIN(13),XGMIN(14)
47974 ENDIF
47975 ELSE
47976 WRITE(MSTU(11),*) 'Invalid model choice.'
47977 GOTO 9999
47978 ENDIF
47979 ENDIF
47980
47981 120 MZERO=M0
47982 MHLF=MHF
47983 AZERO=A0
47984C TANB=REAL(RMSS(5))
47985C SGNMU=REAL(RMSS(4))
47986 MTOP=MT
47987
47988C...Initialize MSSM parameter array
47989 130 DO 140 IPAR=1,72
47990 SUPER(IPAR)=0.0
47991 140 CONTINUE
47992C...Call ISASUGRA
47993 CALL SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODEL)
47994C...Check whether ISASUSY thought the model was OK.
47995 IF (NOGOOD.NE.0) THEN
47996 IF (NOGOOD.EQ.1) CALL PYERRM(26
47997 & ,'(PYSUGI:) SUSY parameters give tachyonic particles.')
47998 IF (NOGOOD.EQ.2) CALL PYERRM(26
47999 & ,'(PYSUGI:) SUSY parameters give no EWSB.')
48000 IF (NOGOOD.EQ.3) CALL PYERRM(26
48001 & ,'(PYSUGI:) SUSY parameters give m(A0) < 0.')
48002 IF (NOGOOD.EQ.4) CALL PYERRM(26
48003 & ,'(PYSUGI:) SUSY parameters give Yukawa > 100.')
48004 IF (NOGOOD.EQ.7) CALL PYERRM(26
48005 & ,'(PYSUGI:) SUSY parameters give x_T EWSB bad.')
48006 IF (NOGOOD.EQ.8) CALL PYERRM(26
48007 & ,'(PYSUGI:) SUSY parameters give m(h0)2 < 0.')
48008C...Give warning, but don't stop, if LSP not ~chi_10.
48009 IF (NOGOOD.EQ.5) CALL PYERRM(16
48010 & ,'(PYSUGI:) SUSY parameters give ~chi_10 not LSP.')
48011 ENDIF
48012C...Warn about possible GUT scale tachyons.
48013 IF (ITACHY.NE.0) CALL PYERRM(16,
48014 & '(PYSUGI:) Tachyonic sleptons at GUT scale.')
48015C...Finalize spectrum (last iteration)
48016C...(Thanks to A. Raklev for pointing this out.)
48017C...NB: SSMSSM also calculates decays, but these are not used by Pythia.
48018 CALL SSMSSM(XISAIN(1),XISAIN(2),XISAIN(3),
48019 $ XISAIN(4),XISAIN(5),XISAIN(6),XISAIN(7),XISAIN(8),XISAIN(9),
48020 $ XISAIN(10),XISAIN(11),XISAIN(12),XISAIN(13),XISAIN(14),
48021 $ XISAIN(15),XISAIN(16),XISAIN(17),XISAIN(18),XISAIN(19),
48022 $ XISAIN(20),XISAIN(21),XISAIN(22),XISAIN(23),XISAIN(24),
48023 $ MTOP,IALLOW,1)
48024
48025C...M1, M2, M3.
48026 RMSS(1)=dble(GSS(7))
48027 RMSS(2)=dble(GSS(8))
48028 RMSS(3)=dble(GSS(9))
48029 RMSOFT(1)=dble(GSS(7))
48030 RMSOFT(2)=dble(GSS(8))
48031 RMSOFT(3)=dble(GSS(9))
48032C...Mu = - Higgsino mass.
48033 RMSS(4)=-SUPER(29)
48034 RMSS(5)=TANB
48035C...Slepton and squark masses. 2 first generations.
48036 RMSS(6)=0.5*(SUPER(18)+SUPER(20))
48037 RMSS(7)=0.5*(SUPER(19)+SUPER(21))
48038 RMSS(8)=0.25*(SUPER(2)+SUPER(4)+SUPER(6)+SUPER(8))
48039 RMSS(9)=0.25*(SUPER(3)+SUPER(5)+SUPER(7)+SUPER(9))
48040C...Third generation.
48041 RMSS(10)=0.5*(SUPER(14)+SUPER(10))
48042 RMSS(11)=SUPER(11)
48043 RMSS(12)=SUPER(15)
48044 RMSS(13)=SUPER(22)
48045 RMSS(14)=SUPER(23)
48046C...SLHA: store exact soft spectrum in RMSOFT
48047 RMSOFT(31)=SUPER(18)
48048 RMSOFT(32)=SUPER(20)
48049 RMSOFT(33)=SUPER(22)
48050 RMSOFT(34)=SUPER(19)
48051 RMSOFT(35)=SUPER(21)
48052 RMSOFT(36)=SUPER(23)
48053 RMSOFT(41)=0.5D0*(SUPER(2)+SUPER(4))
48054 RMSOFT(42)=0.5D0*(SUPER(6)+SUPER(8))
48055 RMSOFT(43)=0.5D0*(SUPER(10)+SUPER(14))
48056 RMSOFT(44)=SUPER(3)
48057 RMSOFT(45)=SUPER(9)
48058 RMSOFT(46)=SUPER(15)
48059 RMSOFT(47)=SUPER(5)
48060 RMSOFT(48)=SUPER(7)
48061 RMSOFT(49)=SUPER(11)
48062
48063C...~b, ~t, and ~tau trilinear couplings and mixing angles.
48064 RMSS(15)=SUPER(62)
48065 RMSS(16)=SUPER(60)
48066 RMSS(17)=SUPER(64)
48067 RMSS(26)=SUPER(63)
48068 RMSS(27)=SUPER(61)
48069 RMSS(28)=SUPER(65)
48070C...SLHA trilinears
48071 DO 142 K1=1,3
48072 DO 141 K2=1,3
48073 AE(K1,K2)=0D0
48074 AU(K1,K2)=0D0
48075 AD(K1,K2)=0D0
48076 141 CONTINUE
48077 142 CONTINUE
48078 AE(3,3)=SUPER(64)
48079 AU(3,3)=SUPER(60)
48080 AD(3,3)=SUPER(62)
48081C...Higgs mixing angle alpha (Gunion-Haber convention).
48082 RMSS(18)=-SUPER(59)
48083C...A0 mass.
48084 RMSS(19)=SUPER(57)
48085C...GUT scale coupling
48086 RMSS(20)=AGUTSS
48087C...Gravitino mass (for future compatibility)
48088 RMSS(21)=MAX(RMSS(21),DBLE(SUPER(66)))
48089
48090C...Now we're done with RMSS. Time to fill PMAS (m > 0 required).
48091C...Higgs sector.
48092 PMAS(PYCOMP(25),1)=ABS(SUPER(55))
48093 PMAS(PYCOMP(35),1)=ABS(SUPER(56))
48094 PMAS(PYCOMP(36),1)=ABS(SUPER(57))
48095 PMAS(PYCOMP(37),1)=ABS(SUPER(58))
48096C...Gluino.
48097 PMAS(PYCOMP(KSUSY1+21),1)=ABS(SUPER(1))
48098C...Squarks and Sleptons.
48099 DO 150 ILR=1,2
48100 ILRM=ILR-1
48101 PMAS(PYCOMP(ILR*KSUSY1+1),1)=ABS(SUPER(4+ILRM))
48102 PMAS(PYCOMP(ILR*KSUSY1+2),1)=ABS(SUPER(2+ILRM))
48103 PMAS(PYCOMP(ILR*KSUSY1+3),1)=ABS(SUPER(6+ILRM))
48104 PMAS(PYCOMP(ILR*KSUSY1+4),1)=ABS(SUPER(8+ILRM))
48105 PMAS(PYCOMP(ILR*KSUSY1+5),1)=ABS(SUPER(12+ILRM))
48106 PMAS(PYCOMP(ILR*KSUSY1+6),1)=ABS(SUPER(16+ILRM))
48107 PMAS(PYCOMP(ILR*KSUSY1+11),1)=ABS(SUPER(18+ILRM))
48108 PMAS(PYCOMP(ILR*KSUSY1+13),1)=ABS(SUPER(20+ILRM))
48109 PMAS(PYCOMP(ILR*KSUSY1+15),1)=ABS(SUPER(24+ILRM))
48110 150 CONTINUE
48111 PMAS(PYCOMP(KSUSY1+12),1)=ABS(SUPER(26))
48112 PMAS(PYCOMP(KSUSY1+14),1)=ABS(SUPER(27))
48113 PMAS(PYCOMP(KSUSY1+16),1)=ABS(SUPER(28))
48114C...Neutralinos.
48115 PMAS(PYCOMP(KSUSY1+22),1)=ABS(SUPER(31))
48116 PMAS(PYCOMP(KSUSY1+23),1)=ABS(SUPER(32))
48117 PMAS(PYCOMP(KSUSY1+25),1)=ABS(SUPER(33))
48118 PMAS(PYCOMP(KSUSY1+35),1)=ABS(SUPER(34))
48119C...Signed masses (extra minus from going to G-H convention).
48120 SMZ(1)=-SUPER(31)
48121 SMZ(2)=-SUPER(32)
48122 SMZ(3)=-SUPER(33)
48123 SMZ(4)=-SUPER(34)
48124C...Charginos
48125 PMAS(PYCOMP(KSUSY1+24),1)=ABS(SUPER(51))
48126 PMAS(PYCOMP(KSUSY1+37),1)=ABS(SUPER(52))
48127C...Signed masses (extra minus from going to G-H convention).
48128 SMW(1)=-SUPER(51)
48129 SMW(2)=-SUPER(52)
48130
48131C... Neutralino Mixing.
48132 DO 160 IN=1,4
48133 ZMIX(IN,1)= SUPER(38+4*(IN-1))
48134 ZMIX(IN,2)= SUPER(37+4*(IN-1))
48135 ZMIX(IN,3)=-SUPER(36+4*(IN-1))
48136 ZMIX(IN,4)=-SUPER(35+4*(IN-1))
48137 160 CONTINUE
48138C...Chargino Mixing (PYTHIA same angle as HERWIG).
48139 THX=1D0
48140 THY=1D0
48141 IF (SUPER(53).GT.0) THX=-1D0
48142 IF (SUPER(54).GT.0) THY=-1D0
48143 UMIX(1,1) = -SIN(SUPER(53))
48144 UMIX(1,2) = -COS(SUPER(53))
48145 UMIX(2,1) = -THX*COS(SUPER(53))
48146 UMIX(2,2) = THX*SIN(SUPER(53))
48147 VMIX(1,1) = -SIN(SUPER(54))
48148 VMIX(1,2) = -COS(SUPER(54))
48149 VMIX(2,1) = -THY*COS(SUPER(54))
48150 VMIX(2,2) = THY*SIN(SUPER(54))
48151C...Sfermion mixing (PYTHIA same angle as ISAJET)
48152 SFMIX(5,1)=COS(SUPER(63))
48153 SFMIX(5,2)=SIN(SUPER(63))
48154 SFMIX(5,3)=-SIN(SUPER(63))
48155 SFMIX(5,4)=COS(SUPER(63))
48156 SFMIX(6,1)=COS(SUPER(61))
48157 SFMIX(6,2)=SIN(SUPER(61))
48158 SFMIX(6,3)=-SIN(SUPER(61))
48159 SFMIX(6,4)=COS(SUPER(61))
48160 SFMIX(15,1)=COS(SUPER(65))
48161 SFMIX(15,2)=SIN(SUPER(65))
48162 SFMIX(15,3)=-SIN(SUPER(65))
48163 SFMIX(15,4)=COS(SUPER(65))
48164
48165 IF (MSTP(122).NE.0) THEN
48166C...Print a few lines to make the user know what's happening
48167 ISAVER=VISAJE()
48168 WRITE(MSTU(11),5000) DOC, ISAVER
48169 WRITE(MSTU(11),5100)
48170 IF (IMODEL.EQ.1) THEN
48171 WRITE(MSTU(11),5200) MZERO, MHLF, AZERO, TANB, NINT(SGNMU),
48172 & MTOP
48173 WRITE(MSTU(11),5300)
48174 ENDIF
48175 WRITE(MSTU(11),5500) 'Pole masses'
48176 WRITE(MSTU(11),5700) (SUPER(IP),IP=2,16,2),(SUPER(IP),IP=3,17,2)
48177 WRITE(MSTU(11),5800) (SUPER(IP),IP=18,24,2),(SUPER(IP),IP=26,28)
48178 & ,(SUPER(IP),IP=19,25,2)
48179 WRITE(MSTU(11),5900) SUPER(1),(SMZ(IP),IP=1,4), (SMW(IP)
48180 & ,IP=1,2)
48181 WRITE(MSTU(11),5400)
48182 WRITE(MSTU(11),6000) (SUPER(IP),IP=55,58)
48183 WRITE(MSTU(11),5400)
48184 WRITE(MSTU(11),5500) 'EW scale mixing structure'
48185 WRITE(MSTU(11),6100) ((ZMIX(I,J), J=1,4),I=1,4)
48186 WRITE(MSTU(11),6200) (UMIX(1,J), J=1,2),(VMIX(1,J),J=1,2)
48187 & ,(UMIX(2,J), J=1,2),(VMIX(2,J),J=1,2)
48188 WRITE(MSTU(11),6300) (SFMIX(5,J), J=1,2),(SFMIX(6,J),J=1,2)
48189 & ,(SFMIX(15,J), J=1,2),(SFMIX(5,J),J=3,4),(SFMIX(6,J), J=3,4
48190 & ),(SFMIX(15,J),J=3,4)
48191 WRITE(MSTU(11),5400)
48192 WRITE(MSTU(11),6450) RMSS(18)
48193 WRITE(MSTU(11),5400)
48194 WRITE(MSTU(11),5500) 'Couplings'
48195 WRITE(MSTU(11),6400) RMSS(15),RMSS(16),RMSS(17),RMSS(20)
48196 WRITE(MSTU(11),5400)
48197 ENDIF
48198
48199C...Call FeynHiggs to improve Higgs sector if requested
48200 IF (IMSS(4).EQ.3) THEN
48201 IF (MSTP(122).NE.0) WRITE(MSTU(11),'(1x,"*"/1x,"*",A)')
48202 & ' (PYSUGI:) Now calling FeynHiggs.'
48203 CALL PYFEYN(IERR)
48204 IF (IERR.EQ.0) THEN
48205 IMSS(4)=2
48206 IF (MSTP(122).NE.0) THEN
48207 WRITE(MSTU(11),5400)
48208 WRITE(MSTU(11),5500)
48209 & 'Corrected Higgs masses and mixing'
48210 WRITE(MSTU(11),6000) PMAS(25,1),PMAS(35,1),PMAS(36,1),
48211 & PMAS(37,1)
48212 WRITE(MSTU(11),6450) RMSS(18)
48213 WRITE(MSTU(11),5400)
48214 ENDIF
48215 ENDIF
48216 ENDIF
48217
48218 IF (MSTP(122).NE.0) WRITE(MSTU(11),6500)
48219
48220C...Fix the higgs sector (in PYMSIN) using the masses and mixing angle
48221C...output by ISASUSY.
48222 IMSS(4)=MAX(2,IMSS(4))
48223
48224 5000 FORMAT(1x,19('*'),1x,'PYSUGI v1.52: PYTHIA/ISASUSY '
48225 & ,'INTERFACE',1x,19('*')/1x,'*',3x,'PYSUGI: Last Change',1x,A
48226 & ,1x,'-',1x,'P. Skands / S. Mrenna'/1x,'*',2x,A/1x,'*')
48227 5100 FORMAT(1x,'*',1x,'ISASUSY Input:'/1x,'*',1x,'----------------')
48228 5200 FORMAT(1x,'*',1x,3x,'M_0',6x,'M_1/2',5x,'A_0',3x,'Tan(beta)',
48229 & 3x,'Sgn(mu)',3x,'M_t'/1x,'*',1x,4(F8.2,1x),I8,2x,F8.2)
48230 5300 FORMAT(1x,'*'/1x,'*',1x,'ISASUSY Output:'/1x,'*',1x
48231 & ,'----------------')
48232 5400 FORMAT(1x,'*',1x,A)
48233 5500 FORMAT(1x,'*',1x,A,':')
48234 5600 FORMAT(1x,'*',2x,2x,'M_GUT',2x,2x,'g_GUT',2x,1x,'alpha_GUT'/
48235 & 1x,'*',2x,1P,2(1x,E8.2),2x,E8.2)
48236 5700 FORMAT(1x,'*',4x,4x,'~u',2x,1x,4x,'~d',2x,1x,4x,'~s',2x,1x,
48237 & 4x,'~c',2x,1x,4x,'~b',2x,1x,2x,'~b(12)',1x,4x,'~t',2x,1x, 2x,
48238 & '~t(12)'/1x,'*',2x,'L',1x,8(F8.2,1x)/1x,'*',2x,'R',1x,8(F8.2
48239 & ,1x))
48240 5800 FORMAT(1x,'*'/1x,'*',4x,4x,'~e',2x,1x,3x,'~mu',2x,1x,3x,'~tau',1x
48241 & ,1x,'~tau(12)',1x,2x,'~nu_e',1x,1x,1x,'~nu_mu',1x,1x,1x
48242 & ,'~nu_tau'/1x,'*',2x,'L',1x,7(F8.2,1x)/1x,'*',2x,'R',1x,4(F8
48243 & .2,1x))
48244 5900 FORMAT(1x,'*'/1x,'*',4x,4x,'~g',2x,1x,1x,'~chi_10',1x,1x,'~chi_20'
48245 & ,1x,1x,'~chi_30',1x,1x,'~chi_40',1x,1x,'~chi_1+',1x
48246 & ,1x,'~chi_2+'/1x,'*',3x,1x,7(F8.2,1x))
48247 6000 FORMAT(1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
48248 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x))
48249 6050 FORMAT(1x,'*'/1x,'*',4x,4x,'h0',2x,1x,4x,'H0',2x,1x,4x,'A0',2x
48250 & ,1x,4x,'H+'/1x,'*',3x,1x,5(F8.2,1x),3x,'(Before FeynHiggs)')
48251 6100 FORMAT(1x,'*',11x,'|',3x,'~B',3x,'|',2x,'~W_3',2x,'|',2x
48252 & ,'~H_1',2x,'|',2x,'~H_2',2x,'|'/1x,'*',3x,'~chi_10',1x,4('|'
48253 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_20',1x,4('|'
48254 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_30',1x,4('|'
48255 & ,1x,F6.3,1x),'|'/1x,'*',3x,'~chi_40',1x,4('|'
48256 & ,1x,F6.3,1x),'|')
48257 6200 FORMAT(1x,'*'/1x,'*',6x,'L',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'
48258 & ,12x,'R',4x,'|',3x,'~W',3x,'|',3x,'~H',3x,'|'/1x,'*',3x
48259 & ,'~chi_1+',1x,2('|',1x,F6.3,1x),'|',9x,'~chi_1+',1x,2('|',1x
48260 & ,F6.3,1x),'|'/1x,'*',3x,'~chi_2+',1x,2('|',1x,F6.3,1x),'|',9x
48261 & ,'~chi_2+',1x,2('|',1x,F6.3,1x),'|')
48262 6300 FORMAT(1x,'*'/1x,'*',8x,'|',2x,'~b_L',2x,'|',2x,'~b_R',2x,'|',8x
48263 & ,'|',2x,'~t_L',2x,'|',2x,'~t_R',2x,'|',10x
48264 & ,'|',1x,'~tau_L',1x,'|',1x,'~tau_R',1x,'|'/
48265 & 1x,'*',3x,'~b_1',1x,2('|',1x,F6.3,1x),'|',3x,'~t_1',1x,2('|'
48266 & ,1x,F6.3,1x),'|',3x,'~tau_1',1x,2('|',1x,F6.3,1x),'|'/
48267 & 1x,'*',3x,'~b_2',1x,2('|',1x,F6.3,1x),'|',3x,'~t_2',1x,2('|'
48268 & ,1x,F6.3,1x),'|',3x,'~tau_2',1x,2('|',1x,F6.3,1x),'|')
48269 6400 FORMAT(1x,'*',3x,'A_b = ',F8.2,4x,'A_t = ',F8.2,4x,'A_tau = ',F8.2
48270 & ,4x,'Alpha_GUT = ',F8.2)
48271 6450 FORMAT(1x,'*',3x,'Alpha_Higgs = ',F8.4)
48272 6500 FORMAT(1x,32('*'),1x,'END OF PYSUGI',1x,31('*'))
48273
48274 9999 RETURN
48275 END
48276
48277C*********************************************************************
48278
48279C...PYFEYN
48280C...Interface to FeynHiggs for MSSM Higgs sector.
48281C...Pythia6.402: Updated to FeynHiggs v.2.3.0+ w/ DOUBLE COMPLEX
48282C...P. Skands
48283
48284 SUBROUTINE PYFEYN(IERR)
48285
48286C...Double precision and integer declarations.
48287 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48288 IMPLICIT INTEGER(I-N)
48289 INTEGER PYK,PYCHGE,PYCOMP
48290C...Commonblocks.
48291 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48292 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48293C...SUSY blocks
48294 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48295C...FeynHiggs variables
48296 DOUBLE PRECISION RMHIGG(4)
48297 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
48298 DOUBLE COMPLEX DMU,
48299 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
48300 & DM1, DM2, DM3
48301C...SLHA Common Block
48302 COMMON/PYLH3P/MODSEL(200),PARMIN(100),PAREXT(200),RMSOFT(0:100),
48303 & AU(3,3),AD(3,3),AE(3,3)
48304 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYLH3P/
48305
48306 IERR=0
48307 CALL FHSETFLAGS(IERR,4,0,0,2,0,2,1,1)
48308 IF (IERR.NE.0) THEN
48309 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETFLAGS.'
48310 & //'Will not use FeynHiggs for this run.')
48311 RETURN
48312 ENDIF
48313 Q=RMSOFT(0)
48314 DMB=PMAS(5,1)
48315 DMT=PMAS(6,1)
48316 DMZ=PMAS(23,1)
48317 DMW=PMAS(24,1)
48318 DMA=PMAS(36,1)
48319 DM1=RMSOFT(1)
48320 DM2=RMSOFT(2)
48321 DM3=RMSOFT(3)
48322 DTANB=RMSS(5)
48323 DMU=RMSS(4)
48324 DM3SL=RMSOFT(33)
48325 DM3SE=RMSOFT(36)
48326 DM3SQ=RMSOFT(43)
48327 DM3SU=RMSOFT(46)
48328 DM3SD=RMSOFT(49)
48329 DM2SL=RMSOFT(32)
48330 DM2SE=RMSOFT(35)
48331 DM2SQ=RMSOFT(42)
48332 DM2SU=RMSOFT(45)
48333 DM2SD=RMSOFT(48)
48334 DM1SL=RMSOFT(31)
48335 DM1SE=RMSOFT(34)
48336 DM1SQ=RMSOFT(41)
48337 DM1SU=RMSOFT(44)
48338 DM1SD=RMSOFT(47)
48339 AE33=AE(3,3)
48340 AE22=AE(2,2)
48341 AE11=AE(1,1)
48342 AU33=AU(3,3)
48343 AU22=AU(2,2)
48344 AU11=AU(1,1)
48345 AD33=AD(3,3)
48346 AD22=AD(2,2)
48347 AD11=AD(1,1)
48348 CALL FHSETPARA(IERR, 1D0, DMT, DMB, DMW, DMZ, DTANB,
48349 & DMA,0D0, DM3SL, DM3SE, DM3SQ, DM3SU, DM3SD,
48350 & DM2SL, DM2SE, DM2SQ, DM2SU, DM2SD,
48351 & DM1SL, DM1SE, DM1SQ, DM1SU, DM1SD,DMU,
48352 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
48353 & DM1, DM2, DM3, 0D0, 0D0,Q,Q,Q)
48354 IF (IERR.NE.0) THEN
48355 CALL PYERRM(11,'(PYHGGM:) Caught error from FHSETPARA.'
48356 & //' Will not use FeynHiggs for this run.')
48357 RETURN
48358 ENDIF
48359C... Get Higgs masses & alpha_eff. (UHIGGS redundant here, only for CPV)
48360 SAEFF=0D0
48361 CALL FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
48362 IF (IERR.NE.0) THEN
48363 CALL PYERRM(11,'(PYFEYN:) Caught error from FHHIG'//
48364 & 'GSCORR. Will not use FeynHiggs for this run.')
48365 RETURN
48366 ENDIF
48367 ALPHA = ASIN(DBLE(SAEFF))
48368 R=RMSS(18)/ALPHA
48369 IF (R.LT.0D0.OR.ABS(R).GT.1.2D0.OR.ABS(R).LT.0.8D0) THEN
48370 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
48371 WRITE(MSTU(11),*) ' Old Alpha:', RMSS(18)
48372 WRITE(MSTU(11),*) ' New Alpha:', ALPHA
48373 ENDIF
48374 IF (RMHIGG(1).LT.0.85D0*PMAS(25,1).OR.RMHIGG(1).GT.
48375 & 1.15D0*PMAS(25,1)) THEN
48376 CALL PYERRM(1,'(PYFEYN:) Large corrections in Higgs sector.')
48377 WRITE(MSTU(11),*) ' Old m(h0):', PMAS(25,1)
48378 WRITE(MSTU(11),*) ' New m(h0):', RMHIGG(1)
48379 ENDIF
48380 RMSS(18)=ALPHA
48381 PMAS(25,1)=RMHIGG(1)
48382 PMAS(35,1)=RMHIGG(2)
48383 PMAS(36,1)=RMHIGG(3)
48384 PMAS(37,1)=RMHIGG(4)
48385
48386 RETURN
48387 END
48388
48389C*********************************************************************
48390
48391C...PYRNMQ
48392C...Determines the running mass of Squarks.
48393
48394 FUNCTION PYRNMQ(ID,DTERM)
48395
48396C...Double precision and integer declarations.
48397 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48398 IMPLICIT INTEGER(I-N)
48399 INTEGER PYK,PYCHGE,PYCOMP
48400C...Commonblock.
48401 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48402 SAVE /PYMSSM/
48403
48404C...Local variables.
48405 DOUBLE PRECISION PI,R
48406 DOUBLE PRECISION TOL
48407 DOUBLE PRECISION CI(3)
48408 EXTERNAL PYALPS
48409 DOUBLE PRECISION PYALPS
48410 DATA TOL/0.001D0/
48411 DATA PI,R/3.141592654D0,.61803399D0/
48412 DATA CI/0.47D0,0.07D0,0.02D0/
48413
48414 C=1D0-R
48415 CA=CI(ID)
48416 AG=(0.71D0)**2/4D0/PI
48417 AG=RMSS(20)
48418 XM0=RMSS(8)
48419 XMG=RMSS(1)
48420 XM02=XM0*XM0
48421 XMG2=XMG*XMG
48422
48423 AS=PYALPS(XM02+6D0*XMG2)
48424 CG=8D0/9D0*((AS/AG)**2-1D0)
48425 BX=XM02+(CA+CG)*XMG2+DTERM
48426 AX=MIN(50D0**2,0.5D0*BX)
48427 CX=MAX(2000D0**2,2D0*BX)
48428
48429 X0=AX
48430 X3=CX
48431 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
48432 X1=BX
48433 X2=BX+C*(CX-BX)
48434 ELSE
48435 X2=BX
48436 X1=BX-C*(BX-AX)
48437 ENDIF
48438 AS1=PYALPS(X1)
48439 CG=8D0/9D0*((AS1/AG)**2-1D0)
48440 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
48441 AS2=PYALPS(X2)
48442 CG=8D0/9D0*((AS2/AG)**2-1D0)
48443 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
48444 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
48445 IF(F2.LT.F1) THEN
48446 X0=X1
48447 X1=X2
48448 X2=R*X1+C*X3
48449 F1=F2
48450 AS2=PYALPS(X2)
48451 CG=8D0/9D0*((AS2/AG)**2-1D0)
48452 F2=ABS(XM02+(CA+CG)*XMG2+DTERM-X2)
48453 ELSE
48454 X3=X2
48455 X2=X1
48456 X1=R*X2+C*X0
48457 F2=F1
48458 AS1=PYALPS(X1)
48459 CG=8D0/9D0*((AS1/AG)**2-1D0)
48460 F1=ABS(XM02+(CA+CG)*XMG2+DTERM-X1)
48461 ENDIF
48462 GOTO 100
48463 ENDIF
48464 IF(F1.LT.F2) THEN
48465 PYRNMQ=X1
48466 XMIN=X1
48467 ELSE
48468 PYRNMQ=X2
48469 XMIN=X2
48470 ENDIF
48471
48472 RETURN
48473 END
48474
48475C*********************************************************************
48476
48477C...PYTHRG
48478C...Calculates the mass eigenstates of the third generation sfermions.
48479C...Created: 5-31-96
48480
48481 SUBROUTINE PYTHRG
48482
48483C...Double precision and integer declarations.
48484 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48485 IMPLICIT INTEGER(I-N)
48486 INTEGER PYK,PYCHGE,PYCOMP
48487C...Parameter statement to help give large particle numbers.
48488 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48489 &KEXCIT=4000000,KDIMEN=5000000)
48490C...Commonblocks.
48491 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48492 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48493 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48494 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48495 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48496 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
48497
48498C...Local variables.
48499 DOUBLE PRECISION BETA
48500 DOUBLE PRECISION AM2(2,2),RT(2,2),DI(2,2)
48501 DOUBLE PRECISION XMZ2,XMW2,TANB,XMU,COS2B,XMQL2,XMQR2
48502 DOUBLE PRECISION XMF,XMF2,DIFF,SAME,XMF12,XMF22,SMALL
48503 DOUBLE PRECISION ATR,AMQR,AMQL
48504 INTEGER ID1(3),ID2(3),ID3(3),ID4(3)
48505 INTEGER IF,I,J,II,JJ,IT,L
48506 LOGICAL DTERM
48507 DATA SMALL/1D-3/
48508 DATA ID1/10,10,13/
48509 DATA ID2/5,6,15/
48510 DATA ID3/15,16,17/
48511 DATA ID4/11,12,14/
48512 DATA DTERM/.TRUE./
48513
48514 XMZ2=PMAS(23,1)**2
48515 XMW2=PMAS(24,1)**2
48516 TANB=RMSS(5)
48517 XMU=-RMSS(4)
48518 BETA=ATAN(TANB)
48519 COS2B=COS(2D0*BETA)
48520
48521C...OPTION TO FIX T1, T2, B1 MASSES AND MIXINGS
48522
48523 IOPT=IMSS(5)
48524 IF(IOPT.EQ.1) THEN
48525 CTT=DCOS(RMSS(27))
48526 CTT2=CTT**2
48527 STT=DSIN(RMSS(27))
48528 STT2=STT**2
48529 XM12=RMSS(10)**2
48530 XM22=RMSS(12)**2
48531 XMQL2=CTT2*XM12+STT2*XM22
48532 XMQR2=STT2*XM12+CTT2*XM22
48533 XMF2=PYMRUN(6,PMAS(6,1)**2)**2
48534 ATOP=-XMU/TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
48535 RMSS(16)=ATOP
48536C......SUBTRACT OUT D-TERM AND FERMION MASS
48537 XMQL2=XMQL2-XMF2-(4D0*XMW2-XMZ2)*COS2B/6D0
48538 XMQR2=XMQR2-XMF2+(XMW2-XMZ2)*COS2B*2D0/3D0
48539 IF(XMQL2.GE.0D0) THEN
48540 RMSS(10)=SQRT(XMQL2)
48541 ELSE
48542 RMSS(10)=-SQRT(-XMQL2)
48543 ENDIF
48544 IF(XMQR2.GE.0D0) THEN
48545 RMSS(12)=SQRT(XMQR2)
48546 ELSE
48547 RMSS(12)=-SQRT(-XMQR2)
48548 ENDIF
48549
48550C SAME FOR BOTTOM SQUARK
48551 CTT=DCOS(RMSS(26))
48552 CTT2=CTT**2
48553 STT=DSIN(RMSS(26))
48554 STT2=STT**2
48555 XM22=RMSS(11)**2
48556 XMF2=PYMRUN(5,PMAS(6,1)**2)**2
48557 XMQL2=SIGN(RMSS(10)**2,RMSS(10))-(2D0*XMW2+XMZ2)*COS2B/6D0+XMF2
48558 IF(ABS(CTT).GE..9999D0) THEN
48559 ABOT=-XMU*TANB
48560 XMQR2=RMSS(11)**2
48561 ELSEIF(ABS(CTT).LE.1D-4) THEN
48562 ABOT=-XMU*TANB
48563 XMQR2=RMSS(11)**2
48564 ELSE
48565 XM12=(XMQL2-STT2*XM22)/CTT2
48566 XMQR2=STT2*XM12+CTT2*XM22
48567 ABOT=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
48568 ENDIF
48569 RMSS(15)=ABOT
48570C......SUBTRACT OUT D-TERM AND FERMION MASS
48571 XMQR2=XMQR2-(XMW2-XMZ2)*COS2B/3D0-XMF2
48572 IF(XMQR2.GE.0D0) THEN
48573 RMSS(11)=SQRT(XMQR2)
48574 ELSE
48575 RMSS(11)=-SQRT(-XMQR2)
48576 ENDIF
48577C SAME FOR TAU SLEPTON
48578 CTT=DCOS(RMSS(28))
48579 CTT2=CTT**2
48580 STT=DSIN(RMSS(28))
48581 STT2=STT**2
48582 XM12=RMSS(13)**2
48583 XM22=RMSS(14)**2
48584 XMQL2=CTT2*XM12+STT2*XM22
48585 XMQR2=STT2*XM12+CTT2*XM22
48586 XMFR=PMAS(15,1)
48587 XMF2=XMFR**2
48588 ATAU=-XMU*TANB+CTT*STT*(XM12-XM22)/SQRT(XMF2)
48589 RMSS(17)=ATAU
48590C......SUBTRACT OUT D-TERM AND FERMION MASS
48591 XMQL2=XMQL2-XMF2+(-.5D0*XMZ2+XMW2)*COS2B
48592 XMQR2=XMQR2-XMF2+(XMZ2-XMW2)*COS2B
48593 IF(XMQL2.GE.0D0) THEN
48594 RMSS(13)=SQRT(XMQL2)
48595 ELSE
48596 RMSS(13)=-SQRT(-XMQL2)
48597 ENDIF
48598 IF(XMQR2.GE.0D0) THEN
48599 RMSS(14)=SQRT(XMQR2)
48600 ELSE
48601 RMSS(14)=-SQRT(-XMQR2)
48602 ENDIF
48603 ENDIF
48604 DO 170 L=1,3
48605 AMQL=RMSS(ID1(L))
48606 IF(AMQL.LT.0D0) THEN
48607 XMQL2=-AMQL**2
48608 ELSE
48609 XMQL2=AMQL**2
48610 ENDIF
48611 ATR=RMSS(ID3(L))
48612 AMQR=RMSS(ID4(L))
48613 IF(AMQR.LT.0D0) THEN
48614 XMQR2=-AMQR**2
48615 ELSE
48616 XMQR2=AMQR**2
48617 ENDIF
48618 IF=ID2(L)
48619 XMF=PYMRUN(IF,PMAS(6,1)**2)
48620 XMF2=XMF**2
48621 AM2(1,1)=XMQL2+XMF2
48622 AM2(2,2)=XMQR2+XMF2
48623 IF(AM2(1,1).EQ.AM2(2,2)) AM2(2,2)=AM2(2,2)*1.00001D0
48624 IF(DTERM) THEN
48625 IF(L.EQ.1) THEN
48626 AM2(1,1)=AM2(1,1)-(2D0*XMW2+XMZ2)*COS2B/6D0
48627 AM2(2,2)=AM2(2,2)+(XMW2-XMZ2)*COS2B/3D0
48628 AM2(1,2)=XMF*(ATR+XMU*TANB)
48629 ELSEIF(L.EQ.2) THEN
48630 AM2(1,1)=AM2(1,1)+(4D0*XMW2-XMZ2)*COS2B/6D0
48631 AM2(2,2)=AM2(2,2)-(XMW2-XMZ2)*COS2B*2D0/3D0
48632 AM2(1,2)=XMF*(ATR+XMU/TANB)
48633 ELSEIF(L.EQ.3) THEN
48634 IF(IMSS(8).EQ.1) THEN
48635 AM2(1,1)=RMSS(6)**2
48636 AM2(2,2)=RMSS(7)**2
48637 AM2(1,2)=0D0
48638 RMSS(13)=RMSS(6)
48639 RMSS(14)=RMSS(7)
48640 ELSE
48641 AM2(1,1)=AM2(1,1)-(-.5D0*XMZ2+XMW2)*COS2B
48642 AM2(2,2)=AM2(2,2)-(XMZ2-XMW2)*COS2B
48643 AM2(1,2)=XMF*(ATR+XMU*TANB)
48644 ENDIF
48645 ENDIF
48646 ENDIF
48647 AM2(2,1)=AM2(1,2)
48648 DETM=AM2(1,1)*AM2(2,2)-AM2(2,1)**2
48649 IF(DETM.LT.0D0) THEN
48650 WRITE(MSTU(11),*) ID2(L),DETM,AM2
48651 CALL PYERRM(30,' NEGATIVE**2 MASS FOR SFERMION IN PYTHRG ')
48652 ENDIF
48653 SAME=0.5D0*(AM2(1,1)+AM2(2,2))
48654 DIFF=0.5D0*SQRT((AM2(1,1)-AM2(2,2))**2+4D0*AM2(1,2)*AM2(2,1))
48655 XMF12=SAME-DIFF
48656 XMF22=SAME+DIFF
48657 IT=0
48658 IF(XMF22-XMF12.GT.0D0) THEN
48659 RT(1,1) = SQRT(MAX(0D0,(XMF22-AM2(1,1))/(XMF22-XMF12)))
48660 RT(2,2) = RT(1,1)
48661 RT(1,2) = -SIGN(SQRT(MAX(0D0,1D0-RT(1,1)**2)),
48662 & AM2(1,2)/(XMF22-XMF12))
48663 RT(2,1) = -RT(1,2)
48664 ELSE
48665 RT(1,1) = 1D0
48666 RT(2,2) = RT(1,1)
48667 RT(1,2) = 0D0
48668 RT(2,1) = -RT(1,2)
48669 ENDIF
48670 100 CONTINUE
48671 IT=IT+1
48672
48673 DO 140 I=1,2
48674 DO 130 JJ=1,2
48675 DI(I,JJ)=0D0
48676 DO 120 II=1,2
48677 DO 110 J=1,2
48678 DI(I,JJ)=DI(I,JJ)+RT(I,J)*AM2(J,II)*RT(JJ,II)
48679 110 CONTINUE
48680 120 CONTINUE
48681 130 CONTINUE
48682 140 CONTINUE
48683
48684 IF(DI(1,1).GT.DI(2,2)) THEN
48685 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION '
48686 WRITE(MSTU(11),*) L,SQRT(XMF12),SQRT(XMF22)
48687 WRITE(MSTU(11),*) AM2
48688 WRITE(MSTU(11),*) DI
48689 WRITE(MSTU(11),*) RT
48690 DI(1,1)=-RT(2,1)
48691 DI(2,2)=RT(1,2)
48692 DI(1,2)=-RT(2,2)
48693 DI(2,1)=RT(1,1)
48694 DO 160 I=1,2
48695 DO 150 J=1,2
48696 RT(I,J)=DI(I,J)
48697 150 CONTINUE
48698 160 CONTINUE
48699 GOTO 100
48700 ELSEIF(ABS(DI(1,2)*DI(2,1)/DI(1,1)/DI(2,2)).GT.SMALL) THEN
48701 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
48702 & ' OFF DIAGONAL ELEMENTS '
48703 WRITE(MSTU(11),*) 'MASSES = ',L,SQRT(XMF12),SQRT(XMF22)
48704 WRITE(MSTU(11),*) DI
48705 WRITE(MSTU(11),*) ' ROTATION = ',RT
48706C...STOP
48707 ELSEIF(DI(1,1).LT.0D0.OR.DI(2,2).LT.0D0) THEN
48708 WRITE(MSTU(11),*) ' ERROR IN DIAGONALIZATION,'//
48709 & ' NEGATIVE MASSES '
48710 CALL PYSTOP(111)
48711 ENDIF
48712 PMAS(PYCOMP(KSUSY1+IF),1)=SQRT(XMF12)
48713 PMAS(PYCOMP(KSUSY2+IF),1)=SQRT(XMF22)
48714 SFMIX(IF,1)=RT(1,1)
48715 SFMIX(IF,2)=RT(1,2)
48716 SFMIX(IF,3)=RT(2,1)
48717 SFMIX(IF,4)=RT(2,2)
48718 170 CONTINUE
48719
48720C.....TAU SNEUTRINO MASS...L=3
48721
48722 XARG=AM2(1,1)+XMW2*COS2B
48723 IF(XARG.LT.0D0) THEN
48724 WRITE(MSTU(11),*) ' PYTHRG:: TAU SNEUTRINO MASS IS NEGATIVE'//
48725 & ' FROM THE SUM RULE. '
48726 WRITE(MSTU(11),*) ' TRY A SMALLER VALUE OF TAN(BETA). '
48727 RETURN
48728 ELSE
48729 PMAS(PYCOMP(KSUSY1+16),1)=SQRT(XARG)
48730 ENDIF
48731
48732 RETURN
48733 END
48734C*********************************************************************
48735
48736C...PYINOM
48737C...Finds the mass eigenstates and mixing matrices for neutralinos
48738C...and charginos.
48739
48740 SUBROUTINE PYINOM
48741
48742C...Double precision and integer declarations.
48743 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
48744 IMPLICIT INTEGER(I-N)
48745 INTEGER PYCOMP
48746C...Parameter statement to help give large particle numbers.
48747 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
48748 &KEXCIT=4000000,KDIMEN=5000000)
48749C...Commonblocks.
48750 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
48751 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
48752 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
48753 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
48754 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
48755 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
48756
48757C...Local variables.
48758 DOUBLE PRECISION XMW,XMZ,XM(4)
48759 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),AI(5,5)
48760 DOUBLE PRECISION WI(5),FV1(5),FV2(5),FV3(5)
48761 DOUBLE PRECISION COSW,SINW
48762 DOUBLE PRECISION XMU
48763 DOUBLE PRECISION TANB,COSB,SINB
48764 DOUBLE PRECISION XM1,XM2,XM3,BETA
48765 DOUBLE PRECISION Q2,AEM,A1,A2,AQ,RM1,RM2
48766 DOUBLE PRECISION ARG,X0,X1,AX0,AX1,AT,BT
48767 DOUBLE PRECISION Y0,Y1,AMGX0,AM1X0,AMGX1,AM1X1
48768 DOUBLE PRECISION ARGX0,AR1X0,ARGX1,AR1X1
48769 DOUBLE PRECISION PYALPS,PYALEM
48770 DOUBLE PRECISION PYRNM3
48771 COMPLEX*16 CAR(4,4),CAI(4,4),CA1,CA2
48772 INTEGER IERR,INDEX(4),I,J,K,IOPT,ILR,KFNCHI(4)
48773 DATA KFNCHI/1000022,1000023,1000025,1000035/
48774
48775 IOPT=IMSS(2)
48776 IF(IMSS(1).EQ.2) THEN
48777 IOPT=1
48778 ENDIF
48779C...M1, M2, AND M3 ARE INDEPENDENT
48780 IF(IOPT.EQ.0) THEN
48781 XM1=RMSS(1)
48782 XM2=RMSS(2)
48783 XM3=RMSS(3)
48784 ELSEIF(IOPT.GE.1) THEN
48785 Q2=PMAS(23,1)**2
48786 AEM=PYALEM(Q2)
48787 A2=AEM/PARU(102)
48788 A1=AEM/(1D0-PARU(102))
48789 XM1=RMSS(1)
48790 XM2=RMSS(2)
48791 IF(IMSS(1).EQ.2) XM1=RMSS(1)/RMSS(20)*A1*5D0/3D0
48792 IF(IOPT.EQ.1) THEN
48793 XM2=XM1*A2/A1*3D0/5D0
48794 RMSS(2)=XM2
48795 ELSEIF(IOPT.EQ.3) THEN
48796 XM1=XM2*5D0/3D0*A1/A2
48797 RMSS(1)=XM1
48798 ENDIF
48799 XM3=PYRNM3(XM2/A2)
48800 RMSS(3)=XM3
48801 IF(XM3.LE.0D0) THEN
48802 WRITE(MSTU(11),*) ' ERROR WITH M3 = ',XM3
48803 CALL PYSTOP(105)
48804 ENDIF
48805 ENDIF
48806
48807C...GLUINO MASS
48808 IF(IMSS(3).EQ.1) THEN
48809 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)
48810 ELSE
48811 AQ=0D0
48812 DO 110 I=1,4
48813 DO 100 ILR=1,2
48814 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48815 AQ=AQ+0.5D0*((2D0-RM1)*(RM1*LOG(RM1)-1D0)
48816 & +(1D0-RM1)**2*LOG(ABS(1D0-RM1)))
48817 100 CONTINUE
48818 110 CONTINUE
48819
48820 DO 130 I=5,6
48821 DO 120 ILR=1,2
48822 RM1=PMAS(PYCOMP(ILR*KSUSY1+I),1)**2/XM3**2
48823 RM2=PMAS(I,1)**2/XM3**2
48824 ARG=(RM1-RM2-1D0)**2-4D0*RM2**2
48825 IF(ARG.GE.0D0) THEN
48826 X0=0.5D0*(1D0+RM2-RM1-SQRT(ARG))
48827 AX0=ABS(X0)
48828 X1=0.5D0*(1D0+RM2-RM1+SQRT(ARG))
48829 AX1=ABS(X1)
48830 IF(X0.EQ.1D0) THEN
48831 AT=-1D0
48832 BT=0.25D0
48833 ELSEIF(X0.EQ.0D0) THEN
48834 AT=0D0
48835 BT=-0.25D0
48836 ELSE
48837 AT=0.5D0*LOG(ABS(1D0-X0))*(1D0-X0**2)+
48838 & 0.5D0*X0**2*LOG(AX0)
48839 BT=(-1D0-2D0*X0)/4D0
48840 ENDIF
48841 IF(X1.EQ.1D0) THEN
48842 AT=-1D0+AT
48843 BT=0.25D0+BT
48844 ELSEIF(X1.EQ.0D0) THEN
48845 AT=0D0+AT
48846 BT=-0.25D0+BT
48847 ELSE
48848 AT=0.5D0*LOG(ABS(1D0-X1))*(1D0-X1**2)+0.5D0*
48849 & X1**2*LOG(AX1)+AT
48850 BT=(-1D0-2D0*X1)/4D0+BT
48851 ENDIF
48852 AQ=AQ+AT+BT
48853 ELSE
48854 X0=0.5D0*(1D0+RM2-RM1)
48855 Y0=-0.5D0*SQRT(-ARG)
48856 AMGX0=SQRT(X0**2+Y0**2)
48857 AM1X0=SQRT((1D0-X0)**2+Y0**2)
48858 ARGX0=ATAN2(-X0,-Y0)
48859 AR1X0=ATAN2(1D0-X0,Y0)
48860 X1=X0
48861 Y1=-Y0
48862 AMGX1=AMGX0
48863 AM1X1=AM1X0
48864 ARGX1=ATAN2(-X1,-Y1)
48865 AR1X1=ATAN2(1D0-X1,Y1)
48866 AT=0.5D0*LOG(AM1X0)*(1D0-X0**2+3D0*Y0**2)
48867 & +0.5D0*(X0**2-Y0**2)*LOG(AMGX0)
48868 BT=(-1D0-2D0*X0)/4D0+X0*Y0*( AR1X0-ARGX0 )
48869 AT=AT+0.5D0*LOG(AM1X1)*(1D0-X1**2+3D0*Y1**2)
48870 & +0.5D0*(X1**2-Y1**2)*LOG(AMGX1)
48871 BT=BT+(-1D0-2D0*X1)/4D0+X1*Y1*( AR1X1-ARGX1 )
48872 AQ=AQ+AT+BT
48873 ENDIF
48874 120 CONTINUE
48875 130 CONTINUE
48876 PMAS(PYCOMP(KSUSY1+21),1)=ABS(XM3)*(1D0+PYALPS(XM3**2)
48877 & /(2D0*PARU(2))*(15D0+AQ))
48878 ENDIF
48879
48880C...NEUTRALINO MASSES
48881 DO 150 I=1,4
48882 DO 140 J=1,4
48883 AI(I,J)=0D0
48884 140 CONTINUE
48885 150 CONTINUE
48886 XMZ=PMAS(23,1)/100D0
48887 XMW=PMAS(24,1)/100D0
48888 XMU=RMSS(4)/100D0
48889 SINW=SQRT(PARU(102))
48890 COSW=SQRT(1D0-PARU(102))
48891 TANB=RMSS(5)
48892 BETA=ATAN(TANB)
48893 COSB=COS(BETA)
48894 SINB=TANB*COSB
48895
48896 XM2=XM2/100D0
48897 XM1=XM1/100D0
48898
48899
48900C... Definitions:
48901C... psi^0 =(-i bino^0, -i wino^0, h_d^0(=H_1^0), h_u^0(=H_2^0))
48902C... => L_neutralino = -1/2*(psi^0)^T * [AR] * psi^0 + h.c.
48903 AR(1,1) = XM1*COS(RMSS(30))
48904 AI(1,1) = XM1*SIN(RMSS(30))
48905 AR(2,2) = XM2*COS(RMSS(31))
48906 AI(2,2) = XM2*SIN(RMSS(31))
48907 AR(3,3) = 0D0
48908 AR(4,4) = 0D0
48909 AR(1,2) = 0D0
48910 AR(2,1) = 0D0
48911 AR(1,3) = -XMZ*SINW*COSB
48912 AR(3,1) = AR(1,3)
48913 AR(1,4) = XMZ*SINW*SINB
48914 AR(4,1) = AR(1,4)
48915 AR(2,3) = XMZ*COSW*COSB
48916 AR(3,2) = AR(2,3)
48917 AR(2,4) = -XMZ*COSW*SINB
48918 AR(4,2) = AR(2,4)
48919 AR(3,4) = -XMU*COS(RMSS(33))
48920 AI(3,4) = -XMU*SIN(RMSS(33))
48921 AR(4,3) = -XMU*COS(RMSS(33))
48922 AI(4,3) = -XMU*SIN(RMSS(33))
48923C CALL PYEIG4(AR,WR,ZR)
48924 CALL PYEICG(5,4,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48925 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48926 & 'PROBLEM WITH PYEICG IN PYINOM ')
48927 DO 160 I=1,4
48928 INDEX(I)=I
48929 XM(I)=ABS(WR(I))
48930 160 CONTINUE
48931 DO 180 I=2,4
48932 K=I
48933 DO 170 J=I-1,1,-1
48934 IF(XM(K).LT.XM(J)) THEN
48935 ITMP=INDEX(J)
48936 XTMP=XM(J)
48937 INDEX(J)=INDEX(K)
48938 XM(J)=XM(K)
48939 INDEX(K)=ITMP
48940 XM(K)=XTMP
48941 K=K-1
48942 ELSE
48943 GOTO 180
48944 ENDIF
48945 170 CONTINUE
48946 180 CONTINUE
48947
48948
48949 DO 210 I=1,4
48950 K=INDEX(I)
48951 SMZ(I)=WR(K)*100D0
48952 PMAS(PYCOMP(KFNCHI(I)),1)=ABS(SMZ(I))
48953 S=0D0
48954 DO 190 J=1,4
48955 S=S+ZR(J,K)**2+ZI(J,K)**2
48956 190 CONTINUE
48957 DO 200 J=1,4
48958 ZMIX(I,J)=ZR(J,K)/SQRT(S)
48959 ZMIXI(I,J)=ZI(J,K)/SQRT(S)
48960 IF(ABS(ZMIX(I,J)).LT.1D-6) ZMIX(I,J)=0D0
48961 IF(ABS(ZMIXI(I,J)).LT.1D-6) ZMIXI(I,J)=0D0
48962 200 CONTINUE
48963 210 CONTINUE
48964
48965C...CHARGINO MASSES
48966C.....Find eigenvectors of X X^*
48967 DO I=1,4
48968 DO J=1,4
48969 AR(I,J)=0D0
48970 AI(I,J)=0D0
48971 ENDDO
48972 ENDDO
48973 AI(1,1) = 0D0
48974 AI(2,2) = 0D0
48975 AR(1,1) = XM2**2+2D0*XMW**2*SINB**2
48976 AR(2,2) = XMU**2+2D0*XMW**2*COSB**2
48977 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48978 &XMU*COS(RMSS(33))*SINB)
48979 AI(1,2) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*COSB-
48980 &XMU*SIN(RMSS(33))*SINB)
48981 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*COSB+
48982 &XMU*COS(RMSS(33))*SINB)
48983 AI(2,1) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*COSB+
48984 &XMU*SIN(RMSS(33))*SINB)
48985 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
48986 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
48987 & 'PROBLEM WITH PYEICG IN PYINOM ')
48988 INDEX(1)=1
48989 INDEX(2)=2
48990 IF(WR(2).LT.WR(1)) THEN
48991 INDEX(1)=2
48992 INDEX(2)=1
48993 ENDIF
48994
48995
48996 DO 240 I=1,2
48997 K=INDEX(I)
48998 SMW(I)=SQRT(WR(K))*100D0
48999 S=0D0
49000 DO 220 J=1,2
49001 S=S+ZR(J,K)**2+ZI(J,K)**2
49002 220 CONTINUE
49003 DO 230 J=1,2
49004 UMIX(I,J)=ZR(J,K)/SQRT(S)
49005 UMIXI(I,J)=-ZI(J,K)/SQRT(S)
49006 IF(ABS(UMIX(I,J)).LT.1D-6) UMIX(I,J)=0D0
49007 IF(ABS(UMIXI(I,J)).LT.1D-6) UMIXI(I,J)=0D0
49008 230 CONTINUE
49009 240 CONTINUE
49010C...Force chargino mass > neutralino mass
49011 IFRC=0
49012 IF(ABS(SMW(1)).LT.ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1)) THEN
49013 CALL PYERRM(8,'(PYINOM:) '//
49014 & 'forcing m(~chi+_1) > m(~chi0_1) + 2m(pi0)')
49015 SMW(1)=SIGN(ABS(SMZ(1))+2D0*PMAS(PYCOMP(111),1),SMW(1))
49016 IFRC=1
49017 ENDIF
49018 PMAS(PYCOMP(KSUSY1+24),1)=SMW(1)
49019 PMAS(PYCOMP(KSUSY1+37),1)=SMW(2)
49020
49021C.....Find eigenvectors of X^* X
49022 DO I=1,4
49023 DO J=1,4
49024 AR(I,J)=0D0
49025 AI(I,J)=0D0
49026 ZR(I,J)=0D0
49027 ZI(I,J)=0D0
49028 ENDDO
49029 ENDDO
49030 AI(1,1) = 0D0
49031 AI(2,2) = 0D0
49032 AR(1,1) = XM2**2+2D0*XMW**2*COSB**2
49033 AR(2,2) = XMU**2+2D0*XMW**2*SINB**2
49034 AR(1,2) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
49035 &XMU*COS(RMSS(33))*COSB)
49036 AI(1,2) = SQRT(2D0)*XMW*(-XM2*SIN(RMSS(31))*SINB+
49037 &XMU*SIN(RMSS(33))*COSB)
49038 AR(2,1) = SQRT(2D0)*XMW*(XM2*COS(RMSS(31))*SINB+
49039 &XMU*COS(RMSS(33))*COSB)
49040 AI(2,1) = SQRT(2D0)*XMW*(XM2*SIN(RMSS(31))*SINB-
49041 &XMU*SIN(RMSS(33))*COSB)
49042 CALL PYEICG(5,2,AR,AI,WR,WI,1,ZR,ZI,FV1,FV2,FV3,IERR)
49043 IF(IERR.NE.0) CALL PYERRM(18,'(PYINOM:) '//
49044 & 'PROBLEM WITH PYEICG IN PYINOM ')
49045 INDEX(1)=1
49046 INDEX(2)=2
49047 IF(WR(2).LT.WR(1)) THEN
49048 INDEX(1)=2
49049 INDEX(2)=1
49050 ENDIF
49051
49052 SIMAG=0D0
49053 DO 270 I=1,2
49054 K=INDEX(I)
49055 S=0D0
49056 DO 250 J=1,2
49057 S=S+ZR(J,K)**2+ZI(J,K)**2
49058 SIMAG=SIMAG+ZI(J,K)**2
49059 250 CONTINUE
49060 DO 260 J=1,2
49061 VMIX(I,J)=ZR(J,K)/SQRT(S)
49062 VMIXI(I,J)=-ZI(J,K)/SQRT(S)
49063 IF(ABS(VMIX(I,J)).LT.1D-6) VMIX(I,J)=0D0
49064 IF(ABS(VMIXI(I,J)).LT.1D-6) VMIXI(I,J)=0D0
49065 260 CONTINUE
49066 270 CONTINUE
49067
49068C.....Simplify if no phases
49069 IF(SIMAG.LT.1D-6) THEN
49070 AR(1,1) = XM2*COS(RMSS(31))
49071 AR(2,2) = XMU*COS(RMSS(33))
49072 AR(1,2) = SQRT(2D0)*XMW*SINB
49073 AR(2,1) = SQRT(2D0)*XMW*COSB
49074 IKNT=0
49075 300 CONTINUE
49076 DO I=1,2
49077 DO J=1,2
49078 ZR(I,J)=0D0
49079 ENDDO
49080 ENDDO
49081
49082 DO I=1,2
49083 DO J=1,2
49084 DO K=1,2
49085 DO L=1,2
49086 ZR(I,J)=ZR(I,J)+UMIX(I,K)*AR(K,L)*VMIX(J,L)
49087 ENDDO
49088 ENDDO
49089 ENDDO
49090 ENDDO
49091 VMIX(1,1)=VMIX(1,1)*SMW(1)/ZR(1,1)/100D0
49092 VMIX(1,2)=VMIX(1,2)*SMW(1)/ZR(1,1)/100D0
49093 VMIX(2,1)=VMIX(2,1)*SMW(2)/ZR(2,2)/100D0
49094 VMIX(2,2)=VMIX(2,2)*SMW(2)/ZR(2,2)/100D0
49095 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
49096 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
49097 ELSEIF(ZR(1,1).LT.0D0.OR.ZR(2,2).LT.0D0) THEN
49098 IKNT=IKNT+1
49099 GOTO 300
49100 ENDIF
49101C.....Must deal with phases
49102 ELSE
49103 CAR(1,1) = XM2*CMPLX(COS(RMSS(31)),SIN(RMSS(31)))
49104 CAR(2,2) = XMU*CMPLX(COS(RMSS(33)),SIN(RMSS(33)))
49105 CAR(1,2) = SQRT(2D0)*XMW*SINB*CMPLX(1D0,0D0)
49106 CAR(2,1) = SQRT(2D0)*XMW*COSB*CMPLX(1D0,0D0)
49107
49108 IKNT=0
49109 310 CONTINUE
49110 DO I=1,2
49111 DO J=1,2
49112 CAI(I,J)=CMPLX(0D0,0D0)
49113 ENDDO
49114 ENDDO
49115
49116 DO I=1,2
49117 DO J=1,2
49118 DO K=1,2
49119 DO L=1,2
49120 CAI(I,J)=CAI(I,J)+CMPLX(UMIX(I,K),-UMIXI(I,K))*CAR(K,L)*
49121 & CMPLX(VMIX(J,L),VMIXI(J,L))
49122 ENDDO
49123 ENDDO
49124 ENDDO
49125 ENDDO
49126
49127 CA1=SMW(1)*CAI(1,1)/ABS(CAI(1,1))**2/100D0
49128 CA2=SMW(2)*CAI(2,2)/ABS(CAI(2,2))**2/100D0
49129 TEMPR=VMIX(1,1)
49130 TEMPI=VMIXI(1,1)
49131 VMIX(1,1)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
49132 VMIXI(1,1)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
49133 TEMPR=VMIX(1,2)
49134 TEMPI=VMIXI(1,2)
49135 VMIX(1,2)=TEMPR*DBLE(CA1)-TEMPI*DIMAG(CA1)
49136 VMIXI(1,2)=TEMPI*DBLE(CA1)+TEMPR*DIMAG(CA1)
49137 TEMPR=VMIX(2,1)
49138 TEMPI=VMIXI(2,1)
49139 VMIX(2,1)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
49140 VMIXI(2,1)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
49141 TEMPR=VMIX(2,2)
49142 TEMPI=VMIXI(2,2)
49143 VMIX(2,2)=TEMPR*DBLE(CA2)-TEMPI*DIMAG(CA2)
49144 VMIXI(2,2)=TEMPI*DBLE(CA2)+TEMPR*DIMAG(CA2)
49145 IF(IKNT.EQ.2.AND.IFRC.EQ.0) THEN
49146 CALL PYERRM(18,'(PYINOM:) Problem with Charginos')
49147 ELSEIF(DBLE(CA1).LT.0D0.OR.DBLE(CA2).LT.0D0.OR.
49148 & ABS(IMAG(CA1)).GT.1D-3.OR.ABS(IMAG(CA2)).GT.1D-3) THEN
49149 IKNT=IKNT+1
49150 GOTO 310
49151 ENDIF
49152 ENDIF
49153 RETURN
49154 END
49155
49156C*********************************************************************
49157
49158C...PYRNM3
49159C...Calculates the running of M3, the SU(3) gluino mass parameter.
49160
49161 FUNCTION PYRNM3(RGUT)
49162
49163C...Double precision and integer declarations.
49164 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49165 IMPLICIT INTEGER(I-N)
49166 INTEGER PYK,PYCHGE,PYCOMP
49167
49168C...Local variables.
49169 DOUBLE PRECISION R
49170 DOUBLE PRECISION TOL
49171 EXTERNAL PYALPS
49172 DOUBLE PRECISION PYALPS
49173 DATA TOL/0.001D0/
49174 DATA R/0.61803399D0/
49175
49176 C=1D0-R
49177
49178 BX=RGUT*PYALPS(RGUT**2)
49179 AX=MIN(50D0,BX*0.5D0)
49180 CX=MAX(2000D0,2D0*BX)
49181
49182 X0=AX
49183 X3=CX
49184 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
49185 X1=BX
49186 X2=BX+C*(CX-BX)
49187 ELSE
49188 X2=BX
49189 X1=BX-C*(BX-AX)
49190 ENDIF
49191 AS1=PYALPS(X1**2)
49192 F1=ABS(X1-RGUT*AS1)
49193 AS2=PYALPS(X2**2)
49194 F2=ABS(X2-RGUT*AS2)
49195 100 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2))) THEN
49196 IF(F2.LT.F1) THEN
49197 X0=X1
49198 X1=X2
49199 X2=R*X1+C*X3
49200 F1=F2
49201 AS2=PYALPS(X2**2)
49202 F2=ABS(X2-RGUT*AS2)
49203 ELSE
49204 X3=X2
49205 X2=X1
49206 X1=R*X2+C*X0
49207 F2=F1
49208 AS1=PYALPS(X1**2)
49209 F1=ABS(X1-RGUT*AS1)
49210 ENDIF
49211 GOTO 100
49212 ENDIF
49213 IF(F1.LT.F2) THEN
49214 PYRNM3=X1
49215 XMIN=X1
49216 ELSE
49217 PYRNM3=X2
49218 XMIN=X2
49219 ENDIF
49220
49221 RETURN
49222 END
49223
49224C*********************************************************************
49225
49226C...PYEIG4
49227C...Finds eigenvalues and eigenvectors to a 4 * 4 matrix.
49228C...Specific application: mixing in neutralino sector.
49229
49230 SUBROUTINE PYEIG4(A,W,Z)
49231
49232C...Double precision and integer declarations.
49233 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49234 IMPLICIT INTEGER(I-N)
49235 INTEGER PYK,PYCHGE,PYCOMP
49236
49237C...Arrays: in call and local.
49238 DIMENSION A(4,4),W(4),Z(4,4),X(4),D(4,4),E(4)
49239
49240C...Coefficients of fourth-degree equation from matrix.
49241C...x**4 + b3 * x**3 + b2 * x**2 + b1 * x + b0 = 0.
49242 B3=-(A(1,1)+A(2,2)+A(3,3)+A(4,4))
49243 B2=0D0
49244 DO 110 I=1,3
49245 DO 100 J=I+1,4
49246 B2=B2+A(I,I)*A(J,J)-A(I,J)*A(J,I)
49247 100 CONTINUE
49248 110 CONTINUE
49249 B1=0D0
49250 B0=0D0
49251 DO 120 I=1,4
49252 I1=MOD(I,4)+1
49253 I2=MOD(I+1,4)+1
49254 I3=MOD(I+2,4)+1
49255 B1=B1+A(I,I)*(-A(I1,I1)*A(I2,I2)+A(I1,I2)*A(I2,I1)+
49256 & A(I1,I3)*A(I3,I1)+A(I2,I3)*A(I3,I2))-
49257 & A(I,I1)*A(I1,I2)*A(I2,I)-A(I,I2)*A(I2,I1)*A(I1,I)
49258 B0=B0+(-1D0)**(I+1)*A(1,I)*(
49259 & A(2,I1)*(A(3,I2)*A(4,I3)-A(3,I3)*A(4,I2))+
49260 & A(2,I2)*(A(3,I3)*A(4,I1)-A(3,I1)*A(4,I3))+
49261 & A(2,I3)*(A(3,I1)*A(4,I2)-A(3,I2)*A(4,I1)))
49262 120 CONTINUE
49263
49264C...Coefficients of third-degree equation needed for
49265C...separation into two second-degree equations.
49266C...u**3 + c2 * u**2 + c1 * u + c0 = 0.
49267 C2=-B2
49268 C1=B1*B3-4D0*B0
49269 C0=-B1**2-B0*B3**2+4D0*B0*B2
49270 CQ=C1/3D0-C2**2/9D0
49271 CR=C1*C2/6D0-C0/2D0-C2**3/27D0
49272 CQR=CQ**3+CR**2
49273
49274C...Cases with one or three real roots.
49275 IF(CQR.GE.0D0) THEN
49276 S1=(CR+SQRT(CQR))**(1D0/3D0)
49277 S2=(CR-SQRT(CQR))**(1D0/3D0)
49278 U=S1+S2-C2/3D0
49279 ELSE
49280 SABS=SQRT(-CQ)
49281 THE=ACOS(CR/SABS**3)/3D0
49282 SRE=SABS*COS(THE)
49283 U=2D0*SRE-C2/3D0
49284 ENDIF
49285
49286C...Find and solve two second-degree equations.
49287 P1=B3/2D0-SQRT(B3**2/4D0+U-B2)
49288 P2=B3/2D0+SQRT(B3**2/4D0+U-B2)
49289 Q1=U/2D0+SQRT(U**2/4D0-B0)
49290 Q2=U/2D0-SQRT(U**2/4D0-B0)
49291 IF(ABS(P1*Q1+P2*Q2-B1).LT.ABS(P1*Q2+P2*Q1-B1)) THEN
49292 QSAV=Q1
49293 Q1=Q2
49294 Q2=QSAV
49295 ENDIF
49296 X(1)=-P1/2D0+SQRT(P1**2/4D0-Q1)
49297 X(2)=-P1/2D0-SQRT(P1**2/4D0-Q1)
49298 X(3)=-P2/2D0+SQRT(P2**2/4D0-Q2)
49299 X(4)=-P2/2D0-SQRT(P2**2/4D0-Q2)
49300
49301C...Order eigenvalues in asceding mass.
49302 W(1)=X(1)
49303 DO 150 I1=2,4
49304 DO 130 I2=I1-1,1,-1
49305 IF(ABS(X(I1)).GE.ABS(W(I2))) GOTO 140
49306 W(I2+1)=W(I2)
49307 130 CONTINUE
49308 140 W(I2+1)=X(I1)
49309 150 CONTINUE
49310
49311C...Find equation system for eigenvectors.
49312 DO 250 I=1,4
49313 DO 170 J1=1,4
49314 D(J1,J1)=A(J1,J1)-W(I)
49315 DO 160 J2=J1+1,4
49316 D(J1,J2)=A(J1,J2)
49317 D(J2,J1)=A(J2,J1)
49318 160 CONTINUE
49319 170 CONTINUE
49320
49321C...Find largest element in matrix.
49322 DAMAX=0D0
49323 DO 190 J1=1,4
49324 DO 180 J2=1,4
49325 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 180
49326 JA=J1
49327 JB=J2
49328 DAMAX=ABS(D(J1,J2))
49329 180 CONTINUE
49330 190 CONTINUE
49331
49332C...Subtract others by multiple of row selected above.
49333 DAMAX=0D0
49334 DO 210 J3=JA+1,JA+3
49335 J1=J3-4*((J3-1)/4)
49336 RL=D(J1,JB)/D(JA,JB)
49337 DO 200 J2=1,4
49338 D(J1,J2)=D(J1,J2)-RL*D(JA,J2)
49339 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 200
49340 JC=J1
49341 JD=J2
49342 DAMAX=ABS(D(J1,J2))
49343 200 CONTINUE
49344 210 CONTINUE
49345
49346C...Do one more subtraction of a row.
49347 DAMAX=0D0
49348 DO 230 J3=JC+1,JC+3
49349 J1=J3-4*((J3-1)/4)
49350 IF(J1.EQ.JA) GOTO 230
49351 RL=D(J1,JD)/D(JC,JD)
49352 DO 220 J2=1,4
49353 IF(J2.EQ.JB) GOTO 220
49354 D(J1,J2)=D(J1,J2)-RL*D(JC,J2)
49355 IF(ABS(D(J1,J2)).LE.DAMAX) GOTO 220
49356 JE=J1
49357 DAMAX=ABS(D(J1,J2))
49358 220 CONTINUE
49359 230 CONTINUE
49360
49361C...Construct unnormalized eigenvector.
49362 JF1=JD+1-4*(JD/4)
49363 JF2=JD+2-4*((JD+1)/4)
49364 IF(JF1.EQ.JB) JF1=JD+3-4*((JD+2)/4)
49365 IF(JF2.EQ.JB) JF2=JD+3-4*((JD+2)/4)
49366 E(JF1)=-D(JE,JF2)
49367 E(JF2)=D(JE,JF1)
49368 E(JD)=-(D(JC,JF1)*E(JF1)+D(JC,JF2)*E(JF2))/D(JC,JD)
49369 E(JB)=-(D(JA,JF1)*E(JF1)+D(JA,JF2)*E(JF2)+D(JA,JD)*E(JD))/
49370 & D(JA,JB)
49371
49372C...Normalize and fill in final array.
49373 EA=SQRT(E(1)**2+E(2)**2+E(3)**2+E(4)**2)
49374 SGN=(-1D0)**INT(PYR(0)+0.5D0)
49375 DO 240 J=1,4
49376 Z(I,J)=SGN*E(J)/EA
49377 240 CONTINUE
49378 250 CONTINUE
49379
49380 RETURN
49381 END
49382
49383C*********************************************************************
49384
49385C...PYHGGM
49386C...Determines the Higgs boson mass spectrum using several inputs.
49387
49388 SUBROUTINE PYHGGM(ALPHA)
49389
49390C...Double precision and integer declarations.
49391 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49392 IMPLICIT INTEGER(I-N)
49393 INTEGER PYK,PYCHGE,PYCOMP
49394C...Parameter statement to help give large particle numbers.
49395 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49396 &KEXCIT=4000000,KDIMEN=5000000)
49397C...Commonblocks.
49398 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49399 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49400 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
49401 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
49402 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/
49403
49404C...Local variables.
49405 DOUBLE PRECISION AT,AB,XMU,TANB
49406 DOUBLE PRECISION ALPHA
49407 INTEGER IHOPT
49408 DOUBLE PRECISION DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD
49409 DOUBLE PRECISION DMU,DMH,DHM,DMHCH,DSA,DCA,DTANBA
49410 DOUBLE PRECISION DMC,DMDR,DMHP,DHMP,DAMP
49411 DOUBLE PRECISION DSTOP1,DSTOP2,DSBOT1,DSBOT2
49412
49413 IHOPT=IMSS(4)
49414 IF(IHOPT.EQ.2) THEN
49415 ALPHA=RMSS(18)
49416 RETURN
49417 ENDIF
49418 AT=RMSS(16)
49419 AB=RMSS(15)
49420 DMGL=RMSS(3)
49421 XMU=RMSS(4)
49422 TANB=RMSS(5)
49423
49424 DMA=RMSS(19)
49425 DTANB=TANB
49426 DMQ=RMSS(10)
49427 DMUR=RMSS(12)
49428 DMDR=RMSS(11)
49429 DMTOP=PMAS(6,1)
49430 DMC=PMAS(PYCOMP(KSUSY1+37),1)
49431 DAU=AT
49432 DAD=AB
49433 DMU=XMU
49434 RMSS(40)=0D0
49435 RMSS(41)=0D0
49436
49437 IF(IHOPT.EQ.0) THEN
49438 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
49439 & DMHCH,DSA,DCA,DTANBA)
49440 ELSEIF(IHOPT.EQ.1) THEN
49441 CALL PYSUBH (DMA,DTANB,DMQ,DMUR,DMTOP,DAU,DAD,DMU,DMH,DHM,
49442 & DMHCH,DSA,DCA,DTANBA)
49443 CALL PYPOLE(3,DMC,DMA,DTANB,DMQ,DMUR,DMDR,DMTOP,DAU,DAD,DMU,
49444 & DMH,DMHP,DHM,DHMP,DAMP,DSA,DCA,
49445 & DSTOP1,DSTOP2,DSBOT1,DSBOT2,DTANBA,DMGL,DDT,DDB)
49446 RMSS(40)=DDT
49447 RMSS(41)=DDB
49448 DMH=DMHP
49449 DHM=DHMP
49450 DMA=DAMP
49451 IF(ABS(PMAS(PYCOMP(1000006),1)-DSTOP2).GT.5D-1) THEN
49452 WRITE(MSTU(11),*) ' STOP1 MASS DOES NOT MATCH IN PYHGGM '
49453 WRITE(MSTU(11),*) ' STOP1 MASSES = ',
49454 & PMAS(PYCOMP(1000006),1),DSTOP2
49455 ENDIF
49456 IF(ABS(PMAS(PYCOMP(2000006),1)-DSTOP1).GT.5D-1) THEN
49457 WRITE(MSTU(11),*) ' STOP2 MASS DOES NOT MATCH IN PYHGGM '
49458 WRITE(MSTU(11),*) ' STOP2 MASSES = ',
49459 & PMAS(PYCOMP(2000006),1),DSTOP1
49460 ENDIF
49461 IF(ABS(PMAS(PYCOMP(1000005),1)-DSBOT2).GT.5D-1) THEN
49462 WRITE(MSTU(11),*) ' SBOT1 MASS DOES NOT MATCH IN PYHGGM '
49463 WRITE(MSTU(11),*) ' SBOT1 MASSES = ',
49464 & PMAS(PYCOMP(1000005),1),DSBOT2
49465 ENDIF
49466 IF(ABS(PMAS(PYCOMP(2000005),1)-DSBOT1).GT.5D-1) THEN
49467 WRITE(MSTU(11),*) ' SBOT2 MASS DOES NOT MATCH IN PYHGGM '
49468 WRITE(MSTU(11),*) ' SBOT2 MASSES = ',
49469 & PMAS(PYCOMP(2000005),1),DSBOT1
49470 ENDIF
49471
49472 ELSEIF (IHOPT.EQ.3) THEN
49473c...Use FeynHiggs to fix Higgs sector (cf feynhiggs.de)
49474C...Currently only available for SLHA spectrum read-in.
49475 IF (IMSS(1).NE.11.AND.IMSS(1).NE.12.AND.IMSS(1).NE.13) THEN
49476 CALL PYERRM(11,'(PYHGGM:) FeynHiggs needs SLHA or ISASUSY'
49477 & //' spectrum, change IMSS(1) or IMSS(4) option.')
49478 ENDIF
49479 ALPHA=RMSS(18)
49480 RETURN
49481 ENDIF
49482
49483 ALPHA=ACOS(DCA)
49484
49485 PMAS(25,1)=DMH
49486 PMAS(35,1)=DHM
49487 PMAS(36,1)=DMA
49488 PMAS(37,1)=DMHCH
49489
49490 RETURN
49491 END
49492
49493C*********************************************************************
49494
49495C...PYSUBH
49496C...This routine computes the renormalization group improved
49497C...values of Higgs masses and couplings in the MSSM.
49498
49499C...Program based on the work by M. Carena, J.R. Espinosa,
49500c...M. Quiros and C.E.M. Wagner, CERN-preprint CERN-TH/95-45
49501
49502C...Input: MA,TANB = TAN(BETA),MQ,MUR,MTOP,AU,AD,MU
49503C...All masses in GeV units. MA is the CP-odd Higgs mass,
49504C...MTOP is the physical top mass, MQ and MUR are the soft
49505C...supersymmetry breaking mass parameters of left handed
49506C...and right handed stops respectively, AU and AD are the
49507C...stop and sbottom trilinear soft breaking terms,
49508C...respectively, and MU is the supersymmetric
49509C...Higgs mass parameter. We use the conventions from
49510C...the physics report of Haber and Kane: left right
49511C...stop mixing term proportional to (AU - MU/TANB)
49512C...We use as input TANB defined at the scale MTOP
49513
49514C...Output: MH,HM,MHCH, SA = SIN(ALPHA), CA= COS(ALPHA), TANBA
49515C...where MH and HM are the lightest and heaviest CP-even
49516C...Higgs masses, MHCH is the charged Higgs mass and
49517C...ALPHA is the Higgs mixing angle
49518C...TANBA is the angle TANB at the CP-odd Higgs mass scale
49519
49520C...Range of validity:
49521C...(STOP1**2 - STOP2**2)/(STOP2**2 + STOP1**2) < 0.5
49522C...(SBOT1**2 - SBOT2**2)/(SBOT2**2 + SBOT2**2) < 0.5
49523C...where STOP1, STOP2, SBOT1 and SBOT2 are the stop and
49524C...are the sbottom mass eigenvalues, respectively. This
49525C...range automatically excludes the existence of tachyons.
49526C...For the charged Higgs mass computation, the method is
49527C...valid if
49528C...2 * |MB * AD* TANB| < M_SUSY**2, 2 * |MTOP * AU| < M_SUSY**2
49529C...2 * |MB * MU * TANB| < M_SUSY**2, 2 * |MTOP * MU| < M_SUSY**2
49530C...where M_SUSY**2 is the average of the squared stop mass
49531C...eigenvalues, M_SUSY**2 = (STOP1**2 + STOP2**2)/2. The sbottom
49532C...masses have been assumed to be of order of the stop ones
49533C...M_SUSY**2 = (MQ**2 + MUR**2)*0.5 + MTOP**2
49534
49535 SUBROUTINE PYSUBH (XMA,TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM,
49536 &XMHCH,SA,CA,TANBA)
49537
49538C...Double precision and integer declarations.
49539 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49540 IMPLICIT INTEGER(I-N)
49541 INTEGER PYK,PYCHGE,PYCOMP
49542C...Parameter statement to help give large particle numbers.
49543 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
49544 &KEXCIT=4000000,KDIMEN=5000000)
49545C...Commonblocks.
49546 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49547 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
49548 COMMON/PYHTRI/HHH(7)
49549 SAVE /PYDAT1/,/PYDAT2/
49550
49551C...Local variables.
49552 DOUBLE PRECISION PYALEM,PYALPS
49553 DOUBLE PRECISION TANB,XMQ,XMUR,XMTOP,AU,AD,XMU,XMH,XHM
49554 DOUBLE PRECISION XMHCH,SA,CA
49555 DOUBLE PRECISION XMA,AEM,ALP1,ALP2,ALPH3Z,V,PI
49556 DOUBLE PRECISION Q02
49557 DOUBLE PRECISION TANBA,TANBT,XMB,ALP3
49558 DOUBLE PRECISION RMTOP,XMS,T,SINB,COSB
49559 DOUBLE PRECISION XLAM1,XLAM2,XLAM3,XLAM4,XLAM5,XLAM6
49560 DOUBLE PRECISION XLAM7,XAU,XAD,G1,G2,G3,HU,HD,HU2
49561 DOUBLE PRECISION HD2,HU4,HD4,SINBT,COSBT
49562 DOUBLE PRECISION TRM2,DETM2,XMH2,XHM2,XMHCH2
49563 DOUBLE PRECISION SINALP,COSALP,AUD,PI2,XMS2,XMS4,AD2
49564 DOUBLE PRECISION AU2,XMU2,XMZ,XMS3
49565
49566 XMZ = PMAS(23,1)
49567 Q02=XMZ**2
49568 AEM=PYALEM(Q02)
49569 ALP1=AEM/(1D0-PARU(102))
49570 ALP2=AEM/PARU(102)
49571 ALPH3Z=PYALPS(Q02)
49572
49573 ALP1 = 0.0101D0
49574 ALP2 = 0.0337D0
49575 ALPH3Z = 0.12D0
49576
49577 V = 174.1D0
49578 PI = PARU(1)
49579 TANBA = TANB
49580 TANBT = TANB
49581
49582C...MBOTTOM(MTOP) = 3. GEV
49583 XMB = PYMRUN(5,XMTOP**2)
49584 ALP3 = ALPH3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPH3Z*
49585 &LOG(XMTOP**2/XMZ**2))
49586
49587C...RMTOP= RUNNING TOP QUARK MASS
49588 RMTOP = XMTOP/(1D0+4D0*ALP3/3D0/PI)
49589 XMS = ((XMQ**2 + XMUR**2)/2D0 + XMTOP**2)**0.5D0
49590 T = LOG(XMS**2/XMTOP**2)
49591 SINB = TANB/((1D0 + TANB**2)**0.5D0)
49592 COSB = SINB/TANB
49593C...IF(MA.LE.XMTOP) TANBA = TANBT
49594 IF(XMA.GT.XMTOP)
49595 &TANBA = TANBT*(1D0-3D0/32D0/PI**2*
49596 &(RMTOP**2/V**2/SINB**2-XMB**2/V**2/COSB**2)*
49597 &LOG(XMA**2/XMTOP**2))
49598
49599 SINBT = TANBT/SQRT(1D0 + TANBT**2)
49600 COSBT = 1D0/SQRT(1D0 + TANBT**2)
49601C COS2BT = (TANBT**2 - 1D0)/(TANBT**2 + 1D0)
49602 G1 = SQRT(ALP1*4D0*PI)
49603 G2 = SQRT(ALP2*4D0*PI)
49604 G3 = SQRT(ALP3*4D0*PI)
49605 HU = RMTOP/V/SINBT
49606 HD = XMB/V/COSBT
49607 HU2=HU*HU
49608 HD2=HD*HD
49609 HU4=HU2*HU2
49610 HD4=HD2*HD2
49611 AU2=AU**2
49612 AD2=AD**2
49613 XMS2=XMS**2
49614 XMS3=XMS**3
49615 XMS4=XMS2*XMS2
49616 XMU2=XMU*XMU
49617 PI2=PI*PI
49618
49619 XAU = (2D0*AU2/XMS2)*(1D0 - AU2/12D0/XMS2)
49620 XAD = (2D0*AD2/XMS2)*(1D0 - AD2/12D0/XMS2)
49621 AUD = (-6D0*XMU2/XMS2 - ( XMU2- AD*AU)**2/XMS4
49622 &+ 3D0*(AU + AD)**2/XMS2)/6D0
49623 XLAM1 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HD2*T/8D0/PI2)
49624 &+(3D0*HD4/8D0/PI2) * (T + XAD/2D0 + (3D0*HD2/2D0 + HU2/2D0
49625 &- 8D0*G3**2) * (XAD*T + T**2)/16D0/PI2)
49626 &-(3D0*HU4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HU2 -5D0* HD2
49627 &- 16D0*G3**2) *T/16D0/PI2)
49628 XLAM2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU2*T/8D0/PI2)
49629 &+(3D0*HU4/8D0/PI2) * (T + XAU/2D0 + (3D0*HU2/2D0 + HD2/2D0
49630 &- 8D0*G3**2) * (XAU*T + T**2)/16D0/PI2)
49631 &-(3D0*HD4* XMU**4/96D0/PI2/XMS4) * (1+ (9D0*HD2 -5D0* HU2
49632 &- 16D0*G3**2) *T/16D0/PI2)
49633 XLAM3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
49634 &(HU2 + HD2)*T/16D0/PI2)
49635 &+(6D0*HU2*HD2/16D0/PI2) * (T + AUD/2D0 + (HU2 + HD2
49636 &- 8D0*G3**2) * (AUD*T + T**2)/16D0/PI2)
49637 &+(3D0*HU4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AU2/
49638 &XMS4)* (1D0+ (6D0*HU2 -2D0* HD2/2D0
49639 &- 16D0*G3**2) *T/16D0/PI2)
49640 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
49641 &XMS4)*(1D0+ (6D0*HD2 -2D0* HU2
49642 &- 16D0*G3**2) *T/16D0/PI2)
49643 XLAM4 = (- G2**2/2D0)*(1D0-3D0*(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)*
49648 &(1+ (6D0*HU2 -2D0* HD2
49649 &- 16D0*G3**2) *T/16D0/PI2)
49650 &+(3D0*HD4/96D0/PI2) * (3D0*XMU2/XMS2 - XMU2*AD2/
49651 &XMS4)*
49652 &(1+ (6D0*HD2 -2D0* HU2/2D0
49653 &- 16D0*G3**2) *T/16D0/PI2)
49654 XLAM5 = -(3D0*HU4* XMU2*AU2/96D0/PI2/XMS4) *
49655 &(1- (2D0*HD2 -6D0* HU2 + 16D0*G3**2) *T/16D0/PI2)
49656 &-(3D0*HD4* XMU2*AD2/96D0/PI2/XMS4) *
49657 &(1- (2D0*HU2 -6D0* HD2 + 16D0*G3**2) *T/16D0/PI2)
49658 XLAM6 = (3D0*HU4* XMU**3*AU/96D0/PI2/XMS4) *
49659 &(1- (7D0*HD2/2D0 -15D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49660 &+(3D0*HD4* XMU *(AD**3/XMS3 - 6D0*AD/XMS )/96D0/PI2/XMS) *
49661 &(1- (HU2/2D0 -9D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49662 XLAM7 = (3D0*HD4* XMU**3*AD/96D0/PI2/XMS4) *
49663 &(1- (7D0*HU2/2D0 -15D0* HD2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49664 &+(3D0*HU4* XMU *(AU**3/XMS3 - 6D0*AU/XMS )/96D0/PI2/XMS) *
49665 &(1- (HD2/2D0 -9D0* HU2/2D0 + 16D0*G3**2) *T/16D0/PI2)
49666 HHH(1)=XLAM1
49667 HHH(2)=XLAM2
49668 HHH(3)=XLAM3
49669 HHH(4)=XLAM4
49670 HHH(5)=XLAM5
49671 HHH(6)=XLAM6
49672 HHH(7)=XLAM7
49673 TRM2 = XMA**2 + 2D0*V**2* (XLAM1* COSBT**2 +
49674 &2D0* XLAM6*SINBT*COSBT
49675 &+ XLAM5*SINBT**2 + XLAM2* SINBT**2 + 2D0* XLAM7*SINBT*COSBT
49676 &+ XLAM5*COSBT**2)
49677 DETM2 = 4D0*V**4*(-(SINBT*COSBT*(XLAM3 + XLAM4) +
49678 &XLAM6*COSBT**2
49679 &+ XLAM7* SINBT**2)**2 + (XLAM1* COSBT**2 +
49680 &2D0* XLAM6* COSBT*SINBT
49681 &+ XLAM5*SINBT**2)*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
49682 &+ XLAM5*COSBT**2)) + XMA**2*2D0*V**2 *
49683 &((XLAM1* COSBT**2 +2D0*
49684 &XLAM6* COSBT*SINBT + XLAM5*SINBT**2)*COSBT**2 +
49685 &(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT + XLAM5*COSBT**2)
49686 &*SINBT**2
49687 &+2D0*SINBT*COSBT* (SINBT*COSBT*(XLAM3
49688 &+ XLAM4) + XLAM6*COSBT**2
49689 &+ XLAM7* SINBT**2))
49690
49691 XMH2 = (TRM2 - SQRT(TRM2**2 - 4D0* DETM2))/2D0
49692 XHM2 = (TRM2 + SQRT(TRM2**2 - 4D0* DETM2))/2D0
49693 XHM = SQRT(XHM2)
49694 XMH = SQRT(XMH2)
49695 XMHCH2 = XMA**2 + (XLAM5 - XLAM4)* V**2
49696 XMHCH = SQRT(XMHCH2)
49697
49698 SINALP = SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0) -
49699 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
49700 &XLAM6* COSBT*SINBT
49701 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
49702 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
49703 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2)))/
49704 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0))/2D0**0.5D0
49705
49706 COSALP = (2D0*(2D0*V**2*(SINBT*COSBT*(XLAM3 + XLAM4) +
49707 &XLAM6*COSBT**2 + XLAM7* SINBT**2) -
49708 &XMA**2*SINBT*COSBT))/2D0**0.5D0/
49709 &SQRT(((TRM2**2 - 4D0* DETM2)**0.5D0)*
49710 &(((TRM2**2 - 4D0* DETM2)**0.5D0) -
49711 &((2D0*V**2*(XLAM1* COSBT**2 + 2D0*
49712 &XLAM6* COSBT*SINBT
49713 &+ XLAM5*SINBT**2) + XMA**2*SINBT**2)
49714 &- (2D0*V**2*(XLAM2* SINBT**2 +2D0* XLAM7* COSBT*SINBT
49715 &+ XLAM5*COSBT**2) + XMA**2*COSBT**2))))
49716
49717 SA = -SINALP
49718 CA = -COSALP
49719
49720 100 CONTINUE
49721
49722 RETURN
49723 END
49724
49725C*********************************************************************
49726
49727C...PYPOLE
49728C...This subroutine computes the CP-even higgs and CP-odd pole
49729c...Higgs masses and mixing angles.
49730
49731C...Program based on the work by M. Carena, M. Quiros
49732C...and C.E.M. Wagner, "Effective potential methods and
49733C...the Higgs mass spectrum in the MSSM", CERN-TH/95-157
49734
49735C...Inputs: IHIGGS(explained below),MCHI,MA,TANB,MQ,MUR,MDR,MTOP,
49736C...AT,AB,MU
49737C...where MCHI is the largest chargino mass, MA is the running
49738C...CP-odd higgs mass, TANB is the value of the ratio of vacuum
49739C...expectaion values at the scale MTOP, MQ is the third generation
49740C...left handed squark mass parameter, MUR is the third generation
49741C...right handed stop mass parameter, MDR is the third generation
49742C...right handed sbottom mass parameter, MTOP is the pole top quark
49743C...mass; AT,AB are the soft supersymmetry breaking trilinear
49744C...couplings of the stop and sbottoms, respectively, and MU is the
49745C...supersymmetric mass parameter
49746
49747C...The parameter IHIGGS=0,1,2,3 corresponds to the number of
49748C...Higgses whose pole mass is computed. If IHIGGS=0 only running
49749C...masses are given, what makes the running of the program
49750c...much faster and it is quite generally a good approximation
49751c...(for a theoretical discussion see ref. above). If IHIGGS=1,
49752C...only the pole mass for H is computed. If IHIGGS=2, then h and H,
49753c...and if IHIGGS=3, then h,H,A polarizations are computed
49754
49755C...Output: MH and MHP which are the lightest CP-even Higgs running
49756C...and pole masses, respectively; HM and HMP are the heaviest CP-even
49757C...Higgs running and pole masses, repectively; SA and CA are the
49758C...SIN(ALPHA) and COS(ALPHA) where ALPHA is the Higgs mixing angle
49759C...AMP is the CP-odd Higgs pole mass. STOP1,STOP2,SBOT1 and SBOT2
49760C...are the stop and sbottom mass eigenvalues. Finally, TANBA is
49761C...the value of TANB at the CP-odd Higgs mass scale
49762
49763C...This subroutine makes use of CERN library subroutine
49764C...integration package, which makes the computation of the
49765C...pole Higgs masses somewhat faster. We thank P. Janot for this
49766C...improvement. Those who are not able to call the CERN
49767C...libraries, please use the subroutine SUBHPOLE2.F, which
49768C...although somewhat slower, gives identical results
49769
49770 SUBROUTINE PYPOLE(IHIGGS,XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,XMU,
49771 &XMH,XMHP,HM,HMP,AMP,SA,CA,STOP1,STOP2,SBOT1,SBOT2,TANBA,XMG,DT,DB)
49772
49773C...Double precision and integer declarations.
49774 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
49775 IMPLICIT INTEGER(I-N)
49776
49777C...Parameters.
49778 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
49779 SAVE /PYDAT1/
49780 INTEGER PYK,PYCHGE,PYCOMP
49781
49782C...Local variables.
49783 DIMENSION DELTA(2,2),COUPT(2,2),T(2,2),SSTOP2(2),
49784 &SSBOT2(2),B(2,2),COUPB(2,2),
49785 &HCOUPT(2,2),HCOUPB(2,2),
49786 &ACOUPT(2,2),ACOUPB(2,2),PR(3), POLAR(3)
49787
49788 DELTA(1,1) = 1D0
49789 DELTA(2,2) = 1D0
49790 DELTA(1,2) = 0D0
49791 DELTA(2,1) = 0D0
49792 V = 174.1D0
49793 XMZ=91.18D0
49794 PI=PARU(1)
49795 RXMT=PYMRUN(6,XMT**2)
49796 CALL PYRGHM(XMC,XMA,TANB,XMQ,XMUR,XMDR,XMT,AT,AB,
49797 &XMU,XMH,HM,XMCH,SA,CA,SAB,CAB,TANBA,XMG,DT,DB)
49798
49799 SINB = TANB/(TANB**2+1D0)**0.5D0
49800 COSB = 1D0/(TANB**2+1D0)**0.5D0
49801 COS2B = SINB**2 - COSB**2
49802 SINBPA = SINB*CA + COSB*SA
49803 COSBPA = COSB*CA - SINB*SA
49804 RMBOT = PYMRUN(5,XMT**2)
49805 XMQ2 = XMQ**2
49806 XMUR2 = XMUR**2
49807 IF(XMUR.LT.0D0) XMUR2=-XMUR2
49808 XMDR2 = XMDR**2
49809 XMST11 = RXMT**2 + XMQ2 - 0.35D0*XMZ**2*COS2B
49810 XMST22 = RXMT**2 + XMUR2 - 0.15D0*XMZ**2*COS2B
49811 IF(XMST11.LT.0D0) GOTO 500
49812 IF(XMST22.LT.0D0) GOTO 500
49813 XMSB11 = RMBOT**2 + XMQ2 + 0.42D0*XMZ**2*COS2B
49814 XMSB22 = RMBOT**2 + XMDR2 + 0.08D0*XMZ**2*COS2B
49815 IF(XMSB11.LT.0D0) GOTO 500
49816 IF(XMSB22.LT.0D0) GOTO 500
49817C WMST11 = RXMT**2 + XMQ2
49818C WMST22 = RXMT**2 + XMUR2
49819 XMST12 = RXMT*(AT - XMU/TANB)
49820 XMSB12 = RMBOT*(AB - XMU*TANB)
49821
49822CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49823C...STOP EIGENVALUES CALCULATION
49824CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49825
49826 STOP12 = 0.5D0*(XMST11+XMST22) +
49827 &0.5D0*((XMST11+XMST22)**2 -
49828 &4D0*(XMST11*XMST22 - XMST12**2))**0.5D0
49829 STOP22 = 0.5D0*(XMST11+XMST22) -
49830 &0.5D0*((XMST11+XMST22)**2 - 4D0*(XMST11*XMST22 -
49831 &XMST12**2))**0.5D0
49832
49833 IF(STOP22.LT.0D0) GOTO 500
49834 SSTOP2(1) = STOP12
49835 SSTOP2(2) = STOP22
49836 STOP1 = STOP12**0.5D0
49837 STOP2 = STOP22**0.5D0
49838C STOP1W = STOP1
49839C STOP2W = STOP2
49840
49841 IF(XMST12.EQ.0D0) XST11 = 1D0
49842 IF(XMST12.EQ.0D0) XST12 = 0D0
49843 IF(XMST12.EQ.0D0) XST21 = 0D0
49844 IF(XMST12.EQ.0D0) XST22 = 1D0
49845
49846 IF(XMST12.EQ.0D0) GOTO 110
49847
49848 100 XST11 = XMST12/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49849 XST12 = - (XMST11-STOP12)/(XMST12**2+(XMST11-STOP12)**2)**0.5D0
49850 XST21 = XMST12/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49851 XST22 = - (XMST11-STOP22)/(XMST12**2+(XMST11-STOP22)**2)**0.5D0
49852
49853 110 T(1,1) = XST11
49854 T(2,2) = XST22
49855 T(1,2) = XST12
49856 T(2,1) = XST21
49857
49858 SBOT12 = 0.5D0*(XMSB11+XMSB22) +
49859 &0.5D0*((XMSB11+XMSB22)**2 -
49860 &4D0*(XMSB11*XMSB22 - XMSB12**2))**0.5D0
49861 SBOT22 = 0.5D0*(XMSB11+XMSB22) -
49862 &0.5D0*((XMSB11+XMSB22)**2 - 4D0*(XMSB11*XMSB22 -
49863 &XMSB12**2))**0.5D0
49864 IF(SBOT22.LT.0D0) GOTO 500
49865 SBOT1 = SBOT12**0.5D0
49866 SBOT2 = SBOT22**0.5D0
49867
49868 SSBOT2(1) = SBOT12
49869 SSBOT2(2) = SBOT22
49870
49871 IF(XMSB12.EQ.0D0) XSB11 = 1D0
49872 IF(XMSB12.EQ.0D0) XSB12 = 0D0
49873 IF(XMSB12.EQ.0D0) XSB21 = 0D0
49874 IF(XMSB12.EQ.0D0) XSB22 = 1D0
49875
49876 IF(XMSB12.EQ.0D0) GOTO 130
49877
49878 120 XSB11 = XMSB12/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49879 XSB12 = - (XMSB11-SBOT12)/(XMSB12**2+(XMSB11-SBOT12)**2)**0.5D0
49880 XSB21 = XMSB12/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49881 XSB22 = - (XMSB11-SBOT22)/(XMSB12**2+(XMSB11-SBOT22)**2)**0.5D0
49882
49883 130 B(1,1) = XSB11
49884 B(2,2) = XSB22
49885 B(1,2) = XSB12
49886 B(2,1) = XSB21
49887
49888
49889 SINT = 0.2320D0
49890 SQR = DSQRT(2D0)
49891 VP = 174.1D0*SQR
49892
49893CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49894C...STARTING OF LIGHT HIGGS
49895CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49896
49897 IF(IHIGGS.EQ.0) GOTO 490
49898
49899 DO 150 I = 1,2
49900 DO 140 J = 1,2
49901 COUPT(I,J) =
49902 & SINT*XMZ**2*2D0*SQR/174.1D0/3D0*SINBPA*(DELTA(I,J) +
49903 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49904 & -RXMT**2/174.1D0**2*VP/SINB*CA*DELTA(I,J)
49905 & -RXMT/VP/SINB*(AT*CA + XMU*SA)*(T(1,I)*T(2,J) +
49906 & T(1,J)*T(2,I))
49907 140 CONTINUE
49908 150 CONTINUE
49909
49910
49911 DO 170 I = 1,2
49912 DO 160 J = 1,2
49913 COUPB(I,J) =
49914 & -SINT*XMZ**2*2D0*SQR/174.1D0/6D0*SINBPA*(DELTA(I,J) +
49915 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49916 & +RMBOT**2/174.1D0**2*VP/COSB*SA*DELTA(I,J)
49917 & +RMBOT/VP/COSB*(AB*SA + XMU*CA)*(B(1,I)*B(2,J) +
49918 & B(1,J)*B(2,I))
49919 160 CONTINUE
49920 170 CONTINUE
49921
49922 PRUN = XMH
49923 EPS = 1D-4*PRUN
49924 ITER = 0
49925 180 ITER = ITER + 1
49926 DO 230 I3 = 1,3
49927
49928 PR(I3)=PRUN+(I3-2)*EPS/2
49929 P2=PR(I3)**2
49930 POLT = 0D0
49931 DO 200 I = 1,2
49932 DO 190 J = 1,2
49933 POLT = POLT + COUPT(I,J)**2*3D0*
49934 & PYFINT(P2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
49935 190 CONTINUE
49936 200 CONTINUE
49937
49938 POLB = 0D0
49939 DO 220 I = 1,2
49940 DO 210 J = 1,2
49941 POLB = POLB + COUPB(I,J)**2*3D0*
49942 & PYFINT(P2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
49943 210 CONTINUE
49944 220 CONTINUE
49945C RXMT2 = RXMT**2
49946 XMT2=XMT**2
49947
49948 POLTT =
49949 & 3D0*RXMT**2/8D0/PI**2/ V **2*
49950 & CA**2/SINB**2 *
49951 & (-2D0*XMT**2+0.5D0*P2)*
49952 & PYFINT(P2,XMT2,XMT2)
49953
49954 POL = POLT + POLB + POLTT
49955 POLAR(I3) = P2 - XMH**2 - POL
49956 230 CONTINUE
49957 DERIV = (POLAR(3)-POLAR(1))/EPS
49958 DRUN = - POLAR(2)/DERIV
49959 PRUN = PRUN + DRUN
49960 P2 = PRUN**2
49961 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 240
49962 GOTO 180
49963 240 CONTINUE
49964
49965 XMHP = DSQRT(P2)
49966
49967CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49968C...END OF LIGHT HIGGS
49969CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49970
49971 250 IF(IHIGGS.EQ.1) GOTO 490
49972
49973CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49974C... STARTING OF HEAVY HIGGS
49975CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
49976
49977 DO 270 I = 1,2
49978 DO 260 J = 1,2
49979 HCOUPT(I,J) =
49980 & -SINT*XMZ**2*2D0*SQR/174.1D0/3D0*COSBPA*(DELTA(I,J) +
49981 & (3D0 - 8D0*SINT)/4D0/SINT*T(1,I)*T(1,J))
49982 & -RXMT**2/174.1D0**2*VP/SINB*SA*DELTA(I,J)
49983 & -RXMT/VP/SINB*(AT*SA - XMU*CA)*(T(1,I)*T(2,J) +
49984 & T(1,J)*T(2,I))
49985 260 CONTINUE
49986 270 CONTINUE
49987
49988 DO 290 I = 1,2
49989 DO 280 J = 1,2
49990 HCOUPB(I,J) =
49991 & SINT*XMZ**2*2D0*SQR/174.1D0/6D0*COSBPA*(DELTA(I,J) +
49992 & (3D0 - 4D0*SINT)/2D0/SINT*B(1,I)*B(1,J))
49993 & -RMBOT**2/174.1D0**2*VP/COSB*CA*DELTA(I,J)
49994 & -RMBOT/VP/COSB*(AB*CA - XMU*SA)*(B(1,I)*B(2,J) +
49995 & B(1,J)*B(2,I))
49996 HCOUPB(I,J)=0D0
49997 280 CONTINUE
49998 290 CONTINUE
49999
50000 PRUN = HM
50001 EPS = 1D-4*PRUN
50002 ITER = 0
50003 300 ITER = ITER + 1
50004 DO 350 I3 = 1,3
50005 PR(I3)=PRUN+(I3-2)*EPS/2
50006 HP2=PR(I3)**2
50007
50008 HPOLT = 0D0
50009 DO 320 I = 1,2
50010 DO 310 J = 1,2
50011 HPOLT = HPOLT + HCOUPT(I,J)**2*3D0*
50012 & PYFINT(HP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
50013 310 CONTINUE
50014 320 CONTINUE
50015
50016 HPOLB = 0D0
50017 DO 340 I = 1,2
50018 DO 330 J = 1,2
50019 HPOLB = HPOLB + HCOUPB(I,J)**2*3D0*
50020 & PYFINT(HP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
50021 330 CONTINUE
50022 340 CONTINUE
50023
50024C RXMT2 = RXMT**2
50025 XMT2 = XMT**2
50026
50027 HPOLTT =
50028 & 3D0*RXMT**2/8D0/PI**2/ V **2*
50029 & SA**2/SINB**2 *
50030 & (-2D0*XMT**2+0.5D0*HP2)*
50031 & PYFINT(HP2,XMT2,XMT2)
50032
50033 HPOL = HPOLT + HPOLB + HPOLTT
50034 POLAR(I3) =HP2-HM**2-HPOL
50035 350 CONTINUE
50036 DERIV = (POLAR(3)-POLAR(1))/EPS
50037 DRUN = - POLAR(2)/DERIV
50038 PRUN = PRUN + DRUN
50039 HP2 = PRUN**2
50040 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 360
50041 GOTO 300
50042 360 CONTINUE
50043
50044
50045 370 CONTINUE
50046 HMP = HP2**0.5D0
50047
50048CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50049C... END OF HEAVY HIGGS
50050CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50051
50052 IF(IHIGGS.EQ.2) GOTO 490
50053
50054CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50055C...BEGINNING OF PSEUDOSCALAR HIGGS
50056CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50057
50058 DO 390 I = 1,2
50059 DO 380 J = 1,2
50060 ACOUPT(I,J) =
50061 & -RXMT/VP/SINB*(AT*COSB + XMU*SINB)*
50062 & (T(1,I)*T(2,J) -T(1,J)*T(2,I))
50063 380 CONTINUE
50064 390 CONTINUE
50065 DO 410 I = 1,2
50066 DO 400 J = 1,2
50067 ACOUPB(I,J) =
50068 & RMBOT/VP/COSB*(AB*SINB + XMU*COSB)*
50069 & (B(1,I)*B(2,J) -B(1,J)*B(2,I))
50070 400 CONTINUE
50071 410 CONTINUE
50072
50073 PRUN = XMA
50074 EPS = 1D-4*PRUN
50075 ITER = 0
50076 420 ITER = ITER + 1
50077 DO 470 I3 = 1,3
50078 PR(I3)=PRUN+(I3-2)*EPS/2
50079 AP2=PR(I3)**2
50080 APOLT = 0D0
50081 DO 440 I = 1,2
50082 DO 430 J = 1,2
50083 APOLT = APOLT + ACOUPT(I,J)**2*3D0*
50084 & PYFINT(AP2,SSTOP2(I),SSTOP2(J))/16D0/PI**2
50085 430 CONTINUE
50086 440 CONTINUE
50087 APOLB = 0D0
50088 DO 460 I = 1,2
50089 DO 450 J = 1,2
50090 APOLB = APOLB + ACOUPB(I,J)**2*3D0*
50091 & PYFINT(AP2,SSBOT2(I),SSBOT2(J))/16D0/PI**2
50092 450 CONTINUE
50093 460 CONTINUE
50094C RXMT2 = RXMT**2
50095 XMT2=XMT**2
50096 APOLTT =
50097 & 3D0*RXMT**2/8D0/PI**2/ V **2*
50098 & COSB**2/SINB**2 *
50099 & (-0.5D0*AP2)*
50100 & PYFINT(AP2,XMT2,XMT2)
50101 APOL = APOLT + APOLB + APOLTT
50102 POLAR(I3) = AP2 - XMA**2 -APOL
50103 470 CONTINUE
50104 DERIV = (POLAR(3)-POLAR(1))/EPS
50105 DRUN = - POLAR(2)/DERIV
50106 PRUN = PRUN + DRUN
50107 AP2 = PRUN**2
50108 IF( ABS(DRUN) .LT. 1D-4 .OR.ITER.GT.500) GOTO 480
50109 GOTO 420
50110 480 CONTINUE
50111
50112 AMP = DSQRT(AP2)
50113
50114CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50115C...END OF PSEUDOSCALAR HIGGS
50116CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50117
50118 IF(IHIGGS.EQ.3) GOTO 490
50119
50120 490 CONTINUE
50121 RETURN
50122 500 CONTINUE
50123 WRITE(MSTU(11),*) ' EXITING IN PYPOLE '
50124 WRITE(MSTU(11),*) ' XMST11,XMST22 = ',XMST11,XMST22
50125 WRITE(MSTU(11),*) ' XMSB11,XMSB22 = ',XMSB11,XMSB22
50126 WRITE(MSTU(11),*) ' STOP22,SBOT22 = ',STOP22,SBOT22
50127 CALL PYSTOP(107)
50128 END
50129
50130C*********************************************************************
50131
50132C...PYRGHM
50133C...Auxiliary to PYPOLE.
50134
50135 SUBROUTINE PYRGHM(MCHI,MA,TANB,MQ,MUR,MD,MTOP,AU,AD,MU,
50136 * MHP,HMP,MCH,SA,CA,SAB,CAB,TANBA,MGLU,DELTAMT,DELTAMB)
50137 IMPLICIT DOUBLE PRECISION(A-H,L,M,O-Z)
50138 DIMENSION VH(2,2),M2(2,2),M2P(2,2)
50139C...Parameters.
50140 INTEGER MSTU,MSTJ
50141 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50142 SAVE /PYDAT1/
50143
50144 MZ = 91.18D0
50145 PI = PARU(1)
50146 V = 174.1D0
50147 ALPHA1 = 0.0101D0
50148 ALPHA2 = 0.0337D0
50149 ALPHA3Z = 0.12D0
50150 TANBA = TANB
50151 TANBT = TANB
50152C MBOTTOM(MTOP) = 3. GEV
50153 MB = PYMRUN(5,MTOP**2)
50154 ALPHA3 = ALPHA3Z/(1D0 +(11D0 - 10D0/3D0)/4D0/PI*ALPHA3Z*
50155 *LOG(MTOP**2/MZ**2))
50156C RMTOP= RUNNING TOP QUARK MASS
50157 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
50158 TQ = LOG((MQ**2+MTOP**2)/MTOP**2)
50159 TU = LOG((MUR**2 + MTOP**2)/MTOP**2)
50160 TD = LOG((MD**2 + MTOP**2)/MTOP**2)
50161CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50162C
50163C NEW DEFINITION, TGLU.
50164C
50165CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50166 TGLU = LOG(MGLU**2/MTOP**2)
50167 SINB = TANB/DSQRT(1D0 + TANB**2)
50168 COSB = SINB/TANB
50169 IF(MA.GT.MTOP)
50170 *TANBA = TANB*(1D0-3D0/32D0/PI**2*
50171 *(RMTOP**2/V**2/SINB**2-MB**2/V**2/COSB**2)*
50172 *LOG(MA**2/MTOP**2))
50173 IF(MA.LT.MTOP.OR.MA.EQ.MTOP) TANBT = TANBA
50174 SINB = TANBT/SQRT(1D0 + TANBT**2)
50175 COSB = 1D0/DSQRT(1D0 + TANBT**2)
50176 G1 = SQRT(ALPHA1*4D0*PI)
50177 G2 = SQRT(ALPHA2*4D0*PI)
50178 G3 = SQRT(ALPHA3*4D0*PI)
50179 HU = RMTOP/V/SINB
50180 HD = MB/V/COSB
50181 CALL PYGFXX(MA,TANBA,MQ,MUR,MD,MTOP,AU,AD,MU,MGLU,VH,STOP1,STOP2,
50182 *SBOT1,SBOT2,DELTAMT,DELTAMB)
50183 IF(MQ.GT.MUR) TP = TQ - TU
50184 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TP = TU - TQ
50185 IF(MQ.GT.MUR) TDP = TU
50186 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) TDP = TQ
50187 IF(MQ.GT.MD) TPD = TQ - TD
50188 IF(MQ.LT.MD.OR.MQ.EQ.MD) TPD = TD - TQ
50189 IF(MQ.GT.MD) TDPD = TD
50190 IF(MQ.LT.MD.OR.MQ.EQ.MD) TDPD = TQ
50191
50192 IF(MQ.GT.MD) DLAMBDA1 = 6D0/96D0/PI**2*G1**2*HD**2*TPD
50193 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA1 = 3D0/32D0/PI**2*
50194 * HD**2*(G1**2/3D0+G2**2)*TPD
50195
50196 IF(MQ.GT.MUR) DLAMBDA2 =12D0/96D0/PI**2*G1**2*HU**2*TP
50197 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA2 = 3D0/32D0/PI**2*
50198 * HU**2*(-G1**2/3D0+G2**2)*TP
50199
50200CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50201C
50202C DLAMBDAP1 AND DLAMBDAP2 ARE THE NEW LOG CORRECTIONS DUE TO
50203C THE PRESENCE OF THE GLUINO MASS. THEY ARE IN GENERAL VERY SMALL,
50204C AND ONLY PRESENT IF THERE IS A HIERARCHY OF MASSES BETWEEN THE
50205C TWO STOPS.
50206C
50207C
50208CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50209
50210 DLAMBDAP2 = 0D0
50211 IF(MGLU.LT.MUR.OR.MGLU.LT.MQ) THEN
50212 IF(MQ.GT.MUR.AND.MGLU.GT.MUR) THEN
50213 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TGLU**2)
50214 ENDIF
50215
50216 IF(MQ.GT.MUR.AND.MGLU.LT.MUR) THEN
50217 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
50218 ENDIF
50219
50220 IF(MQ.GT.MUR.AND.MGLU.EQ.MUR) THEN
50221 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TQ**2-TU**2)
50222 ENDIF
50223
50224 IF(MUR.GT.MQ.AND.MGLU.GT.MQ) THEN
50225 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TGLU**2)
50226 ENDIF
50227
50228 IF(MUR.GT.MQ.AND.MGLU.LT.MQ) THEN
50229 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
50230 ENDIF
50231
50232 IF(MUR.GT.MQ.AND.MGLU.EQ.MQ) THEN
50233 DLAMBDAP2 = -4D0/(16D0*PI**2)**2*HU**4*(TU**2-TQ**2)
50234 ENDIF
50235 ENDIF
50236 DLAMBDA3 = 0D0
50237 DLAMBDA4 = 0D0
50238 IF(MQ.GT.MD) DLAMBDA3 = -1D0/32D0/PI**2*G1**2*HD**2*TPD
50239 IF(MQ.LT.MD.OR.MQ.EQ.MD) DLAMBDA3 = 3D0/64D0/PI**2*HD**2*
50240 *(G2**2-G1**2/3D0)*TPD
50241 IF(MQ.GT.MUR) DLAMBDA3 = DLAMBDA3 -
50242 *1D0/16D0/PI**2*G1**2*HU**2*TP
50243 IF(MQ.LT.MUR.OR.MQ.EQ.MUR) DLAMBDA3 = DLAMBDA3 +
50244 * 3D0/64D0/PI**2*HU**2*(G2**2+G1**2/3D0)*TP
50245 IF(MQ.LT.MUR) DLAMBDA4 = -3D0/32D0/PI**2*G2**2*HU**2*TP
50246 IF(MQ.LT.MD) DLAMBDA4 = DLAMBDA4 - 3D0/32D0/PI**2*G2**2*
50247 *HD**2*TPD
50248 LAMBDA1 = ((G1**2 + G2**2)/4D0)*
50249 * (1D0-3D0*HD**2*(TPD + TDPD)/8D0/PI**2)
50250 *+(3D0*HD**4D0/16D0/PI**2) *TPD*(1D0
50251 *+ (3D0*HD**2/2D0 + HU**2/2D0
50252 *- 8D0*G3**2) * (TPD + 2D0*TDPD)/16D0/PI**2)
50253 *+(3D0*HD**4D0/8D0/PI**2) *TDPD*(1D0 + (3D0*HD**2/2D0 + HU**2/2D0
50254 *- 8D0*G3**2) * TDPD/16D0/PI**2) + DLAMBDA1
50255 LAMBDA2 = ((G1**2 + G2**2)/4D0)*(1D0-3D0*HU**2*
50256 *(TP + TDP)/8D0/PI**2)
50257 *+(3D0*HU**4D0/16D0/PI**2) *TP*(1D0
50258 *+ (3D0*HU**2/2D0 + HD**2/2D0
50259 *- 8D0*G3**2) * (TP + 2D0*TDP)/16D0/PI**2)
50260 *+(3D0*HU**4D0/8D0/PI**2) *TDP*(1D0 + (3D0*HU**2/2D0 + HD**2/2D0
50261 *- 8D0*G3**2) * TDP/16D0/PI**2) + DLAMBDA2 + DLAMBDAP2
50262 LAMBDA3 = ((G2**2 - G1**2)/4D0)*(1D0-3D0*
50263 *(HU**2)*(TP + TDP)/16D0/PI**2 -3D0*
50264 *(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA3
50265 LAMBDA4 = (- G2**2/2D0)*(1D0
50266 *-3D0*(HU**2)*(TP + TDP)/16D0/PI**2
50267 *-3D0*(HD**2)*(TPD + TDPD)/16D0/PI**2) +DLAMBDA4
50268
50269 LAMBDA5 = 0D0
50270 LAMBDA6 = 0D0
50271 LAMBDA7 = 0D0
50272
50273 M2(1,1) = 2D0*V**2*(LAMBDA1*COSB**2+2D0*LAMBDA6*
50274 *COSB*SINB + LAMBDA5*SINB**2) + MA**2*SINB**2
50275
50276 M2(2,2) = 2D0*V**2*(LAMBDA5*COSB**2+2D0*LAMBDA7*
50277 *COSB*SINB + LAMBDA2*SINB**2) + MA**2*COSB**2
50278 M2(1,2) = 2D0*V**2*(LAMBDA6*COSB**2+(LAMBDA3+LAMBDA4)*
50279 *COSB*SINB + LAMBDA7*SINB**2) - MA**2*SINB*COSB
50280
50281 M2(2,1) = M2(1,2)
50282CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50283CCC THIS IS THE CONTRIBUTION FROM LIGHT CHARGINOS/NEUTRALINOS
50284CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50285
50286 MSSUSY=DSQRT(.5D0*(MQ**2+MUR**2)+MTOP**2)
50287
50288 IF(MCHI.GT.MSSUSY) GOTO 100
50289 IF(MCHI.LT.MTOP) MCHI=MTOP
50290
50291 TCHAR=LOG(MSSUSY**2/MCHI**2)
50292
50293 DELTAL12=(9D0/64D0/PI**2*G2**4+5D0/192D0/PI**2*G1**4)*TCHAR
50294 DELTAL3P4=(3D0/64D0/PI**2*G2**4+7D0/192D0/PI**2*G1**4
50295 *+4D0/32D0/PI**2*G1**2*G2**2)*TCHAR
50296
50297 DELTAM112=2D0*DELTAL12*V**2*COSB**2
50298 DELTAM222=2D0*DELTAL12*V**2*SINB**2
50299 DELTAM122=2D0*DELTAL3P4*V**2*SINB*COSB
50300
50301 M2(1,1)=M2(1,1)+DELTAM112
50302 M2(2,2)=M2(2,2)+DELTAM222
50303 M2(1,2)=M2(1,2)+DELTAM122
50304 M2(2,1)=M2(2,1)+DELTAM122
50305
50306 100 CONTINUE
50307
50308CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50309CCC END OF CHARGINOS/NEUTRALINOS
50310CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50311
50312 DO 120 I = 1,2
50313 DO 110 J = 1,2
50314 M2P(I,J) = M2(I,J) + VH(I,J)
50315 110 CONTINUE
50316 120 CONTINUE
50317 TRM2P = M2P(1,1) + M2P(2,2)
50318 DETM2P = M2P(1,1)*M2P(2,2) - M2P(1,2)*M2P(2,1)
50319 MH2P = (TRM2P - DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
50320 HM2P = (TRM2P + DSQRT(TRM2P**2 - 4D0* DETM2P))/2D0
50321 HMP = DSQRT(HM2P)
50322 MCH2=MA**2+(LAMBDA5-LAMBDA4)*V**2
50323 MCH=DSQRT(MCH2)
50324 IF(MH2P.LT.0.) GOTO 130
50325 MHP = SQRT(MH2P)
50326 SIN2ALPHA = 2D0*M2P(1,2)/SQRT(TRM2P**2-4D0*DETM2P)
50327 COS2ALPHA = (M2P(1,1)-M2P(2,2))/SQRT(TRM2P**2-4D0*DETM2P)
50328 IF(COS2ALPHA.GE.0.) THEN
50329 ALPHA = ASIN(SIN2ALPHA)/2D0
50330 ELSE
50331 ALPHA = -PI/2D0-ASIN(SIN2ALPHA)/2D0
50332 ENDIF
50333 SA = SIN(ALPHA)
50334 CA = COS(ALPHA)
50335CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50336C
50337C HERE THE VALUES OF SAB AND CAB ARE DEFINED, IN ORDER
50338C TO DEFINE THE NEW COUPLINGS OF THE LIGHTEST AND
50339C HEAVY CP-EVEN HIGGS TO THE BOTTOM QUARK.
50340C
50341C
50342CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50343 SAB = SA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0+CA/SA/TANB))
50344 CAB = CA*(1D0-DELTAMB/(1D0+DELTAMB)*(1D0-SA/CA/TANB))
50345 130 CONTINUE
50346 RETURN
50347 END
50348
50349C*********************************************************************
50350
50351C...PYGFXX
50352C...Auxiliary to PYRGHM.
50353
50354 SUBROUTINE PYGFXX(MA,TANB,MQ,MUR,MD,MTOP,AT,AB,XMU,XMGL,VH,
50355 * STOP1,STOP2,SBOT1,SBOT2,DELTAMT,DELTAMB)
50356 IMPLICIT DOUBLE PRECISION(A-H,M,O-Z)
50357 DIMENSION VH(2,2),VH3T(2,2),VH3B(2,2),AL(2,2)
50358C...Commonblocks.
50359 INTEGER MSTU,MSTJ,KCHG
50360 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50361 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50362 SAVE /PYDAT1/,/PYDAT2/
50363
50364 G(X,Y) = 2.D0 - (X+Y)/(X-Y)*DLOG(X/Y)
50365
50366 T(X,Y,Z) = (X**2*Y**2*LOG(X**2/Y**2) + X**2*Z**2*LOG(Z**2/X**2)
50367 * + Y**2*Z**2*LOG(Y**2/Z**2))/((X**2-Y**2)*(Y**2-Z**2)*(X**2-Z**2))
50368
50369 IF(DABS(XMU).LT.0.000001D0) XMU = 0.000001D0
50370 MQ2 = MQ**2
50371 MUR2 = MUR**2
50372 MD2 = MD**2
50373 TANBA = TANB
50374 SINBA = TANBA/DSQRT(TANBA**2+1D0)
50375 COSBA = SINBA/TANBA
50376
50377 SINB = TANB/DSQRT(TANB**2+1D0)
50378 COSB = SINB/TANB
50379
50380 PI = PARU(1)
50381 MZ = PMAS(23,1)
50382 MW = PMAS(24,1)
50383 SW = 1D0-MW**2/MZ**2
50384 V = 174.1D0
50385
50386 ALPHA3 = 0.12D0/(1D0+23/12D0/PI*0.12D0*LOG(MTOP**2/MZ**2))
50387 G2 = DSQRT(0.0336D0*4D0*PI)
50388 G1 = DSQRT(0.0101D0*4D0*PI)
50389
50390 IF(MQ.GT.MUR) MST = MQ
50391 IF(MUR.GT.MQ.OR.MUR.EQ.MQ) MST = MUR
50392
50393 MSUSYT = DSQRT(MST**2 + MTOP**2)
50394
50395 IF(MQ.GT.MD) MSB = MQ
50396 IF(MD.GT.MQ.OR.MD.EQ.MQ) MSB = MD
50397
50398 MB = PYMRUN(5,MSB**2)
50399 MSUSYB = DSQRT(MSB**2 + MB**2)
50400 TT = LOG(MSUSYT**2/MTOP**2)
50401 TB = LOG(MSUSYB**2/MTOP**2)
50402
50403 RMTOP = MTOP/(1D0+4D0*ALPHA3/3D0/PI)
50404 HT = RMTOP/(V*SINB)
50405 HTST = RMTOP/V
50406 HB = MB/V/COSB
50407 G32 = ALPHA3*4D0*PI
50408 BT2 = -(8D0*G32 - 9D0*HT**2/2D0 - HB**2/2D0)/(4D0*PI)**2
50409 BB2 = -(8D0*G32 - 9D0*HB**2/2D0 - HT**2/2D0)/(4D0*PI)**2
50410 AL2 = 3D0/8D0/PI**2*HT**2
50411C BT2ST = -(8.*G32 - 9.*HTST**2/2.)/(4.*PI)**2
50412C ALST = 3./8./PI**2*HTST**2
50413 AL1 = 3D0/8D0/PI**2*HB**2
50414
50415 AL(1,1) = AL1
50416 AL(1,2) = (AL2+AL1)/2D0
50417 AL(2,1) = (AL2+AL1)/2D0
50418 AL(2,2) = AL2
50419
50420 IF(MA.GT.MTOP) THEN
50421 VI = V*(1D0 + 3D0/32D0/PI**2*HTST**2*
50422 * LOG(MTOP**2/MA**2))
50423 H1I = VI* COSBA
50424 H2I = VI*SINBA
50425 H1T = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYT**2))**.25D0
50426 H2T = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYT**2))**.25D0
50427 H1B = H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MA**2/MSUSYB**2))**.25D0
50428 H2B = H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MA**2/MSUSYB**2))**.25D0
50429 ELSE
50430 VI = V
50431 H1I = VI*COSB
50432 H2I = VI*SINB
50433 H1T=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYT**2))**.25D0
50434 H2T=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYT**2))**.25D0
50435 H1B=H1I*(1D0+3D0/8D0/PI**2*HB**2*LOG(MTOP**2/MSUSYB**2))**.25D0
50436 H2B=H2I*(1D0+3D0/8D0/PI**2*HT**2*LOG(MTOP**2/MSUSYB**2))**.25D0
50437 ENDIF
50438
50439 TANBST = H2T/H1T
50440 SINBT = TANBST/DSQRT(1D0+TANBST**2)
50441
50442 TANBSB = H2B/H1B
50443 SINBB = TANBSB/DSQRT(1D0+TANBSB**2)
50444 COSBB = SINBB/TANBSB
50445
50446 DELTAMT = 0D0
50447 DELTAMB = 0D0
50448
50449 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
50450 MTOP2 = DSQRT(MTOP4)
50451 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
50452 * /(1D0+DELTAMB)**4
50453 MBOT2 = DSQRT(MBOT4)
50454
50455 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
50456 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50457 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50458 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
50459 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
50460 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50461 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50462 * MQ2 - MUR2)**2*0.25D0
50463 * + MTOP2*(AT-XMU/TANBST)**2)
50464 IF(STOP22.LT.0.) GOTO 120
50465 SBOT12 = (MQ2 + MD2)*.5D0
50466 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50467 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50468 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50469 SBOT22 = (MQ2 + MD2)*.5D0
50470 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50471 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50472 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50473 IF(SBOT22.LT.0.) SBOT22 = 10000D0
50474
50475 STOP1 = DSQRT(STOP12)
50476 STOP2 = DSQRT(STOP22)
50477 SBOT1 = DSQRT(SBOT12)
50478 SBOT2 = DSQRT(SBOT22)
50479
50480CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50481C
50482C HERE IS THE DEFINITION OF DELTAMB AND DELTAMT, WHICH
50483C ARE THE VERTEX CORRECTIONS TO THE BOTTOM AND TOP QUARK
50484C MASS, KEEPING THE DOMINANT QCD AND TOP YUKAWA COUPLING
50485C INDUCED CORRECTIONS.
50486C
50487CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50488
50489 X=SBOT1
50490 Y=SBOT2
50491 Z=XMGL
50492 IF(X.EQ.Y) X = X - 0.00001D0
50493 IF(X.EQ.Z) X = X - 0.00002D0
50494 IF(Y.EQ.Z) Y = Y - 0.00003D0
50495
50496 T1=T(X,Y,Z)
50497 X=STOP1
50498 Y=STOP2
50499 Z=XMU
50500 IF(X.EQ.Y) X = X - 0.00001D0
50501 IF(X.EQ.Z) X = X - 0.00002D0
50502 IF(Y.EQ.Z) Y = Y - 0.00003D0
50503 T2=T(X,Y,Z)
50504 DELTAMB = -2*ALPHA3/3D0/PI*XMGL*(AB-XMU*TANB)*T1
50505 * + HT**2/(4D0*PI)**2*(AT-XMU/TANB)*XMU*TANB*T2
50506 X=STOP1
50507 Y=STOP2
50508 Z=XMGL
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 T3=T(X,Y,Z)
50513 DELTAMT = -2D0*ALPHA3/3D0/PI*(AT-XMU/TANB)*XMGL*T3
50514
50515CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50516C
50517C HERE THE NEW VALUES OF THE TOP AND BOTTOM QUARK MASSES AT
50518C THE SCALE MS ARE DEFINED, TO BE USED IN THE EFFECTIVE
50519C POTENTIAL APPROXIMATION. THEY ARE JUST THE OLD ONES, BUT
50520C INCLUDING THE FINITE CORRECTIONS DELTAMT AND DELTAMB.
50521C THE DELTAMB CORRECTIONS CAN BECOME LARGE AND ARE RESUMMED
50522C TO ALL ORDERS, AS SUGGESTED IN THE TWO RECENT WORKS BY M. CARENA,
50523C S. MRENNA AND C.E.M. WAGNER, AS WELL AS IN THE WORK BY M. CARENA,
50524C D. GARCIA, U. NIERSTE AND C.E.M. WAGNER, TO APPEAR. THE TOP
50525C QUARK MASS CORRECTIONS ARE SMALL AND ARE KEPT IN THE PERTURBATIVE
50526C FORMULATION. THE FUNCTION T(X,Y,Z) IS NECESSARY FOR THE
50527C CALCULATION. THE ENTRIES ARE MASSES AND NOT THEIR SQUARES !
50528C
50529C
50530CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50531
50532 MTOP4 = RMTOP**4*(1D0+2D0*BT2*TT- AL2*TT - 4D0*DELTAMT)
50533 MTOP2 = DSQRT(MTOP4)
50534 MBOT4 = MB**4*(1D0+2D0*BB2*TB - AL1*TB)
50535 * /(1D0+DELTAMB)**4
50536 MBOT2 = DSQRT(MBOT4)
50537
50538 STOP12 = (MQ2 + MUR2)*.5D0 + MTOP2
50539 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50540 * +SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50541 * MQ2 - MUR2)**2*0.25D0 + MTOP2*(AT-XMU/TANBST)**2)
50542 STOP22 = (MQ2 + MUR2)*.5D0 + MTOP2
50543 * +1D0/8D0*(G2**2+G1**2)*(H1T**2-H2T**2)
50544 * - SQRT(((G2**2-5D0*G1**2/3D0)/4D0*(H1T**2-H2T**2) +
50545 * MQ2 - MUR2)**2*0.25D0
50546 * + MTOP2*(AT-XMU/TANBST)**2)
50547
50548 IF(STOP22.LT.0.) GOTO 120
50549 SBOT12 = (MQ2 + MD2)*.5D0
50550 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50551 * + SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50552 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50553 SBOT22 = (MQ2 + MD2)*.5D0
50554 * - 1D0/8D0*(G2**2+G1**2)*(H1B**2-H2B**2)
50555 * - SQRT(((G1**2/3D0-G2**2)/4D0*(H1B**2-H2B**2) +
50556 * MQ2 - MD2)**2*0.25D0 + MBOT2*(AB-XMU*TANBSB)**2)
50557 IF(SBOT22.LT.0.) GOTO 120
50558
50559
50560 STOP1 = DSQRT(STOP12)
50561 STOP2 = DSQRT(STOP22)
50562 SBOT1 = DSQRT(SBOT12)
50563 SBOT2 = DSQRT(SBOT22)
50564
50565CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50566CCC D-TERMS
50567CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
50568 STW=SW
50569
50570 F1T=(MQ2-MUR2)/(STOP12-STOP22)*(.5D0-4D0/3D0*STW)*
50571 * LOG(STOP1/STOP2)
50572 * +(.5D0-2D0/3D0*STW)*LOG(STOP1*STOP2/(MQ2+MTOP2))
50573 * + 2D0/3D0*STW*LOG(STOP1*STOP2/(MUR2+MTOP2))
50574
50575 F1B=(MQ2-MD2)/(SBOT12-SBOT22)*(-.5D0+2D0/3D0*STW)*
50576 * LOG(SBOT1/SBOT2)
50577 * +(-.5D0+1D0/3D0*STW)*LOG(SBOT1*SBOT2/(MQ2+MBOT2))
50578 * - 1D0/3D0*STW*LOG(SBOT1*SBOT2/(MD2+MBOT2))
50579
50580 F2T=DSQRT(MTOP2)*(AT-XMU/TANBST)/(STOP12-STOP22)*
50581 * (-.5D0*LOG(STOP12/STOP22)
50582 * +(4D0/3D0*STW-.5D0)*(MQ2-MUR2)/(STOP12-STOP22)*
50583 * G(STOP12,STOP22))
50584
50585 F2B=DSQRT(MBOT2)*(AB-XMU*TANBSB)/(SBOT12-SBOT22)*
50586 * (.5D0*LOG(SBOT12/SBOT22)
50587 * +(-2D0/3D0*STW+.5D0)*(MQ2-MD2)/(SBOT12-SBOT22)*
50588 * G(SBOT12,SBOT22))
50589
50590 VH3B(1,1) = MBOT4/(COSBB**2)*(LOG(SBOT1**2*SBOT2**2/
50591 * (MQ2+MBOT2)/(MD2+MBOT2))
50592 * + 2D0*(AB*(AB-XMU*TANBSB)/(SBOT1**2-SBOT2**2))*
50593 * LOG(SBOT1**2/SBOT2**2)) +
50594 * MBOT4/(COSBB**2)*(AB*(AB-XMU*TANBSB)/
50595 * (SBOT1**2-SBOT2**2))**2*G(SBOT12,SBOT22)
50596
50597 VH3T(1,1) =
50598 * MTOP4/(SINBT**2)*(XMU*(-AT+XMU/TANBST)/(STOP1**2
50599 * -STOP2**2))**2*G(STOP12,STOP22)
50600
50601 VH3B(1,1)=VH3B(1,1)+
50602 * MZ**2*(2*MBOT2*F1B-DSQRT(MBOT2)*AB*F2B)
50603
50604 VH3T(1,1) = VH3T(1,1) +
50605 * MZ**2*(DSQRT(MTOP2)*XMU/TANBST*F2T)
50606
50607 VH3T(2,2) = MTOP4/(SINBT**2)*(LOG(STOP1**2*STOP2**2/
50608 * (MQ2+MTOP2)/(MUR2+MTOP2))
50609 * + 2D0*(AT*(AT-XMU/TANBST)/(STOP1**2-STOP2**2))*
50610 * LOG(STOP1**2/STOP2**2)) +
50611 * MTOP4/(SINBT**2)*(AT*(AT-XMU/TANBST)/
50612 * (STOP1**2-STOP2**2))**2*G(STOP12,STOP22)
50613
50614 VH3B(2,2) =
50615 * MBOT4/(COSBB**2)*(XMU*(-AB+XMU*TANBSB)/(SBOT1**2
50616 * -SBOT2**2))**2*G(SBOT12,SBOT22)
50617
50618 VH3T(2,2)=VH3T(2,2)+
50619 * MZ**2*(-2*MTOP2*F1T+DSQRT(MTOP2)*AT*F2T)
50620 VH3B(2,2) = VH3B(2,2) -MZ**2*DSQRT(MBOT2)*XMU*TANBSB*F2B
50621 VH3T(1,2) = -
50622 * MTOP4/(SINBT**2)*XMU*(AT-XMU/TANBST)/
50623 * (STOP1**2-STOP2**2)*(LOG(STOP1**2/STOP2**2) + AT*
50624 * (AT - XMU/TANBST)/(STOP1**2-STOP2**2)*G(STOP12,STOP22))
50625
50626 VH3B(1,2) =
50627 * - MBOT4/(COSBB**2)*XMU*(AB-XMU*TANBSB)/
50628 * (SBOT1**2-SBOT2**2)*(LOG(SBOT1**2/SBOT2**2) + AB*
50629 * (AB - XMU*TANBSB)/(SBOT1**2-SBOT2**2)*G(SBOT12,SBOT22))
50630
50631
50632 VH3T(1,2)=VH3T(1,2) +
50633 *MZ**2*(MTOP2/TANBST*F1T-DSQRT(MTOP2)*(AT/TANBST+XMU)/2D0*F2T)
50634
50635 VH3B(1,2)=VH3B(1,2) +
50636 *MZ**2*(-MBOT2*TANBSB*F1B+DSQRT(MBOT2)*(AB*TANBSB+XMU)/2D0*F2B)
50637
50638 VH3T(2,1) = VH3T(1,2)
50639 VH3B(2,1) = VH3B(1,2)
50640
50641C TQ = LOG((MQ2 + MTOP2)/MTOP2)
50642C TU = LOG((MUR2+MTOP2)/MTOP2)
50643C TQD = LOG((MQ2 + MB**2)/MB**2)
50644C TD = LOG((MD2+MB**2)/MB**2)
50645
50646 DO 110 I = 1,2
50647 DO 100 J = 1,2
50648 VH(I,J) =
50649 * 6D0/(8D0*PI**2*(H1T**2+H2T**2))
50650 * *VH3T(I,J)*0.5D0*(1D0-AL(I,J)*TT/2D0) +
50651 * 6D0/(8D0*PI**2*(H1B**2+H2B**2))
50652 * *VH3B(I,J)*0.5D0*(1D0-AL(I,J)*TB/2D0)
50653 100 CONTINUE
50654 110 CONTINUE
50655
50656 GOTO 150
50657 120 DO 140 I =1,2
50658 DO 130 J = 1,2
50659 VH(I,J) = -1D15
50660 130 CONTINUE
50661 140 CONTINUE
50662
50663
50664 150 RETURN
50665 END
50666
50667
50668
50669
50670
50671C*********************************************************************
50672
50673C...PYFINT
50674C...Auxiliary routine to PYPOLE for SUSY Higgs calculations.
50675
50676 FUNCTION PYFINT(A,B,C)
50677
50678C...Double precision and integer declarations.
50679 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50680 IMPLICIT INTEGER(I-N)
50681 INTEGER PYK,PYCHGE,PYCOMP
50682C...Commonblock.
50683 COMMON/PYINTS/XXM(20)
50684 SAVE/PYINTS/
50685
50686C...Local variables.
50687 EXTERNAL PYFISB
50688 DOUBLE PRECISION PYFISB
50689
50690 XXM(1)=A
50691 XXM(2)=B
50692 XXM(3)=C
50693 XLO=0D0
50694 XHI=1D0
50695 PYFINT = PYGAUS(PYFISB,XLO,XHI,1D-3)
50696
50697 RETURN
50698 END
50699
50700C*********************************************************************
50701
50702C...PYFISB
50703C...Auxiliary routine to PYFINT for SUSY Higgs calculations.
50704
50705 FUNCTION PYFISB(X)
50706
50707C...Double precision and integer declarations.
50708 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50709 IMPLICIT INTEGER(I-N)
50710 INTEGER PYK,PYCHGE,PYCOMP
50711C...Commonblock.
50712 COMMON/PYINTS/XXM(20)
50713 SAVE/PYINTS/
50714
50715 PYFISB = LOG(ABS(X*XXM(2)+(1-X)*XXM(3)-X*(1-X)*XXM(1))/
50716 &(X*(XXM(2)-XXM(3))+XXM(3)))
50717
50718 RETURN
50719 END
50720
50721C*********************************************************************
50722
50723C...PYSFDC
50724C...Calculates decays of sfermions.
50725
50726 SUBROUTINE PYSFDC(KFIN,XLAM,IDLAM,IKNT)
50727
50728C...Double precision and integer declarations.
50729 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
50730 IMPLICIT INTEGER(I-N)
50731 INTEGER PYK,PYCHGE,PYCOMP
50732C...Parameter statement to help give large particle numbers.
50733 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
50734 &KEXCIT=4000000,KDIMEN=5000000)
50735C...Commonblocks.
50736 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
50737 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
50738 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
50739 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
50740 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
50741 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
50742
50743C...Local variables.
50744 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2)
50745 COMPLEX*16 CAL,CAR,CBL,CBR,CALP,CARP,CBLP,CBRP,CA,CB
50746 INTEGER KFIN,KCIN
50747 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,XMZ,AXMJ
50748 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
50749 DOUBLE PRECISION PYLAMF,XL
50750 DOUBLE PRECISION TANW,XW,AEM,C1,AS
50751 DOUBLE PRECISION AL,AR,BL,BR
50752 DOUBLE PRECISION CH1,CH2,CH3,CH4
50753 DOUBLE PRECISION XMBOT,XMTOP
50754 DOUBLE PRECISION XLAM(0:400)
50755 INTEGER IDLAM(400,3)
50756 INTEGER LKNT,IX,ILR,IDU,J,I,IKNT,IFL,II
50757 DOUBLE PRECISION SR2
50758 DOUBLE PRECISION CBETA,SBETA
50759 DOUBLE PRECISION CW
50760 DOUBLE PRECISION BETA,ALFA,XMU,AT,AB,ATRIT,ATRIB,ATRIL
50761 DOUBLE PRECISION COSA,SINA,TANB
50762 DOUBLE PRECISION PYALEM,PI,PYALPS,EI
50763 DOUBLE PRECISION GHRR,GHLL,GHLR,XMB,BLR
50764 INTEGER IG,KF1,KF2
50765 INTEGER IGG(4),KFNCHI(4),KFCCHI(2)
50766 DATA IGG/23,25,35,36/
50767 DATA PI/3.141592654D0/
50768 DATA SR2/1.4142136D0/
50769 DATA KFNCHI/1000022,1000023,1000025,1000035/
50770 DATA KFCCHI/1000024,1000037/
50771
50772C...COUNT THE NUMBER OF DECAY MODES
50773 LKNT=0
50774
50775C...NO NU_R DECAYS
50776 IF(KFIN.EQ.KSUSY2+12.OR.KFIN.EQ.KSUSY2+14.OR.
50777 &KFIN.EQ.KSUSY2+16) RETURN
50778
50779 XMW=PMAS(24,1)
50780 XMW2=XMW**2
50781 XMZ=PMAS(23,1)
50782 XW=PARU(102)
50783 TANW = SQRT(XW/(1D0-XW))
50784 CW=SQRT(1D0-XW)
50785
50786 DO 110 I=1,4
50787 DO 100 J=1,4
50788 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
50789 100 CONTINUE
50790 110 CONTINUE
50791 DO 130 I=1,2
50792 DO 120 J=1,2
50793 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
50794 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
50795 120 CONTINUE
50796 130 CONTINUE
50797
50798C...KCIN
50799 KCIN=PYCOMP(KFIN)
50800C...ILR is 1 for left and 2 for right.
50801 ILR=KFIN/KSUSY1
50802C...IFL is matching non-SUSY flavour.
50803 IFL=MOD(KFIN,KSUSY1)
50804C...IDU is weak isospin, 1 for down and 2 for up.
50805 IDU=2-MOD(IFL,2)
50806
50807 XMI=PMAS(KCIN,1)
50808 XMI2=XMI**2
50809 AEM=PYALEM(XMI2)
50810 AS =PYALPS(XMI2)
50811 C1=AEM/XW
50812 XMI3=XMI**3
50813 EI=KCHG(IFL,1)/3D0
50814
50815 XMBOT=PYMRUN(5,XMI2)
50816 XMTOP=PYMRUN(6,XMI2)
50817
50818 TANB=RMSS(5)
50819 BETA=ATAN(TANB)
50820 ALFA=RMSS(18)
50821 CBETA=COS(BETA)
50822 SBETA=TANB*CBETA
50823 SINA=SIN(ALFA)
50824 COSA=COS(ALFA)
50825 XMU=-RMSS(4)
50826 ATRIT=RMSS(16)
50827 ATRIB=RMSS(15)
50828 ATRIL=RMSS(17)
50829
50830C...2-BODY DECAYS OF SFERMION -> GRAVITINO + FERMION
50831
50832 IF(IMSS(11).EQ.1) THEN
50833 XMP=RMSS(29)
50834 IDG=39+KSUSY1
50835 XMGR=PMAS(PYCOMP(IDG),1)
50836 XFAC=(XMI2/(XMP*XMGR))**2*XMI/48D0/PI
50837 IF(IFL.EQ.5) THEN
50838 XMF=XMBOT
50839 ELSEIF(IFL.EQ.6) THEN
50840 XMF=XMTOP
50841 ELSE
50842 XMF=PMAS(IFL,1)
50843 ENDIF
50844 IF(XMI.GT.XMGR+XMF) THEN
50845 LKNT=LKNT+1
50846 IDLAM(LKNT,1)=IDG
50847 IDLAM(LKNT,2)=IFL
50848 IDLAM(LKNT,3)=0
50849 XLAM(LKNT)=XFAC*(1D0-XMF**2/XMI2)**4
50850 ENDIF
50851 ENDIF
50852
50853C...2-BODY DECAYS OF SFERMION -> FERMION + GAUGE/GAUGINO
50854
50855C...CHARGED DECAYS:
50856 DO 140 IX=1,2
50857C...DI -> U CHI1-,CHI2-
50858 IF(IDU.EQ.1) THEN
50859 XMFP=PMAS(IFL+1,1)
50860 XMF =PMAS(IFL,1)
50861C...UI -> D CHI1+,CHI2+
50862 ELSE
50863 XMFP=PMAS(IFL-1,1)
50864 XMF =PMAS(IFL,1)
50865 ENDIF
50866 XMJ=SMW(IX)
50867 AXMJ=ABS(XMJ)
50868 IF(XMI.GE.AXMJ+XMFP) THEN
50869 XMA2=XMJ**2
50870 XMB2=XMFP**2
50871 IF(IDU.EQ.2) THEN
50872 IF(IFL.EQ.6) THEN
50873 XMFP=XMBOT
50874 XMF =XMTOP
50875 ELSEIF(IFL.LT.6) THEN
50876 XMF=0D0
50877 XMFP=0D0
50878 ENDIF
50879 CBL=VMIXC(IX,1)
50880 CAL=-XMFP*UMIXC(IX,2)/SR2/XMW/CBETA
50881 CBR=-XMF*VMIXC(IX,2)/SR2/XMW/SBETA
50882 CAR=0D0
50883 ELSE
50884 IF(IFL.EQ.5) THEN
50885 XMF =XMBOT
50886 XMFP=XMTOP
50887 ELSEIF(IFL.LT.5) THEN
50888 XMF=0D0
50889 XMFP=0D0
50890 ENDIF
50891 CBL=UMIXC(IX,1)
50892 CAL=-XMFP*VMIXC(IX,2)/SR2/XMW/SBETA
50893 CBR=-XMF*UMIXC(IX,2)/SR2/XMW/CBETA
50894 CAR=0D0
50895 ENDIF
50896
50897 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50898 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50899 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50900 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50901 CAL=CALP
50902 CBL=CBLP
50903 CAR=CARP
50904 CBR=CBRP
50905
50906C...F1 -> F` CHI
50907 IF(ILR.EQ.1) THEN
50908 CA=CAL
50909 CB=CBL
50910C...F2 -> F` CHI
50911 ELSE
50912 CA=CAR
50913 CB=CBR
50914 ENDIF
50915 LKNT=LKNT+1
50916 XL=PYLAMF(XMI2,XMA2,XMB2)
50917C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50918 XLAM(LKNT)=2D0*C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50919 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMFP)
50920 IDLAM(LKNT,3)=0
50921 IF(IDU.EQ.1) THEN
50922 IDLAM(LKNT,1)=-KFCCHI(IX)
50923 IDLAM(LKNT,2)=IFL+1
50924 ELSE
50925 IDLAM(LKNT,1)=KFCCHI(IX)
50926 IDLAM(LKNT,2)=IFL-1
50927 ENDIF
50928 ENDIF
50929 140 CONTINUE
50930
50931C...NEUTRAL DECAYS
50932 DO 150 IX=1,4
50933C...DI -> D CHI10
50934 XMF=PMAS(IFL,1)
50935 XMJ=SMZ(IX)
50936 AXMJ=ABS(XMJ)
50937 IF(XMI.GE.AXMJ+XMF) THEN
50938 XMA2=XMJ**2
50939 XMB2=XMF**2
50940 IF(IDU.EQ.1) THEN
50941 IF(IFL.EQ.5) THEN
50942 XMF=XMBOT
50943 ELSEIF(IFL.LT.5) THEN
50944 XMF=0D0
50945 ENDIF
50946 CBL=-ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI+1)
50947 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
50948 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50949 CBR=CAL
50950 ELSE
50951 IF(IFL.EQ.6) THEN
50952 XMF=XMTOP
50953 ELSEIF(IFL.LT.5) THEN
50954 XMF=0D0
50955 ENDIF
50956 CBL=ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-1)
50957 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
50958 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
50959 CBR=CAL
50960 ENDIF
50961
50962 CALP=SFMIX(IFL,1)*CAL + SFMIX(IFL,2)*CAR
50963 CBLP=SFMIX(IFL,1)*CBL + SFMIX(IFL,2)*CBR
50964 CARP=SFMIX(IFL,4)*CAR + SFMIX(IFL,3)*CAL
50965 CBRP=SFMIX(IFL,4)*CBR + SFMIX(IFL,3)*CBL
50966 CAL=CALP
50967 CBL=CBLP
50968 CAR=CARP
50969 CBR=CBRP
50970
50971C...F1 -> F CHI
50972 IF(ILR.EQ.1) THEN
50973 CA=CAL
50974 CB=CBL
50975C...F2 -> F CHI
50976 ELSE
50977 CA=CAR
50978 CB=CBR
50979 ENDIF
50980 LKNT=LKNT+1
50981 XL=PYLAMF(XMI2,XMA2,XMB2)
50982C...SPIN AVERAGE = 1/1 NOT 1/2....NO COLOR ENHANCEMENT
50983 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
50984 & (ABS(CA)**2+ABS(CB)**2)-4D0*DBLE(CA*DCONJG(CB))*XMJ*XMF)
50985 IDLAM(LKNT,1)=KFNCHI(IX)
50986 IDLAM(LKNT,2)=IFL
50987 IDLAM(LKNT,3)=0
50988 ENDIF
50989 150 CONTINUE
50990
50991C...2-BODY DECAYS TO SM GAUGE AND HIGGS BOSONS
50992C...IG=23,25,35,36
50993 DO 160 II=1,4
50994 IG=IGG(II)
50995 IF(ILR.EQ.1) GOTO 160
50996 XMB=PMAS(IG,1)
50997 XMSF1=PMAS(PYCOMP(KFIN-KSUSY1),1)
50998 IF(XMI.LT.XMSF1+XMB) GOTO 160
50999 IF(IG.EQ.23) THEN
51000 BL=-SIGN(.5D0,EI)/CW+EI*XW/CW
51001 BR=EI*XW/CW
51002 BLR=0D0
51003 ELSEIF(IG.EQ.25) THEN
51004 IF(IFL.EQ.5) THEN
51005 XMF=XMBOT
51006 ELSEIF(IFL.EQ.6) THEN
51007 XMF=XMTOP
51008 ELSEIF(IFL.LT.5) THEN
51009 XMF=0D0
51010 ELSE
51011 XMF=PMAS(IFL,1)
51012 ENDIF
51013 IF(IDU.EQ.2) THEN
51014 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
51015 & XMF**2/XMW*COSA/SBETA
51016 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
51017 & XMF**2/XMW*COSA/SBETA
51018 ELSE
51019 GHLL=XMZ/CW*(0.5D0-EI*XW)*(-SIN(ALFA+BETA))+
51020 & XMF**2/XMW*(-SINA)/CBETA
51021 GHRR=XMZ/CW*(EI*XW)*(-SIN(ALFA+BETA))+
51022 & XMF**2/XMW*(-SINA)/CBETA
51023 ENDIF
51024 IF(IFL.EQ.5) THEN
51025 AT=ATRIB
51026 ELSEIF(IFL.EQ.6) THEN
51027 AT=ATRIT
51028 ELSEIF(IFL.EQ.15) THEN
51029 AT=ATRIL
51030 ELSE
51031 AT=0D0
51032 ENDIF
51033C.........need to complexify
51034 IF(IDU.EQ.2) THEN
51035 GHLR=XMF/2D0/XMW/SBETA*(-XMU*SINA+
51036 & AT*COSA)
51037 ELSE
51038 GHLR=XMF/2D0/XMW/CBETA*(XMU*COSA-
51039 & AT*SINA)
51040 ENDIF
51041 BL=GHLL
51042 BR=GHRR
51043 BLR=-GHLR
51044 ELSEIF(IG.EQ.35) THEN
51045 IF(IFL.EQ.5) THEN
51046 XMF=XMBOT
51047 ELSEIF(IFL.EQ.6) THEN
51048 XMF=XMTOP
51049 ELSEIF(IFL.LT.5) THEN
51050 XMF=0D0
51051 ELSE
51052 XMF=PMAS(IFL,1)
51053 ENDIF
51054 IF(IDU.EQ.2) THEN
51055 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
51056 & XMF**2/XMW*SINA/SBETA
51057 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
51058 & XMF**2/XMW*SINA/SBETA
51059 ELSE
51060 GHLL=XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)+
51061 & XMF**2/XMW*COSA/CBETA
51062 GHRR=XMZ/CW*(EI*XW)*COS(ALFA+BETA)+
51063 & XMF**2/XMW*COSA/CBETA
51064 ENDIF
51065 IF(IFL.EQ.5) THEN
51066 AT=ATRIB
51067 ELSEIF(IFL.EQ.6) THEN
51068 AT=ATRIT
51069 ELSEIF(IFL.EQ.15) THEN
51070 AT=ATRIL
51071 ELSE
51072 AT=0D0
51073 ENDIF
51074C.........Need to complexify
51075 IF(IDU.EQ.2) THEN
51076 GHLR=XMF/2D0/XMW/SBETA*(XMU*COSA+
51077 & AT*SINA)
51078 ELSE
51079 GHLR=XMF/2D0/XMW/CBETA*(XMU*SINA+
51080 & AT*COSA)
51081 ENDIF
51082 BL=GHLL
51083 BR=GHRR
51084 BLR=GHLR
51085 ELSEIF(IG.EQ.36) THEN
51086 GHLL=0D0
51087 GHRR=0D0
51088 IF(IFL.EQ.5) THEN
51089 XMF=XMBOT
51090 ELSEIF(IFL.EQ.6) THEN
51091 XMF=XMTOP
51092 ELSEIF(IFL.LT.5) THEN
51093 XMF=0D0
51094 ELSE
51095 XMF=PMAS(IFL,1)
51096 ENDIF
51097 IF(IFL.EQ.5) THEN
51098 AT=ATRIB
51099 ELSEIF(IFL.EQ.6) THEN
51100 AT=ATRIT
51101 ELSEIF(IFL.EQ.15) THEN
51102 AT=ATRIL
51103 ELSE
51104 AT=0D0
51105 ENDIF
51106C.........Need to complexify
51107 IF(IDU.EQ.2) THEN
51108 GHLR=XMF/2D0/XMW*(-XMU+AT/TANB)
51109 ELSE
51110 GHLR=XMF/2D0/XMW/(-XMU+AT*TANB)
51111 ENDIF
51112 BL=GHLL
51113 BR=GHRR
51114 BLR=GHLR
51115 ENDIF
51116 AL=SFMIX(IFL,1)*SFMIX(IFL,3)*BL+
51117 & SFMIX(IFL,2)*SFMIX(IFL,4)*BR+
51118 & (SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,3)*SFMIX(IFL,2))*BLR
51119 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51120 LKNT=LKNT+1
51121 IF(IG.EQ.23) THEN
51122 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
51123 ELSE
51124 XLAM(LKNT)=C1/4D0/XMI3*SQRT(XL)*AL**2
51125 ENDIF
51126 IDLAM(LKNT,3)=0
51127 IDLAM(LKNT,1)=KFIN-KSUSY1
51128 IDLAM(LKNT,2)=IG
51129 160 CONTINUE
51130
51131C...SF -> SF' + W
51132 XMB=PMAS(24,1)
51133 IF(MOD(IFL,2).EQ.0) THEN
51134 KF1=KSUSY1+IFL-1
51135 ELSE
51136 KF1=KSUSY1+IFL+1
51137 ENDIF
51138 KF2=KF1+KSUSY1
51139 XMSF1=PMAS(PYCOMP(KF1),1)
51140 XMSF2=PMAS(PYCOMP(KF2),1)
51141 IF(XMI.GT.XMB+XMSF1) THEN
51142 IF(MOD(IFL,2).EQ.0) THEN
51143 IF(ILR.EQ.1) THEN
51144 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,1)
51145 ELSE
51146 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,1)
51147 ENDIF
51148 ELSE
51149 IF(ILR.EQ.1) THEN
51150 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,1)
51151 ELSE
51152 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,1)
51153 ENDIF
51154 ENDIF
51155 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51156 LKNT=LKNT+1
51157 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
51158 IDLAM(LKNT,3)=0
51159 IDLAM(LKNT,1)=KF1
51160 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
51161 ENDIF
51162 IF(XMI.GT.XMB+XMSF2) THEN
51163 IF(MOD(IFL,2).EQ.0) THEN
51164 IF(ILR.EQ.1) THEN
51165 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL-1,3)
51166 ELSE
51167 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL-1,3)
51168 ENDIF
51169 ELSE
51170 IF(ILR.EQ.1) THEN
51171 AL=1D0/SR2*SFMIX(IFL,1)*SFMIX(IFL+1,3)
51172 ELSE
51173 AL=1D0/SR2*SFMIX(IFL,3)*SFMIX(IFL+1,3)
51174 ENDIF
51175 ENDIF
51176 XL=PYLAMF(XMI2,XMSF2**2,XMB**2)
51177 LKNT=LKNT+1
51178 XLAM(LKNT)=C1/4D0/XMI3*XL**1.5D0/XMB**2*AL**2
51179 IDLAM(LKNT,3)=0
51180 IDLAM(LKNT,1)=KF2
51181 IDLAM(LKNT,2)=SIGN(24,KCHG(IFL,1))
51182 ENDIF
51183
51184C...SF -> SF' + HC
51185 XMB=PMAS(37,1)
51186 IF(MOD(IFL,2).EQ.0) THEN
51187 KF1=KSUSY1+IFL-1
51188 ELSE
51189 KF1=KSUSY1+IFL+1
51190 ENDIF
51191 KF2=KF1+KSUSY1
51192 XMSF1=PMAS(PYCOMP(KF1),1)
51193 XMSF2=PMAS(PYCOMP(KF2),1)
51194 IF(XMI.GT.XMB+XMSF1) THEN
51195 XMF=0D0
51196 XMFP=0D0
51197 AT=0D0
51198 AB=0D0
51199 IF(MOD(IFL,2).EQ.0) THEN
51200C...T1-> B1 HC
51201 IF(ILR.EQ.1) THEN
51202 CH1=-SFMIX(IFL,1)*SFMIX(IFL-1,1)
51203 CH2= SFMIX(IFL,2)*SFMIX(IFL-1,2)
51204 CH3=-SFMIX(IFL,1)*SFMIX(IFL-1,2)
51205 CH4=-SFMIX(IFL,2)*SFMIX(IFL-1,1)
51206C...T2-> B1 HC
51207 ELSE
51208 CH1= SFMIX(IFL,3)*SFMIX(IFL-1,1)
51209 CH2=-SFMIX(IFL,4)*SFMIX(IFL-1,2)
51210 CH3= SFMIX(IFL,3)*SFMIX(IFL-1,2)
51211 CH4= SFMIX(IFL,4)*SFMIX(IFL-1,1)
51212 ENDIF
51213 IF(IFL.EQ.6) THEN
51214 XMF=XMTOP
51215 XMFP=XMBOT
51216 AT=ATRIT
51217 AB=ATRIB
51218 ENDIF
51219 ELSE
51220C...B1 -> T1 HC
51221 IF(ILR.EQ.1) THEN
51222 CH1=-SFMIX(IFL+1,1)*SFMIX(IFL,1)
51223 CH2= SFMIX(IFL+1,2)*SFMIX(IFL,2)
51224 CH3=-SFMIX(IFL+1,1)*SFMIX(IFL,2)
51225 CH4=-SFMIX(IFL+1,2)*SFMIX(IFL,1)
51226C...B2-> T1 HC
51227 ELSE
51228 CH1= SFMIX(IFL,3)*SFMIX(IFL+1,1)
51229 CH2=-SFMIX(IFL,4)*SFMIX(IFL+1,2)
51230 CH3= SFMIX(IFL,4)*SFMIX(IFL+1,1)
51231 CH4= SFMIX(IFL,3)*SFMIX(IFL+1,2)
51232 ENDIF
51233 IF(IFL.EQ.5) THEN
51234 XMF=XMTOP
51235 XMFP=XMBOT
51236 AT=ATRIT
51237 AB=ATRIB
51238 ENDIF
51239 ENDIF
51240 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51241 LKNT=LKNT+1
51242C.......Need to complexify
51243 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
51244 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
51245 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
51246 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
51247 IDLAM(LKNT,3)=0
51248 IDLAM(LKNT,1)=KF1
51249 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
51250 ENDIF
51251 IF(XMI.GT.XMB+XMSF2) THEN
51252 XMF=0D0
51253 XMFP=0D0
51254 AT=0D0
51255 AB=0D0
51256 IF(MOD(IFL,2).EQ.0) THEN
51257C...T1-> B2 HC
51258 IF(ILR.EQ.1) THEN
51259 CH1= SFMIX(IFL-1,3)*SFMIX(IFL,1)
51260 CH2=-SFMIX(IFL-1,4)*SFMIX(IFL,2)
51261 CH3= SFMIX(IFL-1,4)*SFMIX(IFL,1)
51262 CH4= SFMIX(IFL-1,3)*SFMIX(IFL,2)
51263C...T2-> B2 HC
51264 ELSE
51265 CH1= -SFMIX(IFL,3)*SFMIX(IFL-1,3)
51266 CH2= SFMIX(IFL,4)*SFMIX(IFL-1,4)
51267 CH3= -SFMIX(IFL,3)*SFMIX(IFL-1,4)
51268 CH4= -SFMIX(IFL,4)*SFMIX(IFL-1,3)
51269 ENDIF
51270 IF(IFL.EQ.6) THEN
51271 XMF=XMTOP
51272 XMFP=XMBOT
51273 AT=ATRIT
51274 AB=ATRIB
51275 ENDIF
51276 ELSE
51277C...B1 -> T2 HC
51278 IF(ILR.EQ.1) THEN
51279 CH1= SFMIX(IFL+1,3)*SFMIX(IFL,1)
51280 CH2=-SFMIX(IFL+1,4)*SFMIX(IFL,2)
51281 CH3= SFMIX(IFL+1,3)*SFMIX(IFL,2)
51282 CH4= SFMIX(IFL+1,4)*SFMIX(IFL,1)
51283C...B2-> T2 HC
51284 ELSE
51285 CH1= -SFMIX(IFL+1,3)*SFMIX(IFL,3)
51286 CH2= SFMIX(IFL+1,4)*SFMIX(IFL,4)
51287 CH3= -SFMIX(IFL+1,3)*SFMIX(IFL,4)
51288 CH4= -SFMIX(IFL+1,4)*SFMIX(IFL,3)
51289 ENDIF
51290 IF(IFL.EQ.5) THEN
51291 XMF=XMTOP
51292 XMFP=XMBOT
51293 AT=ATRIT
51294 AB=ATRIB
51295 ENDIF
51296 ENDIF
51297 XL=PYLAMF(XMI2,XMSF1**2,XMB**2)
51298 LKNT=LKNT+1
51299C.......Need to complexify
51300 AL=CH1*(XMW2*2D0*CBETA*SBETA-XMFP**2*TANB-XMF**2/TANB)+
51301 & CH2*2D0*XMF*XMFP/(2D0*CBETA*SBETA)+
51302 & CH3*XMFP*(-XMU+AB*TANB)+CH4*XMF*(-XMU+AT/TANB)
51303 XLAM(LKNT)=C1/8D0/XMI3*SQRT(XL)/XMW2*AL**2
51304 IDLAM(LKNT,3)=0
51305 IDLAM(LKNT,1)=KF2
51306 IDLAM(LKNT,2)=SIGN(37,KCHG(IFL,1))
51307 ENDIF
51308
51309C...2-BODY DECAYS OF SQUARK -> QUARK GLUINO
51310
51311 IF(IFL.LE.6) THEN
51312 XMFP=0D0
51313 XMF=0D0
51314 IF(IFL.EQ.6) XMF=PMAS(6,1)
51315 IF(IFL.EQ.5) XMF=PMAS(5,1)
51316 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
51317 AXMJ=ABS(XMJ)
51318 IF(XMI.GE.AXMJ+XMF) THEN
51319 AL=-SFMIX(IFL,3)
51320 BL=SFMIX(IFL,1)
51321 AR=-SFMIX(IFL,4)
51322 BR=SFMIX(IFL,2)
51323C...F1 -> F CHI
51324 IF(ILR.EQ.1) THEN
51325 XCA=AL
51326 XCB=BL
51327C...F2 -> F CHI
51328 ELSE
51329 XCA=AR
51330 XCB=BR
51331 ENDIF
51332 LKNT=LKNT+1
51333 XMA2=XMJ**2
51334 XMB2=XMF**2
51335 XL=PYLAMF(XMI2,XMA2,XMB2)
51336 XLAM(LKNT)=4D0/3D0*AS/2D0/XMI3*SQRT(XL)*((XMI2-XMB2-XMA2)*
51337 & (XCA**2+XCB**2)+4D0*XCA*XCB*XMJ*XMF)
51338 IDLAM(LKNT,1)=KSUSY1+21
51339 IDLAM(LKNT,2)=IFL
51340 IDLAM(LKNT,3)=0
51341 ENDIF
51342 ENDIF
51343
51344C...IF NOTHING ELSE FOR T1, THEN T1* -> C+CHI0
51345 IF(KFIN.EQ.KSUSY1+6.AND.PMAS(KCIN,1).GT.
51346 &PMAS(PYCOMP(KSUSY1+22),1)+PMAS(4,1)) THEN
51347C...THIS IS A BACK-OF-THE-ENVELOPE ESTIMATE
51348C...M = 1/(16PI**2)G**3 = G*2/(4PI) G/(4PI) = C1 * G/(4PI)
51349C...M*M = C1**2 * G**2/(16PI**2)
51350C...G = 1/(8PI)P/MI**2 * M*M = C1**3/(32PI**2)*LAM/(2*MI**3)
51351 LKNT=LKNT+1
51352 XL=PYLAMF(XMI2,0D0,PMAS(PYCOMP(KSUSY1+22),1)**2)
51353 XLAM(LKNT)=C1**3/64D0/PI**2/XMI3*SQRT(XL)
51354 IF(XLAM(LKNT).EQ.0) XLAM(LKNT)=1D-3
51355 IDLAM(LKNT,1)=KSUSY1+22
51356 IDLAM(LKNT,2)=4
51357 IDLAM(LKNT,3)=0
51358 ENDIF
51359
51360C...R-violating sfermion decays (SKANDS).
51361 CALL PYRVSF(KFIN,XLAM,IDLAM,LKNT)
51362
51363 IKNT=LKNT
51364 XLAM(0)=0D0
51365 DO 170 I=1,IKNT
51366 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
51367 XLAM(0)=XLAM(0)+XLAM(I)
51368 170 CONTINUE
51369 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-3
51370
51371 RETURN
51372 END
51373
51374C*********************************************************************
51375
51376C...PYGLUI
51377C...Calculates gluino decay modes.
51378
51379 SUBROUTINE PYGLUI(KFIN,XLAM,IDLAM,IKNT)
51380
51381C...Double precision and integer declarations.
51382 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51383 IMPLICIT INTEGER(I-N)
51384 INTEGER PYK,PYCHGE,PYCOMP
51385C...Parameter statement to help give large particle numbers.
51386 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51387 &KEXCIT=4000000,KDIMEN=5000000)
51388C...Commonblocks.
51389 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51390 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51391 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51392 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51393 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51394CC &SFMIX(16,4),
51395C COMMON/PYINTS/XXM(20)
51396 COMPLEX*16 CXC
51397 COMMON/PYINTC/XXC(10),CXC(8)
51398 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
51399
51400C...Local variables
51401 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
51402 DOUBLE PRECISION XMI,XMJ,XMF,AXMJ,AXMI
51403 DOUBLE PRECISION XMI2,XMI3,XMA2,XMB2,XMFP
51404 DOUBLE PRECISION PYLAMF,XL
51405 DOUBLE PRECISION TANW,XW,AEM,C1,AS,S12MAX,S12MIN
51406 DOUBLE PRECISION CA,CB,AL,AR,BL,BR
51407 DOUBLE PRECISION XLAM(0:400)
51408 INTEGER IDLAM(400,3)
51409 INTEGER LKNT,IX,ILR,I,IKNT,IFL
51410 DOUBLE PRECISION SR2
51411 DOUBLE PRECISION GAM
51412 DOUBLE PRECISION PYALEM,PI,PYALPS,EI,T3I
51413 EXTERNAL PYGAUS,PYXXZ6
51414 DOUBLE PRECISION PYGAUS,PYXXZ6
51415 DOUBLE PRECISION PREC
51416 INTEGER KFNCHI(4),KFCCHI(2)
51417 DATA PI/3.141592654D0/
51418 DATA SR2/1.4142136D0/
51419 DATA PREC/1D-2/
51420 DATA KFNCHI/1000022,1000023,1000025,1000035/
51421 DATA KFCCHI/1000024,1000037/
51422
51423C...COUNT THE NUMBER OF DECAY MODES
51424 LKNT=0
51425 IF(KFIN.NE.KSUSY1+21) RETURN
51426 KCIN=PYCOMP(KFIN)
51427
51428 XW=PARU(102)
51429 TANW = SQRT(XW/(1D0-XW))
51430
51431 XMI=PMAS(KCIN,1)
51432 AXMI=ABS(XMI)
51433 XMI2=XMI**2
51434 AEM=PYALEM(XMI2)
51435 AS =PYALPS(XMI2)
51436 C1=AEM/XW
51437 XMI3=AXMI**3
51438
51439 XMI=SIGN(XMI,RMSS(3))
51440
51441C...2-BODY DECAYS OF GLUINO -> GRAVITINO GLUON
51442
51443 IF(IMSS(11).EQ.1) THEN
51444 XMP=RMSS(29)
51445 IDG=39+KSUSY1
51446 XMGR=PMAS(PYCOMP(IDG),1)
51447 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
51448 IF(AXMI.GT.XMGR) THEN
51449 LKNT=LKNT+1
51450 IDLAM(LKNT,1)=IDG
51451 IDLAM(LKNT,2)=21
51452 IDLAM(LKNT,3)=0
51453 XLAM(LKNT)=XFAC
51454 ENDIF
51455 ENDIF
51456
51457C...2-BODY DECAYS OF GLUINO -> QUARK SQUARK
51458
51459 DO 110 IFL=1,6
51460 DO 100 ILR=1,2
51461 XMJ=PMAS(PYCOMP(ILR*KSUSY1+IFL),1)
51462 AXMJ=ABS(XMJ)
51463 XMF=PMAS(IFL,1)
51464 IF(AXMI.GE.AXMJ+XMF) THEN
51465C...Minus sign difference from gluino-quark-squark feynman rules
51466 AL=SFMIX(IFL,1)
51467 BL=-SFMIX(IFL,3)
51468 AR=SFMIX(IFL,2)
51469 BR=-SFMIX(IFL,4)
51470C...F1 -> F CHI
51471 IF(ILR.EQ.1) THEN
51472 CA=AL
51473 CB=BL
51474C...F2 -> F CHI
51475 ELSE
51476 CA=AR
51477 CB=BR
51478 ENDIF
51479 LKNT=LKNT+1
51480 XMA2=XMJ**2
51481 XMB2=XMF**2
51482 XL=PYLAMF(XMI2,XMA2,XMB2)
51483 XLAM(LKNT)=4D0/8D0*AS/4D0/XMI3*SQRT(XL)*((XMI2+XMB2-XMA2)*
51484 & (CA**2+CB**2)-4D0*CA*CB*XMI*XMF)
51485 IDLAM(LKNT,1)=ILR*KSUSY1+IFL
51486 IDLAM(LKNT,2)=-IFL
51487 IDLAM(LKNT,3)=0
51488 LKNT=LKNT+1
51489 XLAM(LKNT)=XLAM(LKNT-1)
51490 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51491 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51492 IDLAM(LKNT,3)=0
51493 ENDIF
51494 100 CONTINUE
51495 110 CONTINUE
51496
51497C...3-BODY DECAYS TO GAUGINO FERMION-FERMION
51498C...GLUINO -> NI Q QBAR
51499 DO 170 IX=1,4
51500 XMJ=SMZ(IX)
51501 AXMJ=ABS(XMJ)
51502 IF(AXMI.GE.AXMJ) THEN
51503 DO 120 I=1,4
51504 ZMIXC(IX,I)=DCMPLX(ZMIX(IX,I),ZMIXI(IX,I))
51505 120 CONTINUE
51506 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))/SR2
51507 ORPP=DCONJG(OLPP)
51508 XXC(1)=0D0
51509 XXC(2)=XMJ
51510 XXC(3)=0D0
51511 XXC(4)=XMI
51512 IA=1
51513 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
51514 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
51515 XXC(7)=XXC(5)
51516 XXC(8)=XXC(6)
51517 XXC(9)=1D6
51518 XXC(10)=0D0
51519 EI=KCHG(IA,1)/3D0
51520 T3I=SIGN(1D0,EI+1D-6)/2D0
51521 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51522 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51523 CXC(1)=0D0
51524 CXC(2)=-GLIJ
51525 CXC(3)=0D0
51526 CXC(4)=DCONJG(GLIJ)
51527 CXC(5)=0D0
51528 CXC(6)=GRIJ
51529 CXC(7)=0D0
51530 CXC(8)=-DCONJG(GRIJ)
51531 S12MIN=0D0
51532 S12MAX=(AXMI-AXMJ)**2
51533 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 130
51534 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
51535 LKNT=LKNT+1
51536 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
51537 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
51538 IDLAM(LKNT,1)=KFNCHI(IX)
51539 IDLAM(LKNT,2)=1
51540 IDLAM(LKNT,3)=-1
51541 ENDIF
51542 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
51543 LKNT=LKNT+1
51544 XLAM(LKNT)=XLAM(LKNT-1)
51545 IDLAM(LKNT,1)=KFNCHI(IX)
51546 IDLAM(LKNT,2)=3
51547 IDLAM(LKNT,3)=-3
51548 ENDIF
51549 130 CONTINUE
51550 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
51551 PMOLD=PMAS(PYCOMP(KSUSY1+5),1)
51552 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+5),1)+PMAS(5,1)) THEN
51553 GOTO 140
51554 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+5),1)+PMAS(5,1)) THEN
51555 PMAS(PYCOMP(KSUSY1+5),1)=100D0*XMI
51556 ENDIF
51557 CALL PYTBBN(IX,100,-1D0/3D0,XMI,GAM)
51558 LKNT=LKNT+1
51559 XLAM(LKNT)=GAM
51560 IDLAM(LKNT,1)=KFNCHI(IX)
51561 IDLAM(LKNT,2)=5
51562 IDLAM(LKNT,3)=-5
51563 PMAS(PYCOMP(KSUSY1+5),1)=PMOLD
51564 ENDIF
51565C...U-TYPE QUARKS
51566 140 CONTINUE
51567 IA=2
51568 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
51569 XXC(6)=PMAS(PYCOMP(KSUSY2+IA),1)
51570C IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 290
51571 XXC(7)=XXC(5)
51572 XXC(8)=XXC(6)
51573 EI=KCHG(IA,1)/3D0
51574 T3I=SIGN(1D0,EI+1D-6)/2D0
51575 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
51576 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
51577 CXC(2)=-GLIJ
51578 CXC(4)=DCONJG(GLIJ)
51579 CXC(6)=GRIJ
51580 CXC(8)=-DCONJG(GRIJ)
51581 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 150
51582 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
51583 LKNT=LKNT+1
51584 XLAM(LKNT)=C1*AS/XMI3/(16D0*PI)*
51585 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-2)
51586 IDLAM(LKNT,1)=KFNCHI(IX)
51587 IDLAM(LKNT,2)=2
51588 IDLAM(LKNT,3)=-2
51589 ENDIF
51590 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
51591 LKNT=LKNT+1
51592 XLAM(LKNT)=XLAM(LKNT-1)
51593 IDLAM(LKNT,1)=KFNCHI(IX)
51594 IDLAM(LKNT,2)=4
51595 IDLAM(LKNT,3)=-4
51596 ENDIF
51597 150 CONTINUE
51598C...INCLUDE THE DECAY GLUINO -> NJ + T + T~
51599C...IF THE DECAY GLUINO -> ST + T CANNOT OCCUR
51600 XMF=PMAS(6,1)
51601 IF(AXMI.GE.AXMJ+2D0*XMF) THEN
51602 PMOLD=PMAS(PYCOMP(KSUSY1+6),1)
51603 IF(AXMI.GT.PMAS(PYCOMP(KSUSY2+6),1)+XMF) THEN
51604 GOTO 160
51605 ELSEIF(AXMI.GT.PMAS(PYCOMP(KSUSY1+6),1)+XMF) THEN
51606 PMAS(PYCOMP(KSUSY1+6),1)=100D0*XMI
51607 ENDIF
51608 CALL PYTBBN(IX,100,2D0/3D0,XMI,GAM)
51609 LKNT=LKNT+1
51610 XLAM(LKNT)=GAM
51611 IDLAM(LKNT,1)=KFNCHI(IX)
51612 IDLAM(LKNT,2)=6
51613 IDLAM(LKNT,3)=-6
51614 PMAS(PYCOMP(KSUSY1+6),1)=PMOLD
51615 ENDIF
51616 160 CONTINUE
51617 ENDIF
51618 170 CONTINUE
51619
51620C...GLUINO -> CI Q QBAR'
51621 DO 210 IX=1,2
51622 XMJ=SMW(IX)
51623 AXMJ=ABS(XMJ)
51624 IF(AXMI.GE.AXMJ) THEN
51625 DO 180 I=1,2
51626 VMIXC(IX,I)=DCMPLX(VMIX(IX,I),VMIXI(IX,I))
51627 UMIXC(IX,I)=DCMPLX(UMIX(IX,I),UMIXI(IX,I))
51628 180 CONTINUE
51629 S12MIN=0D0
51630 S12MAX=(AXMI-AXMJ)**2
51631 XXC(1)=0D0
51632 XXC(2)=XMJ
51633 XXC(3)=0D0
51634 XXC(4)=XMI
51635 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
51636 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
51637 XXC(9)=1D6
51638 XXC(10)=0D0
51639 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
51640 ORPP=DCONJG(OLPP)
51641 CXC(1)=DCMPLX(0D0,0D0)
51642 CXC(3)=DCMPLX(0D0,0D0)
51643 CXC(5)=DCMPLX(0D0,0D0)
51644 CXC(7)=DCMPLX(0D0,0D0)
51645 CXC(2)=UMIXC(IX,1)*OLPP/SR2
51646 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
51647 CXC(6)=DCMPLX(0D0,0D0)
51648 CXC(8)=DCMPLX(0D0,0D0)
51649 IF(XXC(5).LT.AXMI) THEN
51650 XXC(5)=1D6
51651 ELSEIF(XXC(6).LT.AXMI) THEN
51652 XXC(6)=1D6
51653 ENDIF
51654 XXC(7)=XXC(6)
51655 XXC(8)=XXC(5)
51656 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 190
51657 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
51658 LKNT=LKNT+1
51659 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
51660 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
51661 IDLAM(LKNT,1)=KFCCHI(IX)
51662 IDLAM(LKNT,2)=1
51663 IDLAM(LKNT,3)=-2
51664 LKNT=LKNT+1
51665 XLAM(LKNT)=XLAM(LKNT-1)
51666 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51667 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51668 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51669 ENDIF
51670 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
51671 LKNT=LKNT+1
51672 XLAM(LKNT)=XLAM(LKNT-1)
51673 IDLAM(LKNT,1)=KFCCHI(IX)
51674 IDLAM(LKNT,2)=3
51675 IDLAM(LKNT,3)=-4
51676 LKNT=LKNT+1
51677 XLAM(LKNT)=XLAM(LKNT-1)
51678 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51679 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51680 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51681 ENDIF
51682 190 CONTINUE
51683
51684 XMF=PMAS(6,1)
51685 XMFP=PMAS(5,1)
51686 IF(AXMI.GE.AXMJ+XMF+XMFP) THEN
51687 IF(XMI.GT.MIN(PMAS(PYCOMP(KSUSY1+5),1)+XMFP,
51688 $ PMAS(PYCOMP(KSUSY2+6),1)+XMF)) GOTO 200
51689 PMOLT2=PMAS(PYCOMP(KSUSY2+6),1)
51690 PMOLB2=PMAS(PYCOMP(KSUSY2+5),1)
51691 PMOLT1=PMAS(PYCOMP(KSUSY1+6),1)
51692 PMOLB1=PMAS(PYCOMP(KSUSY1+5),1)
51693 IF(XMI.GT.PMOLT2+XMF) PMAS(PYCOMP(KSUSY2+6),1)=100D0*AXMI
51694 IF(XMI.GT.PMOLT1+XMF) PMAS(PYCOMP(KSUSY1+6),1)=100D0*AXMI
51695 IF(XMI.GT.PMOLB2+XMFP) PMAS(PYCOMP(KSUSY2+5),1)=100D0*AXMI
51696 IF(XMI.GT.PMOLB1+XMFP) PMAS(PYCOMP(KSUSY1+5),1)=100D0*AXMI
51697 CALL PYTBBC(IX,100,XMI,GAM)
51698 LKNT=LKNT+1
51699 XLAM(LKNT)=GAM
51700 IDLAM(LKNT,1)=KFCCHI(IX)
51701 IDLAM(LKNT,2)=5
51702 IDLAM(LKNT,3)=-6
51703 LKNT=LKNT+1
51704 XLAM(LKNT)=XLAM(LKNT-1)
51705 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
51706 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
51707 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
51708 PMAS(PYCOMP(KSUSY2+6),1)=PMOLT2
51709 PMAS(PYCOMP(KSUSY2+5),1)=PMOLB2
51710 PMAS(PYCOMP(KSUSY1+6),1)=PMOLT1
51711 PMAS(PYCOMP(KSUSY1+5),1)=PMOLB1
51712 ENDIF
51713 200 CONTINUE
51714 ENDIF
51715 210 CONTINUE
51716
51717C...R-parity violating (3-body) decays.
51718 CALL PYRVGL(KFIN,XLAM,IDLAM,LKNT)
51719
51720 IKNT=LKNT
51721 XLAM(0)=0D0
51722 DO 220 I=1,IKNT
51723 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
51724 XLAM(0)=XLAM(0)+XLAM(I)
51725 220 CONTINUE
51726 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
51727
51728 RETURN
51729 END
51730
51731
51732C*********************************************************************
51733
51734C...PYTBBN
51735C...Calculates the three-body decay of gluinos into
51736C...neutralinos and third generation fermions.
51737
51738 SUBROUTINE PYTBBN(I,NN,E,XMGLU,GAM)
51739
51740C...Double precision and integer declarations.
51741 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51742 IMPLICIT INTEGER(I-N)
51743 INTEGER PYK,PYCHGE,PYCOMP
51744C...Parameter statement to help give large particle numbers.
51745 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51746 &KEXCIT=4000000,KDIMEN=5000000)
51747C...Commonblocks.
51748 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51749 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51750 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51751 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51752 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51753 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
51754
51755C...Local variables.
51756 EXTERNAL PYSIMP,PYLAMF
51757 DOUBLE PRECISION PYSIMP,PYLAMF
51758 INTEGER LIN,NN
51759 DOUBLE PRECISION COSD,SIND,COSD2,SIND2,COS2D,SIN2D
51760 DOUBLE PRECISION HL,HR,FL,FR,HL2,HR2,FL2,FR2
51761 DOUBLE PRECISION XMS2(2),XM,XM2,XMG,XMG2,XMR,XMR2
51762 DOUBLE PRECISION SBAR,SMIN,SMAX,XMQA,W,GRS,G(0:6),SUMME(0:100)
51763 DOUBLE PRECISION FF,HH,HFL,HFR,HRFL,HLFR,XMQ4,XM24
51764 DOUBLE PRECISION XLN1,XLN2,B1,B2
51765 DOUBLE PRECISION E,XMGLU,GAM
51766 DOUBLE PRECISION HRB(4),HLB(4),FLB(4),FRB(4)
51767 SAVE HRB,HLB,FLB,FRB
51768 DOUBLE PRECISION ALPHAW,ALPHAS
51769 DOUBLE PRECISION HLT(4),HRT(4),FLT(4),FRT(4)
51770 SAVE HLT,HRT,FLT,FRT
51771 DOUBLE PRECISION AMN(4),AN(4,4),ZN(3)
51772 SAVE AMN,AN,ZN
51773 DOUBLE PRECISION AMBOT,SINC,COSC
51774 DOUBLE PRECISION AMTOP,SINA,COSA
51775 DOUBLE PRECISION SINW,COSW,TANW
51776 DOUBLE PRECISION ROT1(4,4)
51777 LOGICAL IFIRST
51778 SAVE IFIRST
51779 DATA IFIRST/.TRUE./
51780
51781 TANB=RMSS(5)
51782 SINB=TANB/SQRT(1D0+TANB**2)
51783 COSB=SINB/TANB
51784 XW=PARU(102)
51785 SINW=SQRT(XW)
51786 COSW=SQRT(1D0-XW)
51787 TANW=SINW/COSW
51788 AMW=PMAS(24,1)
51789 COSC=SFMIX(5,1)
51790 SINC=SFMIX(5,3)
51791 COSA=SFMIX(6,1)
51792 SINA=SFMIX(6,3)
51793 AMBOT=PYMRUN(5,XMGLU**2)
51794 AMTOP=PYMRUN(6,XMGLU**2)
51795 W2=SQRT(2D0)
51796 FAKT1=AMBOT/W2/AMW/COSB
51797 FAKT2=AMTOP/W2/AMW/SINB
51798 IF(IFIRST) THEN
51799 DO 110 II=1,4
51800 AMN(II)=SMZ(II)
51801 DO 100 J=1,4
51802 ROT1(II,J)=0D0
51803 AN(II,J)=0D0
51804 100 CONTINUE
51805 110 CONTINUE
51806 ROT1(1,1)=COSW
51807 ROT1(1,2)=-SINW
51808 ROT1(2,1)=-ROT1(1,2)
51809 ROT1(2,2)=ROT1(1,1)
51810 ROT1(3,3)=COSB
51811 ROT1(3,4)=SINB
51812 ROT1(4,3)=-ROT1(3,4)
51813 ROT1(4,4)=ROT1(3,3)
51814 DO 140 II=1,4
51815 DO 130 J=1,4
51816 DO 120 JJ=1,4
51817 AN(II,J)=AN(II,J)+ZMIX(II,JJ)*ROT1(JJ,J)
51818 120 CONTINUE
51819 130 CONTINUE
51820 140 CONTINUE
51821 DO 150 J=1,4
51822 ZN(1)=-FAKT2*(-SINB*AN(J,3)+COSB*AN(J,4))
51823 ZN(2)=-2D0*W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51824 ZN(3)=-2*W2/3D0*SINW*AN(J,1)-W2*(0.5D0-2D0/3D0*
51825 & XW)*AN(J,2)/COSW
51826 HRT(J)=ZN(1)*COSA-ZN(3)*SINA
51827 HLT(J)=ZN(1)*COSA+ZN(2)*SINA
51828 FLT(J)=ZN(3)*COSA+ZN(1)*SINA
51829 FRT(J)=ZN(2)*COSA-ZN(1)*SINA
51830C FLU(J)=ZN(3)
51831C FRU(J)=ZN(2)
51832 ZN(1)=-FAKT1*(COSB*AN(J,3)+SINB*AN(J,4))
51833 ZN(2)=W2/3D0*SINW*(TANW*AN(J,2)-AN(J,1))
51834 ZN(3)=W2/3D0*SINW*AN(J,1)+W2*(0.5D0-XW/3D0)*AN(J,2)/COSW
51835 HRB(J)=ZN(1)*COSC-ZN(3)*SINC
51836 HLB(J)=ZN(1)*COSC+ZN(2)*SINC
51837 FLB(J)=ZN(3)*COSC+ZN(1)*SINC
51838 FRB(J)=ZN(2)*COSC-ZN(1)*SINC
51839C FLD(J)=ZN(3)
51840C FRD(J)=ZN(2)
51841 150 CONTINUE
51842C AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
51843C AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
51844C AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
51845C AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
51846 IFIRST=.FALSE.
51847 ENDIF
51848
51849 IF(NINT(3D0*E).EQ.2) THEN
51850 HL=HLT(I)
51851 HR=HRT(I)
51852 FL=FLT(I)
51853 FR=FRT(I)
51854 COSD=SFMIX(6,1)
51855 SIND=SFMIX(6,3)
51856 XMS2(1)=PMAS(PYCOMP(KSUSY1+6),1)**2
51857 XMS2(2)=PMAS(PYCOMP(KSUSY2+6),1)**2
51858 XM=PMAS(6,1)
51859 ELSE
51860 HL=HLB(I)
51861 HR=HRB(I)
51862 FL=FLB(I)
51863 FR=FRB(I)
51864 COSD=SFMIX(5,1)
51865 SIND=SFMIX(5,3)
51866 XMS2(1)=PMAS(PYCOMP(KSUSY1+5),1)**2
51867 XMS2(2)=PMAS(PYCOMP(KSUSY2+5),1)**2
51868 XM=PMAS(5,1)
51869 ENDIF
51870 COSD2=COSD*COSD
51871 SIND2=SIND*SIND
51872 COS2D=COSD2-SIND2
51873 SIN2D=SIND*COSD*2D0
51874 HL2=HL*HL
51875 HR2=HR*HR
51876 FL2=FL*FL
51877 FR2=FR*FR
51878 FF=FL*FR
51879 HH=HL*HR
51880 HFL=HL*FL
51881 HFR=HR*FR
51882 HRFL=HR*FL
51883 HLFR=HL*FR
51884 XM2=XM*XM
51885 XMG=XMGLU
51886 XMG2=XMG*XMG
51887 ALPHAW=PYALEM(XMG2)
51888 ALPHAS=PYALPS(XMG2)
51889 XMR=AMN(I)
51890 XMR2=XMR*XMR
51891 XMQ4=XMG*XM2*XMR
51892 XM24=(XMG2+XM2)*(XM2+XMR2)
51893 SMIN=4D0*XM2
51894 SMAX=(XMG-ABS(XMR))**2
51895 XMQA=XMG2+2D0*XM2+XMR2
51896 DO 170 LIN=1,NN-1
51897 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
51898 GRS=SBAR-XMQA
51899 W=PYLAMF(XMG2,XMR2,SBAR)*(0.25D0-XM2/SBAR)
51900 W=DSQRT(W)
51901 XLN1=LOG(ABS((GRS/2D0+XMS2(1)-W)/(GRS/2D0+XMS2(1)+W)))
51902 XLN2=LOG(ABS((GRS/2D0+XMS2(2)-W)/(GRS/2D0+XMS2(2)+W)))
51903 B1=1D0/(GRS/2D0+XMS2(1)-W)-1D0/(GRS/2D0+XMS2(1)+W)
51904 B2=1D0/(GRS/2D0+XMS2(2)-W)-1D0/(GRS/2D0+XMS2(2)+W)
51905 G(0)=-2D0*(HL2+FL2+HR2+FR2+(HFR-HFL)*SIN2D
51906 & +2D0*(FF*SIND2-HH*COSD2))*W
51907 G(1)=((HL2+FL2)*(XMQA-2D0*XMS2(1)-2D0*XM*XMG*SIN2D)
51908 & +4D0*HFL*XM*XMR)*XLN1
51909 & +((HL2+FL2)*((XMQA-XMS2(1))*XMS2(1)-XM24
51910 & +2D0*XM*XMG*(XM2+XMR2-XMS2(1))*SIN2D)
51911 & -4D0*HFL*XMR*XM*(XMG2+XM2-XMS2(1))
51912 & +8D0*HFL*XMQ4*SIN2D)*B1
51913 G(2)=((HR2+FR2)*(XMQA-2D0*XMS2(2)+2D0*XM*XMG*SIN2D)
51914 & +4D0*HFR*XMR*XM)*XLN2
51915 & +((HR2+FR2)*((XMQA-XMS2(2))*XMS2(2)-XM24
51916 & +2D0*XMG*XM*SIN2D*(XMS2(2)-XM2-XMR2))
51917 & +4D0*HFR*XM*XMR*(XMS2(2)-XMG2-XM2)
51918 & -8D0*HFR*XMQ4*SIN2D)*B2
51919 G(3)=(2D0*HFL*SIN2D*(XMS2(1)*(GRS+XMS2(1))+XM2*(SBAR-XMG2-XMR2)
51920 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HL2*SIND2+FL2*COSD2)*SBAR
51921 & -2D0*XMG*XM*HFL*(SBAR+XMR2-XMG2)
51922 & +XMR*XM*(HL2+FL2)*SIN2D*(SBAR+XMG2-XMR2)
51923 & -4D0*XMQ4*(HL2-FL2)*COS2D)/(GRS+2D0*XMS2(1))*XLN1
51924 G(4)=4D0*COS2D*XM*XMG/(XMS2(1)-XMS2(2))*
51925 & (((HLFR+HRFL)*(XM2+XMR2)+2D0*XM*XMR*(HH+FF))*(XLN1-XLN2)
51926 & +(HLFR+HRFL)*(XMS2(2)*XLN2-XMS2(1)*XLN1))
51927 G(5)=(2D0*(HH*COSD2-FF*SIND2)
51928 & *((XMS2(2)*(XMS2(2)+GRS)+XM2*XM2+XMG2*XMR2)*XLN2
51929 & +(XMS2(1)*(XMS2(1)+GRS)+XM2*XM2+XMG2*XMR2)*XLN1)
51930 & +XM*((HH-FF)*SIN2D*XMG-(HRFL-HLFR)*XMR)
51931 & *((GRS+XMS2(1)*2D0)*XLN1-(GRS+XMS2(2)*2D0)*XLN2)
51932 & +((HRFL-HLFR)*XMR*(SIN2D*XMG*(SBAR-4D0*XM2)
51933 & +COS2D*XM*(SBAR+XMG2-XMR2))
51934 & +2D0*(FF*COSD2-HH*SIND2)*XM2*(SBAR-XMG2-XMR2))
51935 & *(XLN1+XLN2))/(GRS+XMS2(1)+XMS2(2))
51936 G(6)=(-2D0*HFR*SIN2D*(XMS2(2)*(GRS+XMS2(2))+XM2*(SBAR-XMG2-XMR2)
51937 & +XMG2*XMR2+XM2*XM2)-2D0*XMR*XMG*(HR2*SIND2+FR2*COSD2)*SBAR
51938 & -2D0*XMG*XM*HFR*(SBAR+XMR2-XMG2)
51939 & -XMR*XM*(HR2+FR2)*SIN2D*(SBAR+XMG2-XMR2)
51940 & -4D0*XMQ4*(HR2-FR2)*COS2D)/(GRS+2D0*XMS2(2))*XLN2
51941 SUMME(LIN)=0D0
51942 DO 160 J=0,6
51943 SUMME(LIN)=SUMME(LIN)+G(J)
51944 160 CONTINUE
51945 170 CONTINUE
51946 SUMME(0)=0D0
51947 SUMME(NN)=0D0
51948 GAM = ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
51949 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
51950
51951 RETURN
51952 END
51953
51954C*********************************************************************
51955
51956C...PYTBBC
51957C...Calculates the three-body decay of gluinos into
51958C...charginos and third generation fermions.
51959
51960 SUBROUTINE PYTBBC(I,NN,XMGLU,GAM)
51961
51962C...Double precision and integer declarations.
51963 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
51964 IMPLICIT INTEGER(I-N)
51965 INTEGER PYK,PYCHGE,PYCOMP
51966C...Parameter statement to help give large particle numbers.
51967 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
51968 &KEXCIT=4000000,KDIMEN=5000000)
51969C...Commonblocks.
51970 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
51971 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
51972 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
51973 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
51974 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
51975 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/
51976
51977C...Local variables.
51978 EXTERNAL PYSIMP,PYLAMF
51979 DOUBLE PRECISION PYSIMP,PYLAMF
51980 INTEGER I,NN,LIN
51981 DOUBLE PRECISION XMG,XMG2,XMB,XMB2,XMR,XMR2
51982 DOUBLE PRECISION XMT,XMT2,XMST(4),XMSB(4)
51983 DOUBLE PRECISION ULR(2),VLR(2),XMQ2,XMQ4,AM,W,SBAR,SMIN,SMAX
51984 DOUBLE PRECISION SUMME(0:100),A(4,8)
51985 DOUBLE PRECISION COS2A,SIN2A,COS2C,SIN2C
51986 DOUBLE PRECISION GRS,XMQ3,XMGBTR,XMGTBR,ANT1,ANT2,ANB1,ANB2
51987 DOUBLE PRECISION XMGLU,GAM
51988 DOUBLE PRECISION XX1(2),XX2(2),AAA(2),BBB(2),CCC(2),
51989 &DDD(2),EEE(2),FFF(2)
51990 SAVE XX1,XX2,AAA,BBB,CCC,DDD,EEE,FFF
51991 DOUBLE PRECISION ALPHAW,ALPHAS
51992 DOUBLE PRECISION AMC(2)
51993 SAVE AMC
51994 DOUBLE PRECISION AMBOT,AMSB(2),SINC,COSC
51995 DOUBLE PRECISION AMTOP,AMST(2),SINA,COSA
51996 SAVE AMSB,AMST
51997 LOGICAL IFIRST
51998 SAVE IFIRST
51999 DATA IFIRST/.TRUE./
52000
52001 TANB=RMSS(5)
52002 SINB=TANB/SQRT(1D0+TANB**2)
52003 COSB=SINB/TANB
52004 XW=PARU(102)
52005 AMW=PMAS(24,1)
52006 COSC=SFMIX(5,1)
52007 SINC=SFMIX(5,3)
52008 COSA=SFMIX(6,1)
52009 SINA=SFMIX(6,3)
52010 AMBOT=PYMRUN(5,XMGLU**2)
52011 AMTOP=PYMRUN(6,XMGLU**2)
52012 W2=SQRT(2D0)
52013 AMW=PMAS(24,1)
52014 FAKT1=AMBOT/W2/AMW/COSB
52015 FAKT2=AMTOP/W2/AMW/SINB
52016 IF(IFIRST) THEN
52017 AMC(1)=SMW(1)
52018 AMC(2)=SMW(2)
52019 DO 100 JJ=1,2
52020 CCC(JJ)=FAKT1*UMIX(JJ,2)*SINC-UMIX(JJ,1)*COSC
52021 EEE(JJ)=FAKT2*VMIX(JJ,2)*COSC
52022 DDD(JJ)=FAKT1*UMIX(JJ,2)*COSC+UMIX(JJ,1)*SINC
52023 FFF(JJ)=FAKT2*VMIX(JJ,2)*SINC
52024 XX1(JJ)=FAKT2*VMIX(JJ,2)*SINA-VMIX(JJ,1)*COSA
52025 AAA(JJ)=FAKT1*UMIX(JJ,2)*COSA
52026 XX2(JJ)=FAKT2*VMIX(JJ,2)*COSA+VMIX(JJ,1)*SINA
52027 BBB(JJ)=FAKT1*UMIX(JJ,2)*SINA
52028 100 CONTINUE
52029 AMST(1)=PMAS(PYCOMP(KSUSY1+6),1)
52030 AMST(2)=PMAS(PYCOMP(KSUSY2+6),1)
52031 AMSB(1)=PMAS(PYCOMP(KSUSY1+5),1)
52032 AMSB(2)=PMAS(PYCOMP(KSUSY2+5),1)
52033 IFIRST=.FALSE.
52034 ENDIF
52035
52036 ULR(1)=XX1(I)*XX1(I)+AAA(I)*AAA(I)
52037 ULR(2)=XX2(I)*XX2(I)+BBB(I)*BBB(I)
52038 VLR(1)=CCC(I)*CCC(I)+EEE(I)*EEE(I)
52039 VLR(2)=DDD(I)*DDD(I)+FFF(I)*FFF(I)
52040
52041 COS2A=COSA**2-SINA**2
52042 SIN2A=SINA*COSA*2D0
52043 COS2C=COSC**2-SINC**2
52044 SIN2C=SINC*COSC*2D0
52045
52046 XMG=XMGLU
52047 XMT=PMAS(6,1)
52048 XMB=PMAS(5,1)
52049 XMR=AMC(I)
52050 XMG2=XMG*XMG
52051 ALPHAW=PYALEM(XMG2)
52052 ALPHAS=PYALPS(XMG2)
52053 XMT2=XMT*XMT
52054 XMB2=XMB*XMB
52055 XMR2=XMR*XMR
52056 XMQ2=XMG2+XMT2+XMB2+XMR2
52057 XMQ4=XMG*XMT*XMB*XMR
52058 XMQ3=XMG2*XMR2+XMT2*XMB2
52059 XMGBTR=(XMG2+XMB2)*(XMT2+XMR2)
52060 XMGTBR=(XMG2+XMT2)*(XMB2+XMR2)
52061
52062 XMST(1)=AMST(1)*AMST(1)
52063 XMST(2)=AMST(1)*AMST(1)
52064 XMST(3)=AMST(2)*AMST(2)
52065 XMST(4)=AMST(2)*AMST(2)
52066 XMSB(1)=AMSB(1)*AMSB(1)
52067 XMSB(2)=AMSB(2)*AMSB(2)
52068 XMSB(3)=AMSB(1)*AMSB(1)
52069 XMSB(4)=AMSB(2)*AMSB(2)
52070
52071 A(1,1)=-COSA*SINC*CCC(I)*AAA(I)-SINA*COSC*EEE(I)*XX1(I)
52072 A(1,2)=XMG*XMB*(COSA*COSC*CCC(I)*AAA(I)+SINA*SINC*EEE(I)*XX1(I))
52073 A(1,3)=-XMG*XMR*(COSA*COSC*CCC(I)*XX1(I)+SINA*SINC*EEE(I)*AAA(I))
52074 A(1,4)=XMB*XMR*(COSA*SINC*CCC(I)*XX1(I)+SINA*COSC*EEE(I)*AAA(I))
52075 A(1,5)=XMG*XMT*(COSA*COSC*EEE(I)*XX1(I)+SINA*SINC*CCC(I)*AAA(I))
52076 A(1,6)=-XMT*XMB*(COSA*SINC*EEE(I)*XX1(I)+SINA*COSC*CCC(I)*AAA(I))
52077 A(1,7)=XMT*XMR*(COSA*SINC*EEE(I)*AAA(I)+SINA*COSC*CCC(I)*XX1(I))
52078 A(1,8)=-XMQ4*(COSA*COSC*EEE(I)*AAA(I)+SINA*SINC*CCC(I)*XX1(I))
52079
52080 A(2,1)=-COSA*COSC*DDD(I)*AAA(I)-SINA*SINC*FFF(I)*XX1(I)
52081 A(2,2)=-XMG*XMB*(COSA*SINC*DDD(I)*AAA(I)+SINA*COSC*FFF(I)*XX1(I))
52082 A(2,3)=XMG*XMR*(COSA*SINC*DDD(I)*XX1(I)+SINA*COSC*FFF(I)*AAA(I))
52083 A(2,4)=XMB*XMR*(COSA*COSC*DDD(I)*XX1(I)+SINA*SINC*FFF(I)*AAA(I))
52084 A(2,5)=XMG*XMT*(COSA*SINC*FFF(I)*XX1(I)+SINA*COSC*DDD(I)*AAA(I))
52085 A(2,6)=XMT*XMB*(COSA*COSC*FFF(I)*XX1(I)+SINA*SINC*DDD(I)*AAA(I))
52086 A(2,7)=-XMT*XMR*(COSA*COSC*FFF(I)*AAA(I)+SINA*SINC*DDD(I)*XX1(I))
52087 A(2,8)=-XMQ4*(COSA*SINC*FFF(I)*AAA(I)+SINA*COSC*DDD(I)*XX1(I))
52088
52089 A(3,1)=-COSA*COSC*EEE(I)*XX2(I)-SINA*SINC*CCC(I)*BBB(I)
52090 A(3,2)=XMG*XMB*(COSA*SINC*EEE(I)*XX2(I)+SINA*COSC*CCC(I)*BBB(I))
52091 A(3,3)=XMG*XMR*(COSA*SINC*EEE(I)*BBB(I)+SINA*COSC*CCC(I)*XX2(I))
52092 A(3,4)=-XMB*XMR*(COSA*COSC*EEE(I)*BBB(I)+SINA*SINC*CCC(I)*XX2(I))
52093 A(3,5)=-XMG*XMT*(COSA*SINC*CCC(I)*BBB(I)+SINA*COSC*EEE(I)*XX2(I))
52094 A(3,6)=XMT*XMB*(COSA*COSC*CCC(I)*BBB(I)+SINA*SINC*EEE(I)*XX2(I))
52095 A(3,7)=XMT*XMR*(COSA*COSC*CCC(I)*XX2(I)+SINA*SINC*EEE(I)*BBB(I))
52096 A(3,8)=-XMQ4*(COSA*SINC*CCC(I)*XX2(I)+SINA*COSC*EEE(I)*BBB(I))
52097
52098 A(4,1)=-COSA*SINC*FFF(I)*XX2(I)-SINA*COSC*DDD(I)*BBB(I)
52099 A(4,2)=-XMG*XMB*(COSA*COSC*FFF(I)*XX2(I)+SINA*SINC*DDD(I)*BBB(I))
52100 A(4,3)=-XMG*XMR*(COSA*COSC*FFF(I)*BBB(I)+SINA*SINC*DDD(I)*XX2(I))
52101 A(4,4)=-XMB*XMR*(COSA*SINC*FFF(I)*BBB(I)+SINA*COSC*DDD(I)*XX2(I))
52102 A(4,5)=-XMG*XMT*(COSA*COSC*DDD(I)*BBB(I)+SINA*SINC*FFF(I)*XX2(I))
52103 A(4,6)=-XMT*XMB*(COSA*SINC*DDD(I)*BBB(I)+SINA*COSC*FFF(I)*XX2(I))
52104 A(4,7)=-XMT*XMR*(COSA*SINC*DDD(I)*XX2(I)+SINA*COSC*FFF(I)*BBB(I))
52105 A(4,8)=-XMQ4*(COSA*COSC*DDD(I)*XX2(I)+SINA*SINC*FFF(I)*BBB(I))
52106
52107 SMAX=(XMG-ABS(XMR))**2
52108 SMIN=(XMB+XMT)**2+0.1D0
52109
52110 DO 120 LIN=0,NN-1
52111 SBAR=SMIN+DBLE(LIN)*(SMAX-SMIN)/DBLE(NN)
52112 AM=(XMG2-XMR2)*(XMT2-XMB2)/2D0/SBAR
52113 GRS=SBAR-XMQ2
52114 W=PYLAMF(SBAR,XMB2,XMT2)*PYLAMF(SBAR,XMG2,XMR2)
52115 W=DSQRT(W)/2D0/SBAR
52116 ANT1=LOG(ABS((GRS/2D0+AM+XMST(1)-W)/(GRS/2D0+AM+XMST(1)+W)))
52117 ANT2=LOG(ABS((GRS/2D0+AM+XMST(3)-W)/(GRS/2D0+AM+XMST(3)+W)))
52118 ANB1=LOG(ABS((GRS/2D0-AM+XMSB(1)-W)/(GRS/2D0-AM+XMSB(1)+W)))
52119 ANB2=LOG(ABS((GRS/2D0-AM+XMSB(2)-W)/(GRS/2D0-AM+XMSB(2)+W)))
52120 SUMME(LIN)=-ULR(1)*W+(ULR(1)*(XMQ2/2D0-XMST(1)-XMG*XMT*SIN2A)
52121 & +2D0*XX1(I)*AAA(I)*XMR*XMB)*ANT1
52122 & +(ULR(1)/2D0*(XMST(1)*(XMQ2-XMST(1))-XMGTBR
52123 & -2D0*XMG*XMT*SIN2A*(XMST(1)-XMB2-XMR2))
52124 & +2D0*XX1(I)*AAA(I)*XMR*XMB*(XMST(1)-XMG2-XMT2)
52125 & +4D0*SIN2A*XX1(I)*AAA(I)*XMQ4)
52126 & *(1D0/(GRS/2D0+AM+XMST(1)-W)-1D0/(GRS/2D0+AM+XMST(1)+W))
52127 SUMME(LIN)=SUMME(LIN)-ULR(2)*W
52128 & +(ULR(2)*(XMQ2/2D0-XMST(3)+XMG*XMT*SIN2A)
52129 & -2D0*XX2(I)*BBB(I)*XMR*XMB)*ANT2
52130 & +(ULR(2)/2D0*(XMST(3)*(XMQ2-XMST(3))-XMGTBR
52131 & +2D0*XMG*XMT*SIN2A*(XMST(3)-XMB2-XMR2))
52132 & -2D0*XX2(I)*BBB(I)*XMR*XMB*(XMST(3)-XMG2-XMT2)
52133 & +4D0*SIN2A*XX2(I)*BBB(I)*XMQ4)
52134 & *(1D0/(GRS/2D0+AM+XMST(3)-W)-1D0/(GRS/2D0+AM+XMST(3)+W))
52135 SUMME(LIN)=SUMME(LIN)-VLR(1)*W
52136 & +(VLR(1)*(XMQ2/2D0-XMSB(1)-XMG*XMB*SIN2C)
52137 & +2D0*CCC(I)*EEE(I)*XMR*XMT)*ANB1
52138 & +(VLR(1)/2D0*(XMSB(1)*(XMQ2-XMSB(1))-XMGBTR
52139 & -2D0*XMG*XMB*SIN2C*(XMSB(1)-XMT2-XMR2))
52140 & +2D0*CCC(I)*EEE(I)*XMR*XMT*(XMSB(1)-XMG2-XMB2)
52141 & +4D0*SIN2C*CCC(I)*EEE(I)*XMQ4)
52142 & *(1D0/(GRS/2D0-AM+XMSB(1)-W)-1D0/(GRS/2D0-AM+XMSB(1)+W))
52143 SUMME(LIN)=SUMME(LIN)-VLR(2)*W
52144 & +(VLR(2)*(XMQ2/2D0-XMSB(2)+XMG*XMB*SIN2C)
52145 & -2D0*DDD(I)*FFF(I)*XMR*XMT)*ANB2
52146 & +(VLR(2)/2D0*(XMSB(2)*(XMQ2-XMSB(2))-XMGBTR
52147 & +2D0*XMG*XMB*SIN2C*(XMSB(2)-XMT2-XMR2))
52148 & -2D0*DDD(I)*FFF(I)*XMR*XMT*(XMSB(2)-XMG2-XMB2)
52149 & +4D0*SIN2C*DDD(I)*FFF(I)*XMQ4)
52150 & *(1D0/(GRS/2D0-AM+XMSB(2)-W)-1D0/(GRS/2D0-AM+XMSB(2)+W))
52151 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMT*COS2A/(XMST(3)-XMST(1))
52152 & *((AAA(I)*BBB(I)-XX1(I)*XX2(I))
52153 & *((XMST(3)-XMB2-XMR2)*ANT2-(XMST(1)-XMB2-XMR2)*ANT1)
52154 & +2D0*(AAA(I)*XX2(I)-XX1(I)*BBB(I))*XMB*XMR*(ANT2-ANT1))
52155 SUMME(LIN)=SUMME(LIN)+2D0*XMG*XMB*COS2C/(XMSB(2)-XMSB(1))
52156 & *((EEE(I)*FFF(I)-CCC(I)*DDD(I))
52157 & *((XMSB(2)-XMT2-XMR2)*ANB2-(XMSB(1)-XMT2-XMR2)*ANB1)
52158 & +2D0*(EEE(I)*DDD(I)-CCC(I)*FFF(I))*XMT*XMR*(ANB2-ANB1))
52159 DO 110 J=1,4
52160 SUMME(LIN)=SUMME(LIN)-2D0*A(J,1)*W
52161 & +((-A(J,1)*(XMSB(J)*(GRS+XMSB(J))+XMQ3)
52162 & +A(J,2)*(XMSB(J)-XMT2-XMR2)+A(J,3)*(SBAR-XMB2-XMT2)
52163 & +A(J,4)*(XMSB(J)+SBAR-XMB2-XMR2)
52164 & -A(J,5)*(XMSB(J)+SBAR-XMG2-XMT2)+A(J,6)*(XMG2+XMR2-SBAR)
52165 & -A(J,7)*(XMSB(J)-XMG2-XMB2)+2D0*A(J,8))
52166 & *LOG(ABS((GRS/2D0+XMSB(J)-AM-W)/(GRS/2D0+XMSB(J)-AM+W)))
52167 & -(A(J,1)*(XMST(J)*(GRS+XMST(J))+XMQ3)
52168 & +A(J,2)*(XMST(J)+SBAR-XMG2-XMB2)-A(J,3)*(SBAR-XMB2-XMT2)
52169 & +A(J,4)*(XMST(J)-XMG2-XMT2)-A(J,5)*(XMST(J)-XMR2-XMB2)
52170 & -A(J,6)*(XMG2+XMR2-SBAR)
52171 & -A(J,7)*(XMST(J)+SBAR-XMT2-XMR2)-2D0*A(J,8))
52172 & *LOG(ABS((GRS/2D0+XMST(J)+AM-W)/(GRS/2D0+XMST(J)+AM+W))))
52173 & /(GRS+XMSB(J)+XMST(J))
52174 110 CONTINUE
52175 120 CONTINUE
52176 SUMME(NN)=0D0
52177 GAM= ALPHAW * ALPHAS * PYSIMP(SUMME,SMIN,SMAX,NN)
52178 &/ (16D0 * PARU(1) * PARU(102) * XMGLU**3)
52179
52180 RETURN
52181 END
52182
52183C*********************************************************************
52184
52185C...PYNJDC
52186C...Calculates decay widths for the neutralinos (admixtures of
52187C...Bino, W3-ino, Higgs1-ino, Higgs2-ino)
52188
52189C...Input: KCIN = KF code for particle
52190C...Output: XLAM = widths
52191C... IDLAM = KF codes for decay particles
52192C... IKNT = number of decay channels defined
52193C...AUTHOR: STEPHEN MRENNA
52194C...Last change:
52195C...10-15-95: force decay chi^0_2 -> chi^0_1 + gamma
52196C...when CHIGAMMA .NE. 0
52197C...10 FEB 96: Calculate this decay for small tan(beta)
52198
52199 SUBROUTINE PYNJDC(KFIN,XLAM,IDLAM,IKNT)
52200
52201C...Double precision and integer declarations.
52202 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
52203 IMPLICIT INTEGER(I-N)
52204 INTEGER PYK,PYCHGE,PYCOMP
52205C...Parameter statement to help give large particle numbers.
52206 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
52207 &KEXCIT=4000000,KDIMEN=5000000)
52208C...Commonblocks.
52209 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
52210 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
52211 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
52212c COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52213c &SFMIX(16,4)
52214 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
52215 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
52216C COMMON/PYINTS/XXM(20)
52217 COMPLEX*16 CXC
52218 COMMON/PYINTC/XXC(10),CXC(8)
52219 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
52220
52221C...Local variables.
52222 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP,GLIJ,GRIJ
52223 COMPLEX*16 QIJ,RIJ,F21K,F12K,CAL,CAR,CBL,CBR,CA,CB
52224 INTEGER KFIN
52225 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
52226 &XMZ,XMZ2,AXMJ,AXMI
52227 DOUBLE PRECISION S12MIN,S12MAX
52228 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2
52229 DOUBLE PRECISION PYLAMF,XL
52230 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I
52231 DOUBLE PRECISION PYX2XH,PYX2XG
52232 DOUBLE PRECISION XLAM(0:400)
52233 INTEGER IDLAM(400,3)
52234 INTEGER LKNT,IX,IH,J,IJ,I,IKNT,FID
52235 INTEGER ITH(3),KF1,KF2
52236 INTEGER ITHC
52237 DOUBLE PRECISION DH(3),EH(3)
52238 DOUBLE PRECISION SR2
52239 DOUBLE PRECISION CBETA,SBETA
52240 DOUBLE PRECISION GAMCON,XMT1,XMT2
52241 DOUBLE PRECISION PYALEM,PI,PYALPS
52242 DOUBLE PRECISION RAT1,RAT2
52243 DOUBLE PRECISION T3T,FCOL
52244 DOUBLE PRECISION ALFA,BETA,TANB
52245 DOUBLE PRECISION PYXXGA
52246 EXTERNAL PYGAUS,PYXXZ6
52247 DOUBLE PRECISION PYGAUS,PYXXZ6
52248 DOUBLE PRECISION PREC
52249 INTEGER KFNCHI(4),KFCCHI(2)
52250 DATA ITH/25,35,36/
52251 DATA ITHC/37/
52252 DATA PREC/1D-2/
52253 DATA PI/3.141592654D0/
52254 DATA SR2/1.4142136D0/
52255 DATA KFNCHI/1000022,1000023,1000025,1000035/
52256 DATA KFCCHI/1000024,1000037/
52257
52258C...COUNT THE NUMBER OF DECAY MODES
52259 LKNT=0
52260
52261 XMW=PMAS(24,1)
52262 XMW2=XMW**2
52263 XMZ=PMAS(23,1)
52264 XMZ2=XMZ**2
52265 XW=1D0-XMW2/XMZ2
52266 XW1=1D0-XW
52267 TANW = SQRT(XW/XW1)
52268
52269C...IX IS 1 - 4 DEPENDING ON SEQUENCE NUMBER
52270 IX=1
52271 IF(KFIN.EQ.KFNCHI(2)) IX=2
52272 IF(KFIN.EQ.KFNCHI(3)) IX=3
52273 IF(KFIN.EQ.KFNCHI(4)) IX=4
52274
52275 XMI=SMZ(IX)
52276 XMI2=XMI**2
52277 AXMI=ABS(XMI)
52278 AEM=PYALEM(XMI2)
52279 AS =PYALPS(XMI2)
52280 C1=AEM/XW
52281 XMI3=ABS(XMI**3)
52282
52283 TANB=RMSS(5)
52284 BETA=ATAN(TANB)
52285 ALFA=RMSS(18)
52286 CBETA=COS(BETA)
52287 SBETA=TANB*CBETA
52288 CALFA=COS(ALFA)
52289 SALFA=SIN(ALFA)
52290
52291 DO 110 I=1,4
52292 DO 100 J=1,4
52293 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
52294 100 CONTINUE
52295 110 CONTINUE
52296 DO 130 I=1,2
52297 DO 120 J=1,2
52298 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
52299 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
52300 120 CONTINUE
52301 130 CONTINUE
52302
52303C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
52304 IF(IX.EQ.1.AND.IMSS(11).EQ.0) GOTO 300
52305
52306C...FORCE CHI0_2 -> CHI0_1 + GAMMA
52307 IF(IX.EQ.2 .AND. IMSS(10).NE.0 ) THEN
52308 XMJ=SMZ(1)
52309 AXMJ=ABS(XMJ)
52310 LKNT=LKNT+1
52311 GAMCON=AEM**3/8D0/PI/XMW2/XW
52312 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
52313 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
52314 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
52315 IDLAM(LKNT,1)=KSUSY1+22
52316 IDLAM(LKNT,2)=22
52317 IDLAM(LKNT,3)=0
52318 WRITE(MSTU(11),*) 'FORCED N2 -> N1 + GAMMA ',XLAM(LKNT)
52319 GOTO 340
52320 ENDIF
52321
52322C...GRAVITINO DECAY MODES
52323
52324 IF(IMSS(11).EQ.1) THEN
52325 XMP=RMSS(29)
52326 IDG=39+KSUSY1
52327 XMGR=PMAS(PYCOMP(IDG),1)
52328 SINW=SQRT(XW)
52329 COSW=SQRT(1D0-XW)
52330 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
52331 IF(AXMI.GT.XMGR+PMAS(22,1)) THEN
52332 LKNT=LKNT+1
52333 IDLAM(LKNT,1)=IDG
52334 IDLAM(LKNT,2)=22
52335 IDLAM(LKNT,3)=0
52336 XLAM(LKNT)=XFAC*ABS(ZMIXC(IX,1)*COSW+ZMIXC(IX,2)*SINW)**2
52337 ENDIF
52338 IF(AXMI.GT.XMGR+XMZ) THEN
52339 LKNT=LKNT+1
52340 IDLAM(LKNT,1)=IDG
52341 IDLAM(LKNT,2)=23
52342 IDLAM(LKNT,3)=0
52343 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,1)*SINW-ZMIXC(IX,2)*COSW)**2 +
52344 $ .5D0*ABS(ZMIXC(IX,3)*CBETA-ZMIXC(IX,4)*SBETA)**2)*
52345 & (1D0-XMZ2/XMI2)**4
52346 ENDIF
52347 IF(AXMI.GT.XMGR+PMAS(25,1)) THEN
52348 LKNT=LKNT+1
52349 IDLAM(LKNT,1)=IDG
52350 IDLAM(LKNT,2)=25
52351 IDLAM(LKNT,3)=0
52352 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SALFA-ZMIXC(IX,4)*CALFA)**2)*
52353 $ .5D0*(1D0-PMAS(25,1)**2/XMI2)**4
52354 ENDIF
52355 IF(AXMI.GT.XMGR+PMAS(35,1)) THEN
52356 LKNT=LKNT+1
52357 IDLAM(LKNT,1)=IDG
52358 IDLAM(LKNT,2)=35
52359 IDLAM(LKNT,3)=0
52360 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*CALFA+ZMIXC(IX,4)*SALFA)**2)*
52361 $ .5D0*(1D0-PMAS(35,1)**2/XMI2)**4
52362 ENDIF
52363 IF(AXMI.GT.XMGR+PMAS(36,1)) THEN
52364 LKNT=LKNT+1
52365 IDLAM(LKNT,1)=IDG
52366 IDLAM(LKNT,2)=36
52367 IDLAM(LKNT,3)=0
52368 XLAM(LKNT)=XFAC*(ABS(ZMIXC(IX,3)*SBETA+ZMIXC(IX,4)*CBETA)**2)*
52369 $ .5D0*(1D0-PMAS(36,1)**2/XMI2)**4
52370 ENDIF
52371 IF(IX.EQ.1) GOTO 300
52372 ENDIF
52373
52374 DO 220 IJ=1,IX-1
52375 XMJ=SMZ(IJ)
52376 AXMJ=ABS(XMJ)
52377 XMJ2=XMJ**2
52378
52379C...CHI0_I -> CHI0_J + GAMMA
52380 IF(AXMI.GE.AXMJ.AND.SBETA/CBETA.LE.2D0) THEN
52381 RAT1=ABS(ZMIXC(IJ,1))**2+ABS(ZMIXC(IJ,2))**2
52382 RAT1=RAT1/( 1D-6+ABS(ZMIXC(IX,3))**2+ABS(ZMIXC(IX,4))**2 )
52383 RAT2=ABS(ZMIXC(IX,1))**2+ABS(ZMIXC(IX,2))**2
52384 RAT2=RAT2/( 1D-6+ABS(ZMIXC(IJ,3))**2+ABS(ZMIXC(IJ,4))**2 )
52385 IF((RAT1.GT. 0.90D0 .AND. RAT1.LT. 1.10D0) .OR.
52386 & (RAT2.GT. 0.90D0 .AND. RAT2.LT. 1.10D0)) THEN
52387 LKNT=LKNT+1
52388 IDLAM(LKNT,1)=KFNCHI(IJ)
52389 IDLAM(LKNT,2)=22
52390 IDLAM(LKNT,3)=0
52391 GAMCON=AEM**3/8D0/PI/XMW2/XW
52392 XMT1=(PMAS(PYCOMP(KSUSY1+6),1)/PMAS(6,1))**2
52393 XMT2=(PMAS(PYCOMP(KSUSY2+6),1)/PMAS(6,1))**2
52394 XLAM(LKNT)=PYXXGA(GAMCON,AXMI,AXMJ,XMT1,XMT2)
52395 ENDIF
52396 ENDIF
52397
52398C...CHI0_I -> CHI0_J + Z0
52399 IF(AXMI.GE.AXMJ+XMZ) THEN
52400 LKNT=LKNT+1
52401 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
52402 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
52403 ORPP=-DCONJG(OLPP)
52404 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52405 GLR=DBLE(OLPP*DCONJG(ORPP))
52406 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
52407 IDLAM(LKNT,1)=KFNCHI(IJ)
52408 IDLAM(LKNT,2)=23
52409 IDLAM(LKNT,3)=0
52410 ELSEIF(AXMI.GE.AXMJ) THEN
52411 XXC(1)=0D0
52412 XXC(2)=XMJ
52413 XXC(3)=0D0
52414 XXC(4)=XMI
52415 XXC(9)=XMZ
52416 XXC(10)=PMAS(23,2)
52417 OLPP=(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,3))-
52418 & ZMIXC(IX,4)*DCONJG(ZMIXC(IJ,4)))/2D0
52419 ORPP=DCONJG(OLPP)
52420C...CHARGED LEPTONS
52421 FID=11
52422 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52423 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52424 EI=KCHG(FID,1)/3D0
52425 T3I=SIGN(1D0,EI+1D-6)/2D0
52426 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52427 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52428 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52429 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52430 CXC(2)=-GLIJ
52431 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52432 CXC(4)=DCONJG(GLIJ)
52433 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52434 CXC(6)=GRIJ
52435 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52436 CXC(8)=-DCONJG(GRIJ)
52437 S12MIN=0D0
52438 S12MAX=(AXMI-AXMJ)**2
52439 IF( XXC(5).LT.AXMI ) THEN
52440 XXC(5)=1D6
52441 ENDIF
52442 IF(XXC(6).LT.AXMI ) THEN
52443 XXC(6)=1D6
52444 ENDIF
52445 XXC(7)=XXC(5)
52446 XXC(8)=XXC(6)
52447
52448 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
52449 LKNT=LKNT+1
52450 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52451 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52452 IDLAM(LKNT,1)=KFNCHI(IJ)
52453 IDLAM(LKNT,2)=FID
52454 IDLAM(LKNT,3)=-FID
52455 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
52456 LKNT=LKNT+1
52457 XLAM(LKNT)=XLAM(LKNT-1)
52458 IDLAM(LKNT,1)=KFNCHI(IJ)
52459 IDLAM(LKNT,2)=13
52460 IDLAM(LKNT,3)=-13
52461 ENDIF
52462 ENDIF
52463 140 CONTINUE
52464 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52465 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
52466 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
52467 ELSE
52468 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
52469 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
52470 ENDIF
52471 IF( XXC(5).LT.AXMI ) THEN
52472 XXC(5)=1D6
52473 ENDIF
52474 IF(XXC(6).LT.AXMI ) THEN
52475 XXC(6)=1D6
52476 ENDIF
52477 XXC(7)=XXC(5)
52478 XXC(8)=XXC(6)
52479
52480 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
52481 LKNT=LKNT+1
52482 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52483 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52484 IDLAM(LKNT,1)=KFNCHI(IJ)
52485 IDLAM(LKNT,2)=15
52486 IDLAM(LKNT,3)=-15
52487 ENDIF
52488
52489C...NEUTRINOS
52490 150 CONTINUE
52491 FID=12
52492 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52493 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52494 EI=KCHG(FID,1)/3D0
52495 T3I=SIGN(1D0,EI+1D-6)/2D0
52496 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52497 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52498 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52499 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52500 CXC(2)=-GLIJ
52501 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52502 CXC(4)=DCONJG(GLIJ)
52503 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52504 CXC(6)=GRIJ
52505 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52506 CXC(8)=-DCONJG(GRIJ)
52507 S12MIN=0D0
52508 S12MAX=(AXMI-AXMJ)**2
52509 IF( XXC(5).LT.AXMI ) THEN
52510 XXC(5)=1D6
52511 ENDIF
52512 IF( XXC(6).LT.AXMI ) THEN
52513 XXC(6)=1D6
52514 ENDIF
52515 XXC(7)=XXC(5)
52516 XXC(8)=XXC(6)
52517
52518 LKNT=LKNT+1
52519 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52520 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52521 IDLAM(LKNT,1)=KFNCHI(IJ)
52522 IDLAM(LKNT,2)=12
52523 IDLAM(LKNT,3)=-12
52524 LKNT=LKNT+1
52525 XLAM(LKNT)=XLAM(LKNT-1)
52526 IDLAM(LKNT,1)=KFNCHI(IJ)
52527 IDLAM(LKNT,2)=14
52528 IDLAM(LKNT,3)=-14
52529 160 CONTINUE
52530
52531 IF(PMAS(PYCOMP(KSUSY1+16),1).NE.PMAS(PYCOMP(KSUSY1+12),1))
52532 & THEN
52533 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
52534 IF( XXC(5).LT.AXMI ) THEN
52535 XXC(5)=1D6
52536 ENDIF
52537 XXC(7)=XXC(5)
52538 LKNT=LKNT+1
52539 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52540 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
52541 ELSE
52542 LKNT=LKNT+1
52543 XLAM(LKNT)=XLAM(LKNT-1)
52544 ENDIF
52545 IDLAM(LKNT,1)=KFNCHI(IJ)
52546 IDLAM(LKNT,2)=16
52547 IDLAM(LKNT,3)=-16
52548C...D-TYPE QUARKS
52549 170 CONTINUE
52550 FID=1
52551 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52552 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52553 EI=KCHG(FID,1)/3D0
52554 T3I=SIGN(1D0,EI+1D-6)/2D0
52555 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52556 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52557 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52558 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52559 CXC(2)=-GLIJ
52560 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52561 CXC(4)=DCONJG(GLIJ)
52562 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52563 CXC(6)=GRIJ
52564 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52565 CXC(8)=-DCONJG(GRIJ)
52566 S12MIN=0D0
52567 S12MAX=(AXMI-AXMJ)**2
52568 IF( XXC(5).LT.AXMI ) THEN
52569 XXC(5)=1D6
52570 ENDIF
52571 IF( XXC(6).LT.AXMI ) THEN
52572 XXC(6)=1D6
52573 ENDIF
52574 XXC(7)=XXC(5)
52575 XXC(8)=XXC(6)
52576
52577 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
52578 LKNT=LKNT+1
52579 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52580 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
52581 IDLAM(LKNT,1)=KFNCHI(IJ)
52582 IDLAM(LKNT,2)=1
52583 IDLAM(LKNT,3)=-1
52584 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
52585 LKNT=LKNT+1
52586 XLAM(LKNT)=XLAM(LKNT-1)
52587 IDLAM(LKNT,1)=KFNCHI(IJ)
52588 IDLAM(LKNT,2)=3
52589 IDLAM(LKNT,3)=-3
52590 ENDIF
52591 ENDIF
52592 180 CONTINUE
52593 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
52594 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
52595 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
52596 ELSE
52597 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
52598 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
52599 ENDIF
52600 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
52601 IF(XXC(5).LT.AXMI) THEN
52602 XXC(5)=1D6
52603 ELSEIF(XXC(6).LT.AXMI) THEN
52604 XXC(6)=1D6
52605 ENDIF
52606 XXC(7)=XXC(5)
52607 XXC(8)=XXC(6)
52608 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
52609 LKNT=LKNT+1
52610 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52611 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
52612 IDLAM(LKNT,1)=KFNCHI(IJ)
52613 IDLAM(LKNT,2)=5
52614 IDLAM(LKNT,3)=-5
52615 ENDIF
52616
52617C...U-TYPE QUARKS
52618 190 CONTINUE
52619 FID=2
52620 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52621 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52622 EI=KCHG(FID,1)/3D0
52623 T3I=SIGN(1D0,EI+1D-6)/2D0
52624 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*
52625 & DCONJG(T3I*ZMIXC(IJ,2)-TANW*(T3I-EI)*ZMIXC(IJ,1))
52626 GRIJ=ZMIXC(IX,1)*DCONJG(ZMIXC(IJ,1))*(EI*TANW)**2
52627 CXC(1)=DCMPLX((T3I-EI*XW)/XW1)*OLPP
52628 CXC(2)=-GLIJ
52629 CXC(3)=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
52630 CXC(4)=DCONJG(GLIJ)
52631 CXC(5)=-DCMPLX((EI*XW)/XW1)*OLPP
52632 CXC(6)=GRIJ
52633 CXC(7)=DCMPLX((EI*XW)/XW1)*ORPP
52634 CXC(8)=-DCONJG(GRIJ)
52635
52636 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 200
52637 IF(XXC(5).LT.AXMI) THEN
52638 XXC(5)=1D6
52639 ELSEIF(XXC(6).LT.AXMI) THEN
52640 XXC(6)=1D6
52641 ENDIF
52642 XXC(7)=XXC(5)
52643 XXC(8)=XXC(6)
52644
52645 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
52646 LKNT=LKNT+1
52647 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52648 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)*3D0
52649 IDLAM(LKNT,1)=KFNCHI(IJ)
52650 IDLAM(LKNT,2)=2
52651 IDLAM(LKNT,3)=-2
52652 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
52653 LKNT=LKNT+1
52654 XLAM(LKNT)=XLAM(LKNT-1)
52655 IDLAM(LKNT,1)=KFNCHI(IJ)
52656 IDLAM(LKNT,2)=4
52657 IDLAM(LKNT,3)=-4
52658 ENDIF
52659 ENDIF
52660 200 CONTINUE
52661 ENDIF
52662
52663C...CHI0_I -> CHI0_J + H0_K
52664 EH(1)=SIN(ALFA)
52665 EH(2)=COS(ALFA)
52666 EH(3)=-SIN(BETA)
52667 DH(1)=COS(ALFA)
52668 DH(2)=-SIN(ALFA)
52669 DH(3)=COS(BETA)
52670 QIJ=ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,2))+
52671 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,2)-
52672 & TANW*(ZMIXC(IX,3)*DCONJG(ZMIXC(IJ,1))+
52673 & DCONJG(ZMIXC(IJ,3))*ZMIXC(IX,1))
52674 RIJ=DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,2)+
52675 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,2))-
52676 & TANW*(DCONJG(ZMIXC(IX,4))*ZMIXC(IJ,1)+
52677 & ZMIXC(IJ,4)*DCONJG(ZMIXC(IX,1)))
52678 DO 210 IH=1,3
52679 XMH=PMAS(ITH(IH),1)
52680 XMH2=XMH**2
52681 IF(AXMI.GE.AXMJ+XMH) THEN
52682 LKNT=LKNT+1
52683 XL=PYLAMF(XMI2,XMJ2,XMH2)
52684 F21K=0.5D0*(QIJ*EH(IH)+RIJ*DH(IH))
52685 F12K=F21K
52686C...SIGN OF MASSES I,J
52687 XMK=XMJ
52688 IF(IH.EQ.3) XMK=-XMK
52689 GX2=ABS(F21K)**2+ABS(F12K)**2
52690 GLR=DBLE(F21K*DCONJG(F12K))
52691 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
52692 IDLAM(LKNT,1)=KFNCHI(IJ)
52693 IDLAM(LKNT,2)=ITH(IH)
52694 IDLAM(LKNT,3)=0
52695 ENDIF
52696 210 CONTINUE
52697 220 CONTINUE
52698
52699C...CHI0_I -> CHI+_J + W-
52700 DO 260 IJ=1,2
52701 XMJ=SMW(IJ)
52702 AXMJ=ABS(XMJ)
52703 XMJ2=XMJ**2
52704 IF(AXMI.GE.AXMJ+XMW) THEN
52705 LKNT=LKNT+1
52706 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
52707 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)/SR2)
52708 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
52709 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))/SR2)
52710 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
52711 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
52712 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
52713 IDLAM(LKNT,1)=KFCCHI(IJ)
52714 IDLAM(LKNT,2)=-24
52715 IDLAM(LKNT,3)=0
52716 LKNT=LKNT+1
52717 XLAM(LKNT)=XLAM(LKNT-1)
52718 IDLAM(LKNT,1)=-KFCCHI(IJ)
52719 IDLAM(LKNT,2)=24
52720 IDLAM(LKNT,3)=0
52721 ELSEIF(AXMI.GE.AXMJ) THEN
52722 S12MIN=0D0
52723 S12MAX=(AXMI-AXMJ)**2
52724 RT2I = 1D0/SQRT(2D0)
52725 CXC(1)=(DCONJG(ZMIXC(IX,2))*VMIXC(IJ,1)-
52726 & DCONJG(ZMIXC(IX,4))*VMIXC(IJ,2)*RT2I)*RT2I
52727 CXC(3)=(ZMIXC(IX,2)*DCONJG(UMIXC(IJ,1))+
52728 & ZMIXC(IX,3)*DCONJG(UMIXC(IJ,2))*RT2I)*RT2I
52729 CXC(5)=DCMPLX(0D0,0D0)
52730 CXC(7)=DCMPLX(0D0,0D0)
52731 IA=11
52732 JA=12
52733 EI=KCHG(IA,1)/3D0
52734 T3I=SIGN(1D0,EI+1D-6)/2D0
52735 EJ=KCHG(JA,1)/3D0
52736 T3J=SIGN(1D0,EJ+1D-6)/2D0
52737 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
52738 & TANW+ZMIXC(IX,2)*T3J)*RT2I
52739 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
52740 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)*RT2I
52741 CXC(6)=DCMPLX(0D0,0D0)
52742 CXC(8)=DCMPLX(0D0,0D0)
52743 XXC(1)=0D0
52744 XXC(2)=XMJ
52745 XXC(3)=0D0
52746 XXC(4)=XMI
52747 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
52748 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
52749 XXC(9)=PMAS(24,1)
52750 XXC(10)=PMAS(24,2)
52751 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 230
52752 IF(XXC(5).LT.AXMI) THEN
52753 XXC(5)=1D6
52754 ELSEIF(XXC(6).LT.AXMI) THEN
52755 XXC(6)=1D6
52756 ENDIF
52757 XXC(7)=XXC(6)
52758 XXC(8)=XXC(5)
52759 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
52760 LKNT=LKNT+1
52761 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52762 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52763 IDLAM(LKNT,1)=KFCCHI(IJ)
52764 IDLAM(LKNT,2)=11
52765 IDLAM(LKNT,3)=-12
52766 LKNT=LKNT+1
52767 XLAM(LKNT)=XLAM(LKNT-1)
52768 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52769 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52770 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52771 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
52772 LKNT=LKNT+1
52773 XLAM(LKNT)=XLAM(LKNT-1)
52774 IDLAM(LKNT,1)=KFCCHI(IJ)
52775 IDLAM(LKNT,2)=13
52776 IDLAM(LKNT,3)=-14
52777 LKNT=LKNT+1
52778 XLAM(LKNT)=XLAM(LKNT-1)
52779 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52780 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52781 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52782 ENDIF
52783 ENDIF
52784 230 CONTINUE
52785 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
52786 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
52787 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
52788 ELSE
52789 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
52790 XXC(6)=PMAS(PYCOMP(KSUSY1+16),1)
52791 ENDIF
52792 IF(XXC(5).LT.AXMI) THEN
52793 XXC(5)=1D6
52794 ENDIF
52795 IF(XXC(6).LT.AXMI) THEN
52796 XXC(6)=1D6
52797 ENDIF
52798 XXC(7)=XXC(6)
52799 XXC(8)=XXC(5)
52800 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
52801 LKNT=LKNT+1
52802 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
52803 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52804 XLAM(LKNT)=XLAM(LKNT-1)
52805 IDLAM(LKNT,1)=KFCCHI(IJ)
52806 IDLAM(LKNT,2)=15
52807 IDLAM(LKNT,3)=-16
52808 LKNT=LKNT+1
52809 XLAM(LKNT)=XLAM(LKNT-1)
52810 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52811 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52812 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52813 ENDIF
52814
52815C...NOW, DO THE QUARKS
52816 240 CONTINUE
52817 IA=1
52818 JA=2
52819 EI=KCHG(IA,1)/3D0
52820 T3I=SIGN(1D0,EI+1D-6)/2D0
52821 EJ=KCHG(JA,1)/3D0
52822 T3J=SIGN(1D0,EJ+1D-6)/2D0
52823 CXC(2)=VMIXC(IJ,1)*DCONJG(ZMIXC(IX,1)*(EJ-T3J)*
52824 & TANW+ZMIXC(IX,2)*T3J)
52825 CXC(4)=-DCONJG(UMIXC(IJ,1))*(
52826 & ZMIXC(IX,1)*(EI-T3I)*TANW+ZMIXC(IX,2)*T3I)
52827 XXC(5)=PMAS(PYCOMP(KSUSY1+IA),1)
52828 XXC(6)=PMAS(PYCOMP(KSUSY1+JA),1)
52829 IF(XXC(5).LT.AXMI) THEN
52830 XXC(5)=1D6
52831 ENDIF
52832 IF(XXC(6).LT.AXMI) THEN
52833 XXC(6)=1D6
52834 ENDIF
52835 XXC(7)=XXC(6)
52836 XXC(8)=XXC(5)
52837 IF(AXMI.GE.AXMJ+PMAS(2,1)+PMAS(1,1)) THEN
52838 LKNT=LKNT+1
52839 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
52840 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
52841 IDLAM(LKNT,1)=KFCCHI(IJ)
52842 IDLAM(LKNT,2)=1
52843 IDLAM(LKNT,3)=-2
52844 LKNT=LKNT+1
52845 XLAM(LKNT)=XLAM(LKNT-1)
52846 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52847 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52848 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52849 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
52850 LKNT=LKNT+1
52851 XLAM(LKNT)=XLAM(LKNT-1)
52852 IDLAM(LKNT,1)=KFCCHI(IJ)
52853 IDLAM(LKNT,2)=3
52854 IDLAM(LKNT,3)=-4
52855 LKNT=LKNT+1
52856 XLAM(LKNT)=XLAM(LKNT-1)
52857 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52858 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52859 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52860 ENDIF
52861 ENDIF
52862 250 CONTINUE
52863 ENDIF
52864 260 CONTINUE
52865 270 CONTINUE
52866
52867C...CHI0_I -> CHI+_I + H-
52868 DO 280 IJ=1,2
52869 XMJ=SMW(IJ)
52870 AXMJ=ABS(XMJ)
52871 XMJ2=XMJ**2
52872 XMHP=PMAS(ITHC,1)
52873 IF(AXMI.GE.AXMJ+XMHP) THEN
52874 LKNT=LKNT+1
52875 OLPP=CBETA*(ZMIXC(IX,4)*DCONJG(VMIXC(IJ,1))+(ZMIXC(IX,2)+
52876 & ZMIXC(IX,1)*TANW)*DCONJG(VMIXC(IJ,2))/SR2)
52877 ORPP=SBETA*(DCONJG(ZMIXC(IX,3))*UMIXC(IJ,1)-
52878 & (DCONJG(ZMIXC(IX,2))+DCONJG(ZMIXC(IX,1))*TANW)*
52879 & UMIXC(IJ,2)/SR2)
52880 GX2=ABS(OLPP)**2+ABS(ORPP)**2
52881 GLR=DBLE(OLPP*DCONJG(ORPP))
52882 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
52883 IDLAM(LKNT,1)=KFCCHI(IJ)
52884 IDLAM(LKNT,2)=-ITHC
52885 IDLAM(LKNT,3)=0
52886 LKNT=LKNT+1
52887 XLAM(LKNT)=XLAM(LKNT-1)
52888 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52889 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52890 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
52891 ELSE
52892
52893 ENDIF
52894 280 CONTINUE
52895
52896C...2-BODY DECAYS TO FERMION SFERMION
52897 DO 290 J=1,16
52898 IF(J.GE.7.AND.J.LE.10) GOTO 290
52899 KF1=KSUSY1+J
52900 KF2=KSUSY2+J
52901 XMSF1=PMAS(PYCOMP(KF1),1)
52902 XMSF2=PMAS(PYCOMP(KF2),1)
52903 XMF=PMAS(J,1)
52904 IF(J.LE.6) THEN
52905 FCOL=3D0
52906 ELSE
52907 FCOL=1D0
52908 ENDIF
52909
52910 EI=KCHG(J,1)/3D0
52911 T3T=SIGN(1D0,EI)
52912 IF(J.EQ.12.OR.J.EQ.14.OR.J.EQ.16) T3T=1D0
52913 IF(MOD(J,2).EQ.0) THEN
52914 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52915 CAL=XMF*ZMIXC(IX,4)/XMW/SBETA
52916 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52917 CBR=CAL
52918 ELSE
52919 CBL=T3T*ZMIXC(IX,2)+TANW*ZMIXC(IX,1)*(2D0*EI-T3T)
52920 CAL=XMF*ZMIXC(IX,3)/XMW/CBETA
52921 CAR=-2D0*EI*TANW*ZMIXC(IX,1)
52922 CBR=CAL
52923 ENDIF
52924
52925C...D~ D_L
52926 IF(AXMI.GE.XMF+XMSF1) THEN
52927 LKNT=LKNT+1
52928 XMA2=XMSF1**2
52929 XMB2=XMF**2
52930 XL=PYLAMF(XMI2,XMA2,XMB2)
52931 CA=CAL*SFMIX(J,1)+CAR*SFMIX(J,2)
52932 CB=CBL*SFMIX(J,1)+CBR*SFMIX(J,2)
52933 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52934 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52935 IDLAM(LKNT,1)=KF1
52936 IDLAM(LKNT,2)=-J
52937 IDLAM(LKNT,3)=0
52938 LKNT=LKNT+1
52939 XLAM(LKNT)=XLAM(LKNT-1)
52940 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52941 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52942 IDLAM(LKNT,3)=0
52943 ENDIF
52944
52945C...D~ D_R
52946 IF(AXMI.GE.XMF+XMSF2) THEN
52947 LKNT=LKNT+1
52948 XMA2=XMSF2**2
52949 XMB2=XMF**2
52950 CA=CAL*SFMIX(J,3)+CAR*SFMIX(J,4)
52951 CB=CBL*SFMIX(J,3)+CBR*SFMIX(J,4)
52952 XL=PYLAMF(XMI2,XMA2,XMB2)
52953 XLAM(LKNT)=0.5D0*FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
52954 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
52955 IDLAM(LKNT,1)=KF2
52956 IDLAM(LKNT,2)=-J
52957 IDLAM(LKNT,3)=0
52958 LKNT=LKNT+1
52959 XLAM(LKNT)=XLAM(LKNT-1)
52960 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
52961 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
52962 IDLAM(LKNT,3)=0
52963 ENDIF
52964 290 CONTINUE
52965 300 CONTINUE
52966C...3-BODY DECAY TO Q Q~ GLUINO
52967 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
52968 IF(AXMI.GE.XMJ) THEN
52969 RT2I = 1D0/SQRT(2D0)
52970 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))*RT2I
52971 ORPP=DCONJG(OLPP)
52972 AXMJ=ABS(XMJ)
52973 XXC(1)=0D0
52974 XXC(2)=XMJ
52975 XXC(3)=0D0
52976 XXC(4)=XMI
52977 FID=1
52978 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
52979 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
52980 XXC(7)=XXC(5)
52981 XXC(8)=XXC(6)
52982 XXC(9)=1D6
52983 XXC(10)=0D0
52984 EI=KCHG(FID,1)/3D0
52985 T3I=SIGN(1D0,EI+1D-6)/2D0
52986 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
52987 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
52988 CXC(1)=0D0
52989 CXC(2)=-GLIJ
52990 CXC(3)=0D0
52991 CXC(4)=DCONJG(GLIJ)
52992 CXC(5)=0D0
52993 CXC(6)=GRIJ
52994 CXC(7)=0D0
52995 CXC(8)=-DCONJG(GRIJ)
52996 S12MIN=0D0
52997 S12MAX=(AXMI-AXMJ)**2
52998CMRENNA.This statement must be here to define S12MAX
52999 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 310
53000C...ALL QUARKS BUT T
53001 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
53002 LKNT=LKNT+1
53003 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
53004 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
53005 IDLAM(LKNT,1)=KSUSY1+21
53006 IDLAM(LKNT,2)=1
53007 IDLAM(LKNT,3)=-1
53008 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
53009 LKNT=LKNT+1
53010 XLAM(LKNT)=XLAM(LKNT-1)
53011 IDLAM(LKNT,1)=KSUSY1+21
53012 IDLAM(LKNT,2)=3
53013 IDLAM(LKNT,3)=-3
53014 ENDIF
53015 ENDIF
53016 310 CONTINUE
53017 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
53018 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
53019 XXC(6)=PMAS(PYCOMP(KSUSY2+5),1)
53020 ELSE
53021 XXC(6)=PMAS(PYCOMP(KSUSY1+5),1)
53022 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
53023 ENDIF
53024 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 320
53025 XXC(7)=XXC(5)
53026 XXC(8)=XXC(6)
53027 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
53028 LKNT=LKNT+1
53029 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
53030 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
53031 IDLAM(LKNT,1)=KSUSY1+21
53032 IDLAM(LKNT,2)=5
53033 IDLAM(LKNT,3)=-5
53034 ENDIF
53035C...U-TYPE QUARKS
53036 320 CONTINUE
53037 FID=2
53038 XXC(5)=PMAS(PYCOMP(KSUSY1+FID),1)
53039 XXC(6)=PMAS(PYCOMP(KSUSY2+FID),1)
53040 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 330
53041 XXC(7)=XXC(5)
53042 XXC(8)=XXC(6)
53043 EI=KCHG(FID,1)/3D0
53044 T3I=SIGN(1D0,EI+1D-6)/2D0
53045 GLIJ=(T3I*ZMIXC(IX,2)-TANW*(T3I-EI)*ZMIXC(IX,1))*OLPP
53046 GRIJ=ZMIXC(IX,1)*(EI*TANW)*ORPP
53047 CXC(2)=-GLIJ
53048 CXC(4)=DCONJG(GLIJ)
53049 CXC(6)=GRIJ
53050 CXC(8)=-DCONJG(GRIJ)
53051 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
53052 LKNT=LKNT+1
53053 XLAM(LKNT)=0.5D0*C1*AS/XMI3/(16D0*PI)*
53054 & PYGAUS(PYXXZ6,S12MIN,S12MAX,1D-3)
53055 IDLAM(LKNT,1)=KSUSY1+21
53056 IDLAM(LKNT,2)=2
53057 IDLAM(LKNT,3)=-2
53058 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
53059 LKNT=LKNT+1
53060 XLAM(LKNT)=XLAM(LKNT-1)
53061 IDLAM(LKNT,1)=KSUSY1+21
53062 IDLAM(LKNT,2)=4
53063 IDLAM(LKNT,3)=-4
53064 ENDIF
53065 ENDIF
53066 330 CONTINUE
53067 ENDIF
53068
53069C...R-violating decay modes (SKANDS).
53070 CALL PYRVNE(KFIN,XLAM,IDLAM,LKNT)
53071
53072 340 IKNT=LKNT
53073 XLAM(0)=0D0
53074 DO 350 I=1,IKNT
53075 IF(XLAM(I).LT.0D0) XLAM(I)=0D0
53076 XLAM(0)=XLAM(0)+XLAM(I)
53077 350 CONTINUE
53078 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
53079
53080 RETURN
53081 END
53082
53083C*********************************************************************
53084
53085C...PYCJDC
53086C...Calculate decay widths for the charginos (admixtures of
53087C...charged Wino and charged Higgsino.
53088
53089C...Input: KCIN = KF code for particle
53090C...Output: XLAM = widths
53091C... IDLAM = KF codes for decay particles
53092C... IKNT = number of decay channels defined
53093C...AUTHOR: STEPHEN MRENNA
53094C...Last change:
53095C...10-16-95: force decay chi^+_1 -> chi^0_1 e+ nu_e
53096C...when CHIENU .NE. 0
53097
53098 SUBROUTINE PYCJDC(KFIN,XLAM,IDLAM,IKNT)
53099
53100C...Double precision and integer declarations.
53101 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53102 IMPLICIT INTEGER(I-N)
53103 INTEGER PYK,PYCHGE,PYCOMP
53104C...Parameter statement to help give large particle numbers.
53105 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53106 &KEXCIT=4000000,KDIMEN=5000000)
53107C...Commonblocks.
53108 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53109 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
53110 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
53111 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
53112 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
53113CC &SFMIX(16,4),
53114C COMMON/PYINTS/XXM(20)
53115 COMPLEX*16 CXC
53116 COMMON/PYINTC/XXC(10),CXC(8)
53117 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYINTC/
53118
53119C...Local variables
53120 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
53121 COMPLEX*16 CAL,CBL,CAR,CBR,CA,CB
53122 INTEGER KFIN,KCIN
53123 DOUBLE PRECISION XMI,XMJ,XMF,XMSF1,XMSF2,XMW,XMW2,
53124 &XMZ,XMZ2,AXMJ,AXMI
53125 DOUBLE PRECISION S12MIN,S12MAX
53126 DOUBLE PRECISION XMI2,XMI3,XMJ2,XMH,XMH2,XMHP,XMA2,XMB2,XMK
53127 DOUBLE PRECISION PYLAMF,XL
53128 DOUBLE PRECISION TANW,XW,AEM,C1,AS,EI,T3I,BETA,ALFA
53129 DOUBLE PRECISION PYX2XH,PYX2XG
53130 DOUBLE PRECISION XLAM(0:400)
53131 INTEGER IDLAM(400,3)
53132 INTEGER LKNT,IX,IH,J,IJ,I,IKNT
53133 INTEGER ITH(3)
53134 INTEGER ITHC
53135 DOUBLE PRECISION ETAH(3),DH(3),EH(3)
53136 DOUBLE PRECISION SR2
53137 DOUBLE PRECISION CBETA,SBETA,TANB
53138
53139 DOUBLE PRECISION PYALEM,PI,PYALPS
53140 DOUBLE PRECISION FCOL
53141 INTEGER KF1,KF2,ISF
53142 INTEGER KFNCHI(4),KFCCHI(2)
53143
53144 DOUBLE PRECISION TEMP
53145 EXTERNAL PYGAUS,PYXXZ6
53146 DOUBLE PRECISION PYGAUS,PYXXZ6
53147 DOUBLE PRECISION PREC
53148 DATA ITH/25,35,36/
53149 DATA ITHC/37/
53150 DATA ETAH/1D0,1D0,-1D0/
53151 DATA SR2/1.4142136D0/
53152 DATA PI/3.141592654D0/
53153 DATA PREC/1D-2/
53154 DATA KFNCHI/1000022,1000023,1000025,1000035/
53155 DATA KFCCHI/1000024,1000037/
53156
53157C...COUNT THE NUMBER OF DECAY MODES
53158 LKNT=0
53159 XMW=PMAS(24,1)
53160 XMW2=XMW**2
53161 XMZ=PMAS(23,1)
53162 XMZ2=XMZ**2
53163 XW=1D0-XMW2/XMZ2
53164 XW1=1D0-XW
53165 TANW = SQRT(XW/XW1)
53166
53167C...1 OR 2 DEPENDING ON CHARGINO TYPE
53168 IX=1
53169 IF(KFIN.EQ.KFCCHI(2)) IX=2
53170 KCIN=PYCOMP(KFIN)
53171
53172 XMI=SMW(IX)
53173 XMI2=XMI**2
53174 AXMI=ABS(XMI)
53175 AEM=PYALEM(XMI2)
53176 AS =PYALPS(XMI2)
53177 C1=AEM/XW
53178 XMI3=ABS(XMI**3)
53179 TANB=RMSS(5)
53180 BETA=ATAN(TANB)
53181 CBETA=COS(BETA)
53182 SBETA=TANB*CBETA
53183 ALFA=RMSS(18)
53184
53185 DO 110 I=1,2
53186 DO 100 J=1,2
53187 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
53188 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
53189 100 CONTINUE
53190 110 CONTINUE
53191
53192C...GRAVITINO DECAY MODES
53193
53194 IF(IMSS(11).EQ.1) THEN
53195 XMP=RMSS(29)
53196 IDG=39+KSUSY1
53197 XMGR=PMAS(PYCOMP(IDG),1)
53198C SINW=SQRT(XW)
53199C COSW=SQRT(1D0-XW)
53200 XFAC=(XMI2/(XMP*XMGR))**2*AXMI/48D0/PI
53201 IF(AXMI.GT.XMGR+XMW) THEN
53202 LKNT=LKNT+1
53203 IDLAM(LKNT,1)=IDG
53204 IDLAM(LKNT,2)=24
53205 IDLAM(LKNT,3)=0
53206 XLAM(LKNT)=XFAC*(
53207 & .5D0*(ABS(VMIXC(IX,1))**2+ABS(UMIXC(IX,1))**2)+
53208 & .5D0*((ABS(VMIXC(IX,2))*SBETA)**2+(ABS(UMIXC(IX,2))*CBETA)**2))*
53209 & (1D0-XMW2/XMI2)**4
53210 ENDIF
53211 IF(AXMI.GT.XMGR+PMAS(37,1)) THEN
53212 LKNT=LKNT+1
53213 IDLAM(LKNT,1)=IDG
53214 IDLAM(LKNT,2)=37
53215 IDLAM(LKNT,3)=0
53216 XLAM(LKNT)=XFAC*(.5D0*((ABS(VMIXC(IX,2))*CBETA)**2+
53217 & (ABS(UMIXC(IX,2))*SBETA)**2))
53218 & *(1D0-PMAS(37,1)**2/XMI2)**4
53219 ENDIF
53220 ENDIF
53221
53222C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
53223 IF(IX.EQ.1) GOTO 170
53224 XMJ=SMW(1)
53225 AXMJ=ABS(XMJ)
53226 XMJ2=XMJ**2
53227
53228C...CHI_2+ -> CHI_1+ + Z0
53229 IF(AXMI.GE.AXMJ+XMZ) THEN
53230 LKNT=LKNT+1
53231 IJ=1
53232 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
53233 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
53234 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
53235 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
53236 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53237 GLR=DBLE(OLPP*DCONJG(ORPP))
53238 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMZ,GX2,GLR)
53239 IDLAM(LKNT,1)=KFCCHI(1)
53240 IDLAM(LKNT,2)=23
53241 IDLAM(LKNT,3)=0
53242
53243C...CHARGED LEPTONS
53244 ELSEIF(AXMI.GE.AXMJ) THEN
53245 S12MIN=0D0
53246 S12MAX=(AXMI-AXMJ)**2
53247 IA=11
53248 JA=12
53249 EI=KCHG(IABS(IA),1)/3D0
53250 T3I=SIGN(1D0,EI+1D-6)/2D0
53251 XXC(1)=0D0
53252 XXC(2)=XMJ
53253 XXC(3)=0D0
53254 XXC(4)=XMI
53255 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53256 XXC(6)=1D6
53257 XXC(9)=PMAS(23,1)
53258 XXC(10)=PMAS(23,2)
53259 IJ=1
53260 OLPP=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))-
53261 & VMIXC(IJ,2)*DCONJG(VMIXC(IX,2))/2D0
53262 ORPP=-UMIXC(IX,1)*DCONJG(UMIXC(IJ,1))-
53263 & UMIXC(IX,2)*DCONJG(UMIXC(IJ,2))/2D0
53264 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53265 CXC(2)=DCMPLX(0D0,0D0)
53266 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53267 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
53268 CXC(5)=-DCMPLX(EI/XW1)*ORPP
53269 CXC(6)=DCMPLX(0D0,0D0)
53270 CXC(7)=-DCMPLX(EI/XW1)*OLPP
53271 CXC(8)=DCMPLX(0D0,0D0)
53272 IF( XXC(5).LT.AXMI ) THEN
53273 XXC(5)=1D6
53274 ENDIF
53275 XXC(7)=XXC(5)
53276 XXC(8)=XXC(6)
53277 IF(AXMI.GE.AXMJ+2D0*PMAS(11,1)) THEN
53278 LKNT=LKNT+1
53279 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
53280 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53281 IDLAM(LKNT,1)=KFCCHI(1)
53282 IDLAM(LKNT,2)=11
53283 IDLAM(LKNT,3)=-11
53284 IF(AXMI.GE.AXMJ+2D0*PMAS(13,1)) THEN
53285 LKNT=LKNT+1
53286 XLAM(LKNT)=XLAM(LKNT-1)
53287 IDLAM(LKNT,1)=KFCCHI(1)
53288 IDLAM(LKNT,2)=13
53289 IDLAM(LKNT,3)=-13
53290 ENDIF
53291 IF(AXMI.GE.AXMJ+2D0*PMAS(15,1)) THEN
53292 LKNT=LKNT+1
53293 XLAM(LKNT)=XLAM(LKNT-1)
53294 IDLAM(LKNT,1)=KFCCHI(1)
53295 IDLAM(LKNT,2)=15
53296 IDLAM(LKNT,3)=-15
53297 ENDIF
53298 ENDIF
53299
53300C...NEUTRINOS
53301 120 CONTINUE
53302 IA=12
53303 JA=11
53304 EI=KCHG(IABS(IA),1)/3D0
53305 T3I=SIGN(1D0,EI+1D-6)/2D0
53306 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53307 XXC(6)=1D6
53308 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53309 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53310 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
53311 CXC(5)=-DCMPLX(EI/XW1)*ORPP
53312 CXC(7)=-DCMPLX(EI/XW1)*OLPP
53313 IF( XXC(5).LT.AXMI ) THEN
53314 XXC(5)=1D6
53315 ENDIF
53316 XXC(7)=XXC(5)
53317 XXC(8)=XXC(6)
53318 IF(AXMI.GE.AXMJ+2D0*PMAS(12,1)) THEN
53319 LKNT=LKNT+1
53320 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
53321 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53322 IDLAM(LKNT,1)=KFCCHI(1)
53323 IDLAM(LKNT,2)=12
53324 IDLAM(LKNT,3)=-12
53325 LKNT=LKNT+1
53326 XLAM(LKNT)=XLAM(LKNT-1)
53327 IDLAM(LKNT,1)=KFCCHI(1)
53328 IDLAM(LKNT,2)=14
53329 IDLAM(LKNT,3)=-14
53330 ENDIF
53331 IF(AXMI.GE.AXMJ+2D0*PMAS(16,1)) THEN
53332 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
53333 XXC(5)=PMAS(PYCOMP(KSUSY1+15),1)
53334 ELSE
53335 XXC(5)=PMAS(PYCOMP(KSUSY2+15),1)
53336 ENDIF
53337 IF( XXC(5).LT.AXMI ) THEN
53338 XXC(5)=1D6
53339 ENDIF
53340 XXC(7)=XXC(5)
53341 LKNT=LKNT+1
53342 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*
53343 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53344 IDLAM(LKNT,1)=KFCCHI(1)
53345 IDLAM(LKNT,2)=16
53346 IDLAM(LKNT,3)=-16
53347 ENDIF
53348
53349C...D-TYPE QUARKS
53350 130 CONTINUE
53351 IA=1
53352 JA=2
53353 EI=KCHG(IABS(IA),1)/3D0
53354 T3I=SIGN(1D0,EI+1D-6)/2D0
53355 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53356 XXC(6)=1D6
53357 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53358 CXC(2)=DCMPLX(0D0,0D0)
53359 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53360 CXC(4)=-VMIXC(IJ,1)*DCONJG(VMIXC(IX,1))*DCMPLX(T3I/XW)
53361 CXC(5)=-DCMPLX(EI/XW1)*ORPP
53362 CXC(6)=DCMPLX(0D0,0D0)
53363 CXC(7)=-DCMPLX(EI/XW1)*OLPP
53364 CXC(8)=DCMPLX(0D0,0D0)
53365 IF( XXC(5).LT.AXMI ) THEN
53366 XXC(5)=1D6
53367 ENDIF
53368 XXC(7)=XXC(5)
53369 XXC(8)=XXC(6)
53370 IF(AXMI.GE.AXMJ+2D0*PMAS(1,1)) THEN
53371 LKNT=LKNT+1
53372 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53373 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53374 IDLAM(LKNT,1)=KFCCHI(1)
53375 IDLAM(LKNT,2)=1
53376 IDLAM(LKNT,3)=-1
53377 IF(AXMI.GE.AXMJ+2D0*PMAS(3,1)) THEN
53378 LKNT=LKNT+1
53379 XLAM(LKNT)=XLAM(LKNT-1)
53380 IDLAM(LKNT,1)=KFCCHI(1)
53381 IDLAM(LKNT,2)=3
53382 IDLAM(LKNT,3)=-3
53383 ENDIF
53384 ENDIF
53385 IF(AXMI.GE.AXMJ+2D0*PMAS(5,1)) THEN
53386 IF(ABS(SFMIX(5,1)).GT.ABS(SFMIX(5,2))) THEN
53387 XXC(5)=PMAS(PYCOMP(KSUSY1+5),1)
53388 ELSE
53389 XXC(5)=PMAS(PYCOMP(KSUSY2+5),1)
53390 ENDIF
53391 IF( XXC(5).LT.AXMI ) THEN
53392 XXC(5)=1D6
53393 ENDIF
53394 XXC(7)=XXC(5)
53395 LKNT=LKNT+1
53396 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53397 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53398 IDLAM(LKNT,1)=KFCCHI(1)
53399 IDLAM(LKNT,2)=5
53400 IDLAM(LKNT,3)=-5
53401 ENDIF
53402
53403C...U-TYPE QUARKS
53404 140 CONTINUE
53405 IA=2
53406 JA=1
53407 EI=KCHG(IABS(IA),1)/3D0
53408 T3I=SIGN(1D0,EI+1D-6)/2D0
53409 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53410 XXC(6)=1D6
53411 CXC(1)=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
53412 CXC(2)=DCMPLX(0D0,0D0)
53413 CXC(3)=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
53414 CXC(4)=-UMIXC(IJ,1)*DCONJG(UMIXC(IX,1))*DCMPLX(T3I/XW)
53415 CXC(5)=-DCMPLX(EI/XW1)*ORPP
53416 CXC(6)=DCMPLX(0D0,0D0)
53417 CXC(7)=-DCMPLX(EI/XW1)*OLPP
53418 CXC(8)=DCMPLX(0D0,0D0)
53419 IF( XXC(5).LT.AXMI ) THEN
53420 XXC(5)=1D6
53421 ENDIF
53422 XXC(7)=XXC(5)
53423 XXC(8)=XXC(6)
53424 IF(AXMI.GE.AXMJ+2D0*PMAS(2,1)) THEN
53425 LKNT=LKNT+1
53426 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53427 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53428 IDLAM(LKNT,1)=KFCCHI(1)
53429 IDLAM(LKNT,2)=2
53430 IDLAM(LKNT,3)=-2
53431 IF(AXMI.GE.AXMJ+2D0*PMAS(4,1)) THEN
53432 LKNT=LKNT+1
53433 XLAM(LKNT)=XLAM(LKNT-1)
53434 IDLAM(LKNT,1)=KFCCHI(1)
53435 IDLAM(LKNT,2)=4
53436 IDLAM(LKNT,3)=-4
53437 ENDIF
53438 ENDIF
53439 150 CONTINUE
53440 ENDIF
53441
53442C...CHI_2+ -> CHI_1+ + H0_K
53443 EH(2)=COS(ALFA)
53444 EH(1)=SIN(ALFA)
53445 EH(3)=-SBETA
53446 DH(2)=-SIN(ALFA)
53447 DH(1)=COS(ALFA)
53448 DH(3)=COS(BETA)
53449 DO 160 IH=1,3
53450 XMH=PMAS(ITH(IH),1)
53451 XMH2=XMH**2
53452C...NO 3-BODY OPTION
53453 IF(AXMI.GE.AXMJ+XMH) THEN
53454 LKNT=LKNT+1
53455 XL=PYLAMF(XMI2,XMJ2,XMH2)
53456 OLPP=(VMIXC(2,1)*DCONJG(UMIXC(1,2))*EH(IH) -
53457 & VMIXC(2,2)*DCONJG(UMIXC(1,1))*DH(IH))/SR2
53458 ORPP=(DCONJG(VMIXC(1,1))*UMIXC(2,2)*EH(IH) -
53459 & DCONJG(VMIXC(1,2))*UMIXC(2,1)*DH(IH))/SR2
53460 XMK=XMJ*ETAH(IH)
53461 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53462 GLR=DBLE(OLPP*DCONJG(ORPP))
53463 XLAM(LKNT)=PYX2XH(C1,XMI,XMK,XMH,GX2,GLR)
53464 IDLAM(LKNT,1)=KFCCHI(1)
53465 IDLAM(LKNT,2)=ITH(IH)
53466 IDLAM(LKNT,3)=0
53467 ENDIF
53468 160 CONTINUE
53469
53470C...CHI1 JUMPS TO HERE
53471 170 CONTINUE
53472
53473C...CHI+_I -> CHI0_J + W+
53474 DO 220 IJ=1,4
53475 XMJ=SMZ(IJ)
53476 AXMJ=ABS(XMJ)
53477 XMJ2=XMJ**2
53478 IF(AXMI.GE.AXMJ+XMW) THEN
53479 LKNT=LKNT+1
53480 DO 180 I=1,4
53481 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
53482 180 CONTINUE
53483 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
53484 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)
53485 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
53486 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)
53487 GX2=ABS(CXC(1))**2+ABS(CXC(3))**2
53488 GLR=DBLE(CXC(1)*DCONJG(CXC(3)))
53489 XLAM(LKNT)=PYX2XG(C1/XMW2,XMI,XMJ,XMW,GX2,GLR)
53490 IDLAM(LKNT,1)=KFNCHI(IJ)
53491 IDLAM(LKNT,2)=24
53492 IDLAM(LKNT,3)=0
53493C...LEPTONS
53494 ELSEIF(AXMI.GE.AXMJ) THEN
53495 S12MIN=0D0
53496 S12MAX=(AXMI-AXMJ)**2
53497 DO 190 I=1,4
53498 ZMIXC(IJ,I)=DCMPLX(ZMIX(IJ,I),ZMIXI(IJ,I))
53499 190 CONTINUE
53500 CXC(1)=(DCONJG(ZMIXC(IJ,2))*VMIXC(IX,1)-
53501 & DCONJG(ZMIXC(IJ,4))*VMIXC(IX,2)/SR2)/SR2
53502 CXC(3)=(ZMIXC(IJ,2)*DCONJG(UMIXC(IX,1))+
53503 & ZMIXC(IJ,3)*DCONJG(UMIXC(IX,2))/SR2)/SR2
53504 CXC(5)=DCMPLX(0D0,0D0)
53505 CXC(7)=DCMPLX(0D0,0D0)
53506 IA=11
53507 JA=12
53508 EI=KCHG(IA,1)/3D0
53509 T3I=SIGN(1D0,EI+1D-6)/2D0
53510 EJ=KCHG(JA,1)/3D0
53511 T3J=SIGN(1D0,EJ+1D-6)/2D0
53512 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
53513 & TANW+ZMIXC(IJ,2)*T3J)/SR2
53514 CXC(4)=-DCONJG(UMIXC(IX,1))*(
53515 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)/SR2
53516 CXC(6)=DCMPLX(0D0,0D0)
53517 CXC(8)=DCMPLX(0D0,0D0)
53518 XXC(1)=0D0
53519 XXC(2)=XMJ
53520 XXC(3)=0D0
53521 XXC(4)=XMI
53522 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53523 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
53524 XXC(9)=PMAS(24,1)
53525 XXC(10)=PMAS(24,2)
53526CCC IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 190
53527 IF(XXC(5).LT.AXMI) THEN
53528 XXC(5)=1D6
53529 ELSEIF(XXC(6).LT.AXMI) THEN
53530 XXC(6)=1D6
53531 ENDIF
53532 XXC(7)=XXC(6)
53533 XXC(8)=XXC(5)
53534C...1/(2PI)**3*/(32*M**3)*G^4, G^2/(4*PI)= AEM/XW,
53535C...--> 1/(16PI)/M**3*(AEM/XW)**2
53536 IF(AXMI.GE.AXMJ+PMAS(11,1)+PMAS(12,1)) THEN
53537 LKNT=LKNT+1
53538 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53539 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
53540 IDLAM(LKNT,1)=KFNCHI(IJ)
53541 IDLAM(LKNT,2)=-11
53542 IDLAM(LKNT,3)=12
53543C...ONLY DECAY CHI+1 -> E+ NU_E
53544 IF( IMSS(12).NE. 0 ) GOTO 260
53545 IF(AXMI.GE.AXMJ+PMAS(13,1)+PMAS(14,1)) THEN
53546 LKNT=LKNT+1
53547 XLAM(LKNT)=XLAM(LKNT-1)
53548 IDLAM(LKNT,1)=KFNCHI(IJ)
53549 IDLAM(LKNT,2)=-13
53550 IDLAM(LKNT,3)=14
53551 ENDIF
53552 ENDIF
53553 IF(AXMI.GE.AXMJ+PMAS(15,1)+PMAS(16,1)) THEN
53554 LKNT=LKNT+1
53555 IF(ABS(SFMIX(15,1)).GT.ABS(SFMIX(15,2))) THEN
53556 XXC(6)=PMAS(PYCOMP(KSUSY1+15),1)
53557 ELSE
53558 XXC(6)=PMAS(PYCOMP(KSUSY2+15),1)
53559 ENDIF
53560 XXC(5)=PMAS(PYCOMP(KSUSY1+16),1)
53561 IF(XXC(5).LT.AXMI) THEN
53562 XXC(5)=1D6
53563 ELSEIF(XXC(6).LT.AXMI) THEN
53564 XXC(6)=1D6
53565 ENDIF
53566 XXC(7)=XXC(6)
53567 XXC(8)=XXC(5)
53568 TEMP=PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53569 XLAM(LKNT)=C1**2/XMI3/(16D0*PI)*TEMP
53570 IDLAM(LKNT,1)=KFNCHI(IJ)
53571 IDLAM(LKNT,2)=-15
53572 IDLAM(LKNT,3)=16
53573 ENDIF
53574
53575C...NOW, DO THE QUARKS
53576 200 CONTINUE
53577 IA=1
53578 JA=2
53579 EI=KCHG(IA,1)/3D0
53580 T3I=SIGN(1D0,EI+1D-6)/2D0
53581 EJ=KCHG(JA,1)/3D0
53582 T3J=SIGN(1D0,EJ+1D-6)/2D0
53583 CXC(2)=VMIXC(IX,1)*DCONJG(ZMIXC(IJ,1)*(EJ-T3J)*
53584 & TANW+ZMIXC(IJ,2)*T3J)
53585 CXC(4)=-DCONJG(UMIXC(IX,1))*(
53586 & ZMIXC(IJ,1)*(EI-T3I)*TANW+ZMIXC(IJ,2)*T3I)
53587 XXC(5)=PMAS(PYCOMP(KSUSY1+JA),1)
53588 XXC(6)=PMAS(PYCOMP(KSUSY1+IA),1)
53589 IF( XXC(5).LT.AXMI .AND. XXC(6).LT.AXMI ) GOTO 210
53590 IF(XXC(5).LT.AXMI) THEN
53591 XXC(5)=1D6
53592 ENDIF
53593 IF(XXC(6).LT.AXMI) THEN
53594 XXC(6)=1D6
53595 ENDIF
53596 XXC(7)=XXC(6)
53597 XXC(8)=XXC(5)
53598 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
53599 LKNT=LKNT+1
53600 XLAM(LKNT)=3D0*C1**2/XMI3/(16D0*PI)*
53601 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53602 IDLAM(LKNT,1)=KFNCHI(IJ)
53603 IDLAM(LKNT,2)=-1
53604 IDLAM(LKNT,3)=2
53605 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
53606 LKNT=LKNT+1
53607 XLAM(LKNT)=XLAM(LKNT-1)
53608 IDLAM(LKNT,1)=KFNCHI(IJ)
53609 IDLAM(LKNT,2)=-3
53610 IDLAM(LKNT,3)=4
53611 ENDIF
53612 ENDIF
53613 210 CONTINUE
53614 ENDIF
53615 220 CONTINUE
53616
53617C...CHI+_I -> CHI0_J + H+
53618 DO 230 IJ=1,4
53619 XMJ=SMZ(IJ)
53620 AXMJ=ABS(XMJ)
53621 XMJ2=XMJ**2
53622 XMHP=PMAS(ITHC,1)
53623 IF(AXMI.GE.AXMJ+XMHP) THEN
53624 LKNT=LKNT+1
53625 OLPP=CBETA*(ZMIXC(IJ,4)*DCONJG(VMIXC(IX,1))+(ZMIXC(IJ,2)+
53626 & ZMIXC(IJ,1)*TANW)*DCONJG(VMIXC(IX,2))/SR2)
53627 ORPP=SBETA*(DCONJG(ZMIXC(IJ,3))*UMIXC(IX,1)-
53628 & (DCONJG(ZMIXC(IJ,2))+DCONJG(ZMIXC(IJ,1))*TANW)*
53629 & UMIXC(IX,2)/SR2)
53630 GX2=ABS(OLPP)**2+ABS(ORPP)**2
53631 GLR=DBLE(OLPP*DCONJG(ORPP))
53632 XLAM(LKNT)=PYX2XH(C1,XMI,XMJ,XMHP,GX2,GLR)
53633 IDLAM(LKNT,1)=KFNCHI(IJ)
53634 IDLAM(LKNT,2)=ITHC
53635 IDLAM(LKNT,3)=0
53636 ELSE
53637
53638 ENDIF
53639 230 CONTINUE
53640
53641C...2-BODY DECAYS TO FERMION SFERMION
53642 DO 240 J=1,16
53643 IF(J.GE.7.AND.J.LE.10) GOTO 240
53644 IF(MOD(J,2).EQ.0) THEN
53645 KF1=KSUSY1+J-1
53646 ELSE
53647 KF1=KSUSY1+J+1
53648 ENDIF
53649 KF2=KF1+KSUSY1
53650 XMSF1=PMAS(PYCOMP(KF1),1)
53651 XMSF2=PMAS(PYCOMP(KF2),1)
53652 XMF=PMAS(J,1)
53653 IF(J.LE.6) THEN
53654 FCOL=3D0
53655 ELSE
53656 FCOL=1D0
53657 ENDIF
53658
53659C...U~ D_L
53660 IF(MOD(J,2).EQ.0) THEN
53661 XMFP=PMAS(J-1,1)
53662 CAL=UMIXC(IX,1)
53663 CBL=-XMF*VMIXC(IX,2)/XMW/SBETA/SR2
53664 CAR=-XMFP*UMIXC(IX,2)/XMW/CBETA/SR2
53665 CBR=0D0
53666 ISF=J-1
53667 ELSE
53668 XMFP=PMAS(J+1,1)
53669 CAL=VMIXC(IX,1)
53670 CBL=-XMF*UMIXC(IX,2)/XMW/CBETA/SR2
53671 CBR=0D0
53672 CAR=-XMFP*VMIXC(IX,2)/XMW/SBETA/SR2
53673 ISF=J+1
53674 ENDIF
53675
53676C...~U_L D
53677 IF(AXMI.GE.XMF+XMSF1) THEN
53678 LKNT=LKNT+1
53679 XMA2=XMSF1**2
53680 XMB2=XMF**2
53681 XL=PYLAMF(XMI2,XMA2,XMB2)
53682 CA=CAL*SFMIX(ISF,1)+CAR*SFMIX(ISF,2)
53683 CB=CBL*SFMIX(ISF,1)+CBR*SFMIX(ISF,2)
53684 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
53685 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
53686 IDLAM(LKNT,3)=0
53687 IF(MOD(J,2).EQ.0) THEN
53688 IDLAM(LKNT,1)=-KF1
53689 IDLAM(LKNT,2)=J
53690 ELSE
53691 IDLAM(LKNT,1)=KF1
53692 IDLAM(LKNT,2)=-J
53693 ENDIF
53694 ENDIF
53695
53696C...U~ D_R
53697 IF(AXMI.GE.XMF+XMSF2) THEN
53698 LKNT=LKNT+1
53699 XMA2=XMSF2**2
53700 XMB2=XMF**2
53701 CA=CAL*SFMIX(ISF,3)+CAR*SFMIX(ISF,4)
53702 CB=CBL*SFMIX(ISF,3)+CBR*SFMIX(ISF,4)
53703 XL=PYLAMF(XMI2,XMA2,XMB2)
53704 XLAM(LKNT)=FCOL*C1/8D0/XMI3*SQRT(XL)*( (XMI2+XMB2-XMA2)*
53705 & (ABS(CA)**2+ABS(CB)**2)+4D0*DBLE(CA*DCONJG(CB))*XMF*XMI)
53706 IDLAM(LKNT,3)=0
53707 IF(MOD(J,2).EQ.0) THEN
53708 IDLAM(LKNT,1)=-KF2
53709 IDLAM(LKNT,2)=J
53710 ELSE
53711 IDLAM(LKNT,1)=KF2
53712 IDLAM(LKNT,2)=-J
53713 ENDIF
53714 ENDIF
53715 240 CONTINUE
53716
53717C...3-BODY DECAY TO Q Q~' GLUINO, ONLY IF IT CANNOT PROCEED THROUGH
53718C...A 2-BODY -- 2-BODY CHAIN
53719 XMJ=PMAS(PYCOMP(KSUSY1+21),1)
53720 IF(AXMI.GE.XMJ) THEN
53721 AXMJ=ABS(XMJ)
53722 S12MIN=0D0
53723 S12MAX=(AXMI-AXMJ)**2
53724 XXC(1)=0D0
53725 XXC(2)=XMJ
53726 XXC(3)=0D0
53727 XXC(4)=XMI
53728 XXC(5)=PMAS(PYCOMP(KSUSY1+1),1)
53729 XXC(6)=PMAS(PYCOMP(KSUSY1+2),1)
53730 XXC(9)=1D6
53731 XXC(10)=0D0
53732 OLPP=DCMPLX(COS(RMSS(32)),SIN(RMSS(32)))
53733 ORPP=DCONJG(OLPP)
53734 CXC(1)=DCMPLX(0D0,0D0)
53735 CXC(3)=DCMPLX(0D0,0D0)
53736 CXC(5)=DCMPLX(0D0,0D0)
53737 CXC(7)=DCMPLX(0D0,0D0)
53738 CXC(2)=UMIXC(IX,1)*OLPP/SR2
53739 CXC(4)=-DCONJG(VMIXC(IX,1))*ORPP/SR2
53740 CXC(6)=DCMPLX(0D0,0D0)
53741 CXC(8)=DCMPLX(0D0,0D0)
53742 IF(XXC(5).LT.AXMI) THEN
53743 XXC(5)=1D6
53744 ELSEIF(XXC(6).LT.AXMI) THEN
53745 XXC(6)=1D6
53746 ENDIF
53747 XXC(7)=XXC(6)
53748 XXC(8)=XXC(5)
53749 IF( XXC(5).LT.AXMI .OR. XXC(6).LT.AXMI ) GOTO 250
53750 IF(AXMI.GE.AXMJ+PMAS(1,1)+PMAS(2,1)) THEN
53751 LKNT=LKNT+1
53752 XLAM(LKNT)=4D0*C1*AS/XMI3/(16D0*PI)*
53753 & PYGAUS(PYXXZ6,S12MIN,S12MAX,PREC)
53754 IDLAM(LKNT,1)=KSUSY1+21
53755 IDLAM(LKNT,2)=-1
53756 IDLAM(LKNT,3)=2
53757 IF(AXMI.GE.AXMJ+PMAS(3,1)+PMAS(4,1)) THEN
53758 LKNT=LKNT+1
53759 XLAM(LKNT)=XLAM(LKNT-1)
53760 IDLAM(LKNT,1)=KSUSY1+21
53761 IDLAM(LKNT,2)=-3
53762 IDLAM(LKNT,3)=4
53763 ENDIF
53764 ENDIF
53765 250 CONTINUE
53766 ENDIF
53767
53768C...R-violating decay modes (SKANDS).
53769 CALL PYRVCH(KFIN,XLAM,IDLAM,LKNT)
53770
53771 260 IKNT=LKNT
53772 XLAM(0)=0D0
53773 DO 270 I=1,IKNT
53774 XLAM(0)=XLAM(0)+XLAM(I)
53775 IF(XLAM(I).LT.0D0) THEN
53776 WRITE(MSTU(11),*) ' XLAM(I) = ',XLAM(I),KCIN,
53777 & (IDLAM(I,J),J=1,3)
53778 XLAM(I)=0D0
53779 ENDIF
53780 270 CONTINUE
53781 IF(XLAM(0).EQ.0D0) THEN
53782 XLAM(0)=1D-6
53783 WRITE(MSTU(11),*) ' XLAM(0) = ',XLAM(0)
53784 WRITE(MSTU(11),*) LKNT
53785 WRITE(MSTU(11),*) (XLAM(J),J=1,LKNT)
53786 ENDIF
53787
53788 RETURN
53789 END
53790
53791C*********************************************************************
53792
53793C...PYXXZ6
53794C...Used in the calculation of inoi -> inoj + f + ~f.
53795
53796 FUNCTION PYXXZ6(X)
53797
53798C...Double precision and integer declarations.
53799 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53800 IMPLICIT INTEGER(I-N)
53801 INTEGER PYK,PYCHGE,PYCOMP
53802C...Parameter statement to help give large particle numbers.
53803 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
53804 &KEXCIT=4000000,KDIMEN=5000000)
53805C...Commonblocks.
53806 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
53807C COMMON/PYINTS/XXM(20)
53808 COMPLEX*16 CXC
53809 COMMON/PYINTC/XXC(10),CXC(8)
53810 SAVE /PYDAT1/,/PYINTC/
53811
53812C...Local variables.
53813 COMPLEX*16 QLLS,QRRS,QRLS,QLRS,QLLU,QRRU,QLRT,QRLT
53814 DOUBLE PRECISION PYXXZ6,X
53815 DOUBLE PRECISION XM12,XM22,XM32,S,S13,WPROP2
53816 DOUBLE PRECISION WW,WF1,WF2,WFL1,WFL2
53817 DOUBLE PRECISION SIJ
53818 DOUBLE PRECISION XMV,XMG,XMSU1,XMSU2,XMSD1,XMSD2
53819 DOUBLE PRECISION OL2
53820 DOUBLE PRECISION S23MIN,S23MAX,S23AVE,S23DEL
53821 INTEGER I
53822
53823C...Statement functions.
53824C...Integral from x to y of (t-a)(b-t) dt.
53825 TINT(X,Y,A,B)=(X-Y)*(-(X**2+X*Y+Y**2)/3D0+(B+A)*(X+Y)/2D0-A*B)
53826C...Integral from x to y of (t-a)(b-t)/(t-c) dt.
53827 TINT2(X,Y,A,B,C)=(X-Y)*(-0.5D0*(X+Y)+(B+A-C))-
53828 &LOG(ABS((X-C)/(Y-C)))*(C-B)*(C-A)
53829C...Integral from x to y of (t-a)(b-t)/(t-c)**2 dt.
53830 TINT3(X,Y,A,B,C)=-(X-Y)+(C-A)*(C-B)*(Y-X)/(X-C)/(Y-C)+
53831 &(B+A-2D0*C)*LOG(ABS((X-C)/(Y-C)))
53832C...Integral from x to y of (t-a)/(b-t) dt.
53833 UTINT(X,Y,A,B)=LOG(ABS((X-A)/(B-X)*(B-Y)/(Y-A)))/(B-A)
53834C...Integral from x to y of 1/(t-a) dt.
53835 TPROP(X,Y,A)=LOG(ABS((X-A)/(Y-A)))
53836
53837 XM12=XXC(1)**2
53838 XM22=XXC(2)**2
53839 XM32=XXC(3)**2
53840 S=XXC(4)**2
53841 S13=X
53842
53843 S23AVE=XM22+XM32-0.5D0/X*(X+XM32-XM12)*(X+XM22-S)
53844 S23DEL=0.5D0/X*SQRT( ( (X-XM12-XM32)**2-4D0*XM12*XM32)*
53845 &( (X-XM22-S)**2 -4D0*XM22*S ) )
53846
53847 S23MIN=(S23AVE-S23DEL)
53848 S23MAX=(S23AVE+S23DEL)
53849
53850 XMSD1=XXC(5)**2
53851 XMSD2=XXC(7)**2
53852 XMSU1=XXC(6)**2
53853 XMSU2=XXC(8)**2
53854
53855 XMV=XXC(9)
53856 XMG=XXC(10)
53857 QLLS=CXC(1)
53858 QLLU=CXC(2)
53859 QLRS=CXC(3)
53860 QLRT=CXC(4)
53861 QRLS=CXC(5)
53862 QRLT=CXC(6)
53863 QRRS=CXC(7)
53864 QRRU=CXC(8)
53865 WPROP2=(S13-XMV**2)**2+(XMV*XMG)**2
53866 SIJ=2D0*XXC(2)*XXC(4)*S13
53867 IF(XMV.LE.1000D0) THEN
53868 OL2=ABS(QLLS)**2+ABS(QRRS)**2+ABS(QLRS)**2+ABS(QRLS)**2
53869 OLR=-2D0*DBLE(QLRS*DCONJG(QLLS)+QRLS*DCONJG(QRRS))
53870 WW=(OL2*2D0*TINT(S23MAX,S23MIN,XM22,S)
53871 & +OLR*SIJ*(S23MAX-S23MIN))/WPROP2
53872 IF(XXC(5).LE.10000D0) THEN
53873 WFL1=4D0*(DBLE(QLLS*DCONJG(QLLU))*
53874 & TINT2(S23MAX,S23MIN,XM22,S,XMSD1)-
53875 & .5D0*DBLE(QLLS*DCONJG(QLRT))*SIJ*TPROP(S23MAX,S23MIN,XMSD2)+
53876 & DBLE(QLRS*DCONJG(QLRT))*TINT2(S23MAX,S23MIN,XM22,S,XMSD2)-
53877 & .5D0*DBLE(QLRS*DCONJG(QLLU))*SIJ*TPROP(S23MAX,S23MIN,XMSD1))
53878 & *(S13-XMV**2)/WPROP2
53879 ELSE
53880 WFL1=0D0
53881 ENDIF
53882
53883 IF(XXC(6).LE.10000D0) THEN
53884 WFL2=4D0*(DBLE(QRRS*DCONJG(QRRU))*
53885 & TINT2(S23MAX,S23MIN,XM22,S,XMSU1)-
53886 & .5D0*DBLE(QRRS*DCONJG(QRLT))*SIJ*TPROP(S23MAX,S23MIN,XMSU2)+
53887 & DBLE(QRLS*DCONJG(QRLT))*TINT2(S23MAX,S23MIN,XM22,S,XMSU2)-
53888 & .5D0*DBLE(QRLS*DCONJG(QRRU))*SIJ*TPROP(S23MAX,S23MIN,XMSU1))
53889 & *(S13-XMV**2)/WPROP2
53890 ELSE
53891 WFL2=0D0
53892 ENDIF
53893 ELSE
53894 WW=0D0
53895 WFL1=0D0
53896 WFL2=0D0
53897 ENDIF
53898 IF(XXC(5).LE.10000D0) THEN
53899 WF1=2D0*ABS(QLLU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD1)
53900 & +2D0*ABS(QLRT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSD2)
53901 & - 2D0*DBLE(QLRT*DCONJG(QLLU))*
53902 & SIJ*UTINT(S23MAX,S23MIN,XMSD1,XM22+S-S13-XMSD2)
53903 ELSE
53904 WF1=0D0
53905 ENDIF
53906 IF(XXC(6).LE.10000D0) THEN
53907 WF2=2D0*ABS(QRRU)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU1)
53908 & +2D0*ABS(QRLT)**2*TINT3(S23MAX,S23MIN,XM22,S,XMSU2)
53909 & - 2D0*DBLE(QRLT*DCONJG(QRRU))*
53910 & SIJ*UTINT(S23MAX,S23MIN,XMSU1,XM22+S-S13-XMSU2)
53911 ELSE
53912 WF2=0D0
53913 ENDIF
53914
53915 PYXXZ6=(WW+WF1+WF2+WFL1+WFL2)
53916
53917 IF(PYXXZ6.LT.0D0) THEN
53918 WRITE(MSTU(11),*) ' NEGATIVE WT IN PYXXZ6 '
53919 WRITE(MSTU(11),*) (XXC(I),I=1,5)
53920 WRITE(MSTU(11),*) (XXC(I),I=6,10)
53921 WRITE(MSTU(11),*) WW,WF1,WF2,WFL1,WFL2
53922 WRITE(MSTU(11),*) S23MIN,S23MAX
53923 PYXXZ6=0D0
53924 ENDIF
53925
53926 RETURN
53927 END
53928
53929
53930C*********************************************************************
53931
53932C...PYXXGA
53933C...Calculates chi0_i -> chi0_j + gamma.
53934
53935 FUNCTION PYXXGA(C0,XM1,XM2,XMTR,XMTL)
53936
53937C...Double precision and integer declarations.
53938 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53939 IMPLICIT INTEGER(I-N)
53940 INTEGER PYK,PYCHGE,PYCOMP
53941
53942C...Local variables.
53943 DOUBLE PRECISION PYXXGA,C0,XM1,XM2,XMTR,XMTL
53944 DOUBLE PRECISION F1,F2
53945
53946 F1=(1D0+XMTR/(1D0-XMTR)*LOG(XMTR))/(1D0-XMTR)
53947 F2=(1D0+XMTL/(1D0-XMTL)*LOG(XMTL))/(1D0-XMTL)
53948 PYXXGA=C0*((XM1**2-XM2**2)/XM1)**3
53949 PYXXGA=PYXXGA*(2D0/3D0*(F1+F2)-13D0/12D0)**2
53950
53951 RETURN
53952 END
53953
53954C*********************************************************************
53955
53956C...PYX2XG
53957C...Calculates the decay rate for ino -> ino + gauge boson.
53958
53959 FUNCTION PYX2XG(C1,XM1,XM2,XM3,GX2,GLR)
53960
53961C...Double precision and integer declarations.
53962 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53963 IMPLICIT INTEGER(I-N)
53964 INTEGER PYK,PYCHGE,PYCOMP
53965
53966C...Local variables.
53967 DOUBLE PRECISION PYX2XG,XM1,XM2,XM3,GX2,GLR
53968 DOUBLE PRECISION XL,PYLAMF,C1
53969 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53970
53971 XMI2=XM1**2
53972 XMI3=ABS(XM1**3)
53973 XMJ2=XM2**2
53974 XMV2=XM3**2
53975 XL=PYLAMF(XMI2,XMJ2,XMV2)
53976 PYX2XG=C1/8D0/XMI3*SQRT(XL)
53977 &*(GX2*(XL+3D0*XMV2*(XMI2+XMJ2-XMV2))-
53978 &12D0*GLR*XM1*XM2*XMV2)
53979
53980 RETURN
53981 END
53982
53983C*********************************************************************
53984
53985C...PYX2XH
53986C...Calculates the decay rate for ino -> ino + H.
53987
53988 FUNCTION PYX2XH(C1,XM1,XM2,XM3,GX2,GLR)
53989
53990C...Double precision and integer declarations.
53991 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
53992 IMPLICIT INTEGER(I-N)
53993 INTEGER PYK,PYCHGE,PYCOMP
53994
53995C...Local variables.
53996 DOUBLE PRECISION PYX2XH,XM1,XM2,XM3
53997 DOUBLE PRECISION XL,PYLAMF,C1
53998 DOUBLE PRECISION XMI2,XMJ2,XMV2,XMI3
53999
54000 XMI2=XM1**2
54001 XMI3=ABS(XM1**3)
54002 XMJ2=XM2**2
54003 XMV2=XM3**2
54004 XL=PYLAMF(XMI2,XMJ2,XMV2)
54005 PYX2XH=C1/8D0/XMI3*SQRT(XL)
54006 &*(GX2*(XMI2+XMJ2-XMV2)+
54007 &4D0*GLR*XM1*XM2)
54008
54009 RETURN
54010 END
54011
54012C*********************************************************************
54013
54014C...PYHEXT
54015C...Calculates the non-standard decay modes of the Higgs boson.
54016C...
54017C...Author: Stephen Mrenna
54018C...Last Update: April 2001
54019C......Allow complex values for Z,U, and V
54020
54021 SUBROUTINE PYHEXT(KFIN,XLAM,IDLAM,IKNT)
54022
54023C...Double precision and integer declarations.
54024 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54025 IMPLICIT INTEGER(I-N)
54026 INTEGER PYK,PYCHGE,PYCOMP
54027C...Parameter statement to help give large particle numbers.
54028 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54029 &KEXCIT=4000000,KDIMEN=5000000)
54030C...Commonblocks.
54031 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54032 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54033 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54034 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
54035 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54036 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54037 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYMSSM/,/PYSSMT/
54038
54039C...Local variables.
54040 COMPLEX*16 ZMIXC(4,4),VMIXC(2,2),UMIXC(2,2),OLPP,ORPP
54041 COMPLEX*16 QIJ,RIJ,F21K,F12K
54042 INTEGER KFIN
54043 DOUBLE PRECISION XMI,XMJ,XMF,XMW,XMW2,XMZ,AXMJ,AXMI
54044 DOUBLE PRECISION XMI2,XMI3,XMJ2
54045 DOUBLE PRECISION PYLAMF,XL,CF,EI
54046 INTEGER IDU,IFL
54047 DOUBLE PRECISION TANW,XW,AEM,C1,AS
54048 DOUBLE PRECISION PYH2XX,GHLL,GHRR,GHLR
54049 DOUBLE PRECISION XLAM(0:400)
54050 INTEGER IDLAM(400,3)
54051 INTEGER LKNT,IH,J,IJ,I,IKNT,IK
54052 INTEGER ITH(4)
54053 INTEGER KFNCHI(4),KFCCHI(2)
54054 DOUBLE PRECISION ETAH(3),CH(3),DH(3),EH(3)
54055 DOUBLE PRECISION SR2
54056 DOUBLE PRECISION BETA,ALFA
54057 DOUBLE PRECISION CBETA,SBETA,GR,GL,TANB
54058 DOUBLE PRECISION PYALEM
54059 DOUBLE PRECISION AL,AR,ALR
54060 DOUBLE PRECISION XMK,AXMK,COSA,SINA,CW,XML
54061 DOUBLE PRECISION XMUZ,ATRIT,ATRIB,ATRIL
54062 DOUBLE PRECISION XMJL,XMJR,XM1,XM2
54063 DATA ITH/25,35,36,37/
54064 DATA ETAH/1D0,1D0,-1D0/
54065 DATA SR2/1.4142136D0/
54066 DATA KFNCHI/1000022,1000023,1000025,1000035/
54067 DATA KFCCHI/1000024,1000037/
54068
54069C...COUNT THE NUMBER OF DECAY MODES
54070 LKNT=IKNT
54071
54072 XMW=PMAS(24,1)
54073 XMW2=XMW**2
54074 XMZ=PMAS(23,1)
54075 XW=PARU(102)
54076 TANW = SQRT(XW/(1D0-XW))
54077 CW=SQRT(1D0-XW)
54078
54079C...1 - 4 DEPENDING ON Higgs species.
54080 IH=1
54081 IF(KFIN.EQ.ITH(2)) IH=2
54082 IF(KFIN.EQ.ITH(3)) IH=3
54083 IF(KFIN.EQ.ITH(4)) IH=4
54084
54085 XMI=PMAS(KFIN,1)
54086 XMI2=XMI**2
54087 AXMI=ABS(XMI)
54088 AEM=PYALEM(XMI2)
54089 C1=AEM/XW
54090 XMI3=ABS(XMI**3)
54091
54092 TANB=RMSS(5)
54093 BETA=ATAN(TANB)
54094 CBETA=COS(BETA)
54095 SBETA=TANB*CBETA
54096 ALFA=RMSS(18)
54097 COSA=COS(ALFA)
54098 SINA=SIN(ALFA)
54099 ATRIT=RMSS(16)
54100 ATRIB=RMSS(15)
54101 ATRIL=RMSS(17)
54102 XMUZ=-RMSS(4)
54103
54104 DO 110 I=1,4
54105 DO 100 J=1,4
54106 ZMIXC(J,I)=DCMPLX(ZMIX(J,I),ZMIXI(J,I))
54107 100 CONTINUE
54108 110 CONTINUE
54109 DO 130 I=1,2
54110 DO 120 J=1,2
54111 VMIXC(J,I)=DCMPLX(VMIX(J,I),VMIXI(J,I))
54112 UMIXC(J,I)=DCMPLX(UMIX(J,I),UMIXI(J,I))
54113 120 CONTINUE
54114 130 CONTINUE
54115
54116
54117 IF(IH.EQ.4) GOTO 220
54118
54119C...CHECK ALL 2-BODY DECAYS TO GAUGE AND HIGGS BOSONS
54120C...H0_K -> CHI0_I + CHI0_J
54121 EH(2)=SINA
54122 EH(1)=COSA
54123 EH(3)=CBETA
54124 DH(2)=COSA
54125 DH(1)=-SINA
54126 DH(3)=SBETA
54127 DO 150 IJ=1,4
54128 XMJ=SMZ(IJ)
54129 AXMJ=ABS(XMJ)
54130 DO 140 IK=1,IJ
54131 XMK=SMZ(IK)
54132 AXMK=ABS(XMK)
54133 IF(AXMI.GE.AXMJ+AXMK) THEN
54134 LKNT=LKNT+1
54135 QIJ=ZMIXC(IK,3)*ZMIXC(IJ,2)+
54136 & ZMIXC(IJ,3)*ZMIXC(IK,2)-
54137 & TANW*(ZMIXC(IK,3)*ZMIXC(IJ,1)+
54138 & ZMIXC(IJ,3)*ZMIXC(IK,1))
54139 RIJ=ZMIXC(IK,4)*ZMIXC(IJ,2)+
54140 & ZMIXC(IJ,4)*ZMIXC(IK,2)-
54141 & TANW*(ZMIXC(IK,4)*ZMIXC(IJ,1)+
54142 & ZMIXC(IJ,4)*ZMIXC(IK,1))
54143 F21K=0.5D0*DCONJG(QIJ*DH(IH)-RIJ*EH(IH))
54144 F12K=0.5D0*(QIJ*DH(IH)-RIJ*EH(IH))
54145C...SIGN OF MASSES I,J
54146 XML=XMK*ETAH(IH)
54147 GX2=ABS(F12K)**2+ABS(F21K)**2
54148 GLR=DBLE(F12K*DCONJG(F21K))
54149 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
54150 IF(IJ.EQ.IK) XLAM(LKNT)=XLAM(LKNT)*0.5D0
54151 IDLAM(LKNT,1)=KFNCHI(IJ)
54152 IDLAM(LKNT,2)=KFNCHI(IK)
54153 IDLAM(LKNT,3)=0
54154 ENDIF
54155 140 CONTINUE
54156 150 CONTINUE
54157
54158C...H0_K -> CHI+_I CHI-_J
54159 DO 170 IJ=1,2
54160 XMJ=SMW(IJ)
54161 AXMJ=ABS(XMJ)
54162 DO 160 IK=1,2
54163 XMK=SMW(IK)
54164 AXMK=ABS(XMK)
54165 IF(AXMI.GE.AXMJ+AXMK) THEN
54166 LKNT=LKNT+1
54167 OLPP=DCONJG(VMIXC(IJ,1)*UMIXC(IK,2)*DH(IH) +
54168 & VMIXC(IJ,2)*UMIXC(IK,1)*EH(IH))/SR2
54169 ORPP=(VMIXC(IK,1)*UMIXC(IJ,2)*DH(IH) +
54170 & VMIXC(IK,2)*UMIXC(IJ,1)*EH(IH))/SR2
54171 GX2=ABS(OLPP)**2+ABS(ORPP)**2
54172 GLR=DBLE(OLPP*DCONJG(ORPP))
54173 XML=XMK*ETAH(IH)
54174 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,XML,GX2,GLR)
54175 IDLAM(LKNT,1)=KFCCHI(IJ)
54176 IDLAM(LKNT,2)=-KFCCHI(IK)
54177 IDLAM(LKNT,3)=0
54178 ENDIF
54179 160 CONTINUE
54180 170 CONTINUE
54181
54182C...HIGGS TO SFERMION SFERMION
54183 DO 200 IFL=1,16
54184 IF(IFL.GE.7.AND.IFL.LE.10) GOTO 200
54185 IJ=KSUSY1+IFL
54186 XMJL=PMAS(PYCOMP(IJ),1)
54187 XMJR=PMAS(PYCOMP(IJ+KSUSY1),1)
54188 IF(AXMI.GE.2D0*MIN(XMJL,XMJR)) THEN
54189 XMJ=XMJL
54190 XMJ2=XMJ**2
54191 XL=PYLAMF(XMI2,XMJ2,XMJ2)
54192 XMF=PMAS(IFL,1)
54193 EI=KCHG(IFL,1)/3D0
54194 IDU=2-MOD(IFL,2)
54195
54196 IF(IH.EQ.1) THEN
54197 IF(IDU.EQ.1) THEN
54198 GHLL=-XMZ/CW*(0.5D0+EI*XW)*SIN(ALFA+BETA)+
54199 & XMF**2/XMW*SINA/CBETA
54200 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)+
54201 & XMF**2/XMW*SINA/CBETA
54202 IF(IFL.EQ.5) THEN
54203 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
54204 & ATRIB*SINA)
54205 ELSEIF(IFL.EQ.15) THEN
54206 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*COSA-
54207 & ATRIL*SINA)
54208 ELSE
54209 GHLR=0D0
54210 ENDIF
54211 ELSE
54212 GHLL=XMZ/CW*(0.5D0-EI*XW)*SIN(ALFA+BETA)-
54213 & XMF**2/XMW*COSA/SBETA
54214 GHRR=XMZ/CW*(EI*XW)*SIN(ALFA+BETA)-
54215 & XMF**2/XMW*COSA/SBETA
54216 IF(IFL.EQ.6) THEN
54217 GHLR=XMF/2D0/XMW/SBETA*(XMUZ*SINA-
54218 & ATRIT*COSA)
54219 ELSE
54220 GHLR=0D0
54221 ENDIF
54222 ENDIF
54223
54224 ELSEIF(IH.EQ.2) THEN
54225 IF(IDU.EQ.1) THEN
54226 GHLL=XMZ/CW*(0.5D0+EI*XW)*COS(ALFA+BETA)-
54227 & XMF**2/XMW*COSA/CBETA
54228 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
54229 & XMF**2/XMW*COSA/CBETA
54230 IF(IFL.EQ.5) THEN
54231 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
54232 & ATRIB*COSA)
54233 ELSEIF(IFL.EQ.15) THEN
54234 GHLR=-XMF/2D0/XMW/CBETA*(XMUZ*SINA+
54235 & ATRIL*COSA)
54236 ELSE
54237 GHLR=0D0
54238 ENDIF
54239 ELSE
54240 GHLL=-XMZ/CW*(0.5D0-EI*XW)*COS(ALFA+BETA)-
54241 & XMF**2/XMW*SINA/SBETA
54242 GHRR=-XMZ/CW*(EI*XW)*COS(ALFA+BETA)-
54243 & XMF**2/XMW*SINA/SBETA
54244 IF(IFL.EQ.6) THEN
54245 GHLR=-XMF/2D0/XMW/SBETA*(XMUZ*COSA+
54246 & ATRIT*SINA)
54247 ELSE
54248 GHLR=0D0
54249 ENDIF
54250 ENDIF
54251
54252 ELSEIF(IH.EQ.3) THEN
54253 GHLL=0D0
54254 GHRR=0D0
54255 GHLR=0D0
54256 IF(IDU.EQ.1) THEN
54257 IF(IFL.EQ.5) THEN
54258 GHLR=XMF/2D0/XMW*(ATRIB*TANB-XMUZ)
54259 ELSEIF(IFL.EQ.15) THEN
54260 GHLR=XMF/2D0/XMW*(ATRIL*TANB-XMUZ)
54261 ENDIF
54262 ELSE
54263 IF(IFL.EQ.6) THEN
54264 GHLR=XMF/2D0/XMW*(ATRIT/TANB-XMUZ)
54265 ENDIF
54266 ENDIF
54267 ENDIF
54268 IF(IH.EQ.3) GOTO 180
54269
54270 AL=SFMIX(IFL,1)**2
54271 AR=SFMIX(IFL,2)**2
54272 ALR=SFMIX(IFL,1)*SFMIX(IFL,2)
54273 IF(IFL.LE.6) THEN
54274 CF=3D0
54275 ELSE
54276 CF=1D0
54277 ENDIF
54278
54279 IF(AXMI.GE.2D0*XMJ) THEN
54280 LKNT=LKNT+1
54281 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54282 & (GHLL*AL+GHRR*AR
54283 & +2D0*GHLR*ALR)**2
54284 IDLAM(LKNT,1)=IJ
54285 IDLAM(LKNT,2)=-IJ
54286 IDLAM(LKNT,3)=0
54287 ENDIF
54288
54289 IF(AXMI.GE.2D0*XMJR) THEN
54290 LKNT=LKNT+1
54291 AL=SFMIX(IFL,3)**2
54292 AR=SFMIX(IFL,4)**2
54293 ALR=SFMIX(IFL,3)*SFMIX(IFL,4)
54294 XMJ=XMJR
54295 XMJ2=XMJ**2
54296 XL=PYLAMF(XMI2,XMJ2,XMJ2)
54297 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54298 & (GHLL*AL+GHRR*AR
54299 & +2D0*GHLR*ALR)**2
54300 IDLAM(LKNT,1)=IJ+KSUSY1
54301 IDLAM(LKNT,2)=-(IJ+KSUSY1)
54302 IDLAM(LKNT,3)=0
54303 ENDIF
54304 180 CONTINUE
54305
54306 IF(AXMI.GE.XMJL+XMJR) THEN
54307 LKNT=LKNT+1
54308 AL=SFMIX(IFL,1)*SFMIX(IFL,3)
54309 AR=SFMIX(IFL,2)*SFMIX(IFL,4)
54310 ALR=SFMIX(IFL,1)*SFMIX(IFL,4)+SFMIX(IFL,2)*SFMIX(IFL,3)
54311 XMJ=XMJR
54312 XMJ2=XMJ**2
54313 XL=PYLAMF(XMI2,XMJ2,XMJL**2)
54314 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54315 & (GHLL*AL+GHRR*AR)**2
54316 IDLAM(LKNT,1)=IJ
54317 IDLAM(LKNT,2)=-(IJ+KSUSY1)
54318 IDLAM(LKNT,3)=0
54319 LKNT=LKNT+1
54320 IDLAM(LKNT,1)=-IJ
54321 IDLAM(LKNT,2)=IJ+KSUSY1
54322 IDLAM(LKNT,3)=0
54323 XLAM(LKNT)=XLAM(LKNT-1)
54324 ENDIF
54325 ENDIF
54326 190 CONTINUE
54327 200 CONTINUE
54328 210 CONTINUE
54329
54330 GOTO 270
54331 220 CONTINUE
54332
54333C...H+ -> CHI+_I + CHI0_J
54334 DO 240 IJ=1,4
54335 XMJ=SMZ(IJ)
54336 AXMJ=ABS(XMJ)
54337 XMJ2=XMJ**2
54338 DO 230 IK=1,2
54339 XMK=SMW(IK)
54340 AXMK=ABS(XMK)
54341 IF(AXMI.GE.AXMJ+AXMK) THEN
54342 LKNT=LKNT+1
54343 OLPP=CBETA*DCONJG(ZMIXC(IJ,4)*VMIXC(IK,1)+(ZMIXC(IJ,2)+
54344 & ZMIXC(IJ,1)*TANW)*VMIXC(IK,2)/SR2)
54345 ORPP=SBETA*(ZMIXC(IJ,3)*UMIXC(IK,1)-
54346 & (ZMIXC(IJ,2)+ZMIXC(IJ,1)*TANW)*UMIXC(IK,2)/SR2)
54347 GX2=ABS(OLPP)**2+ABS(ORPP)**2
54348 GLR=DBLE(OLPP*DCONJG(ORPP))
54349 XLAM(LKNT)=PYH2XX(C1,XMI,XMJ,-XMK,GX2,GLR)
54350 IDLAM(LKNT,1)=KFNCHI(IJ)
54351 IDLAM(LKNT,2)=KFCCHI(IK)
54352 IDLAM(LKNT,3)=0
54353 ENDIF
54354 230 CONTINUE
54355 240 CONTINUE
54356
54357 GL=-XMW/SR2*(SIN(2D0*BETA)-PMAS(6,1)**2/TANB/XMW2)
54358 GR=-PMAS(6,1)/SR2/XMW*(XMUZ-ATRIT/TANB)
54359 AL=0D0
54360 AR=0D0
54361 CF=3D0
54362
54363C...H+ -> T_1 B_1~
54364 XM1=PMAS(PYCOMP(KSUSY1+6),1)
54365 XM2=PMAS(PYCOMP(KSUSY1+5),1)
54366 IF(XMI.GE.XM1+XM2) THEN
54367 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54368 LKNT=LKNT+1
54369 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54370 & (GL*SFMIX(6,1)*SFMIX(5,1)+GR*SFMIX(6,2)*SFMIX(5,1))**2
54371 IDLAM(LKNT,1)=KSUSY1+6
54372 IDLAM(LKNT,2)=-(KSUSY1+5)
54373 IDLAM(LKNT,3)=0
54374 ENDIF
54375
54376C...H+ -> T_2 B_1~
54377 XM1=PMAS(PYCOMP(KSUSY2+6),1)
54378 XM2=PMAS(PYCOMP(KSUSY1+5),1)
54379 IF(XMI.GE.XM1+XM2) THEN
54380 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54381 LKNT=LKNT+1
54382 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54383 & (GL*SFMIX(6,3)*SFMIX(5,1)+GR*SFMIX(6,4)*SFMIX(5,1))**2
54384 IDLAM(LKNT,1)=KSUSY2+6
54385 IDLAM(LKNT,2)=-(KSUSY1+5)
54386 IDLAM(LKNT,3)=0
54387 ENDIF
54388
54389C...H+ -> T_1 B_2~
54390 XM1=PMAS(PYCOMP(KSUSY1+6),1)
54391 XM2=PMAS(PYCOMP(KSUSY2+5),1)
54392 IF(XMI.GE.XM1+XM2) THEN
54393 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54394 LKNT=LKNT+1
54395 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54396 & (GL*SFMIX(6,1)*SFMIX(5,3)+GR*SFMIX(6,2)*SFMIX(5,3))**2
54397 IDLAM(LKNT,1)=KSUSY1+6
54398 IDLAM(LKNT,2)=-(KSUSY2+5)
54399 IDLAM(LKNT,3)=0
54400 ENDIF
54401
54402C...H+ -> T_2 B_2~
54403 XM1=PMAS(PYCOMP(KSUSY2+6),1)
54404 XM2=PMAS(PYCOMP(KSUSY2+5),1)
54405 IF(XMI.GE.XM1+XM2) THEN
54406 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54407 LKNT=LKNT+1
54408 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*
54409 & (GL*SFMIX(6,3)*SFMIX(5,3)+GR*SFMIX(6,4)*SFMIX(5,3))**2
54410 IDLAM(LKNT,1)=KSUSY2+6
54411 IDLAM(LKNT,2)=-(KSUSY2+5)
54412 IDLAM(LKNT,3)=0
54413 ENDIF
54414
54415C...H+ -> UL DL~
54416 GL=-XMW/SR2*SIN(2D0*BETA)
54417 DO 250 IJ=1,3,2
54418 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
54419 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
54420 IF(XMI.GE.XM1+XM2) THEN
54421 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54422 LKNT=LKNT+1
54423 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
54424 IDLAM(LKNT,1)=-(KSUSY1+IJ)
54425 IDLAM(LKNT,2)=KSUSY1+IJ+1
54426 IDLAM(LKNT,3)=0
54427 ENDIF
54428 250 CONTINUE
54429
54430C...H+ -> EL~ NUL
54431 CF=1D0
54432 DO 260 IJ=11,13,2
54433 XM1=PMAS(PYCOMP(KSUSY1+IJ),1)
54434 XM2=PMAS(PYCOMP(KSUSY1+IJ+1),1)
54435 IF(XMI.GE.XM1+XM2) THEN
54436 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54437 LKNT=LKNT+1
54438 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2
54439 IDLAM(LKNT,1)=-(KSUSY1+IJ)
54440 IDLAM(LKNT,2)=KSUSY1+IJ+1
54441 IDLAM(LKNT,3)=0
54442 ENDIF
54443 260 CONTINUE
54444
54445C...H+ -> TAU1 NUTAUL
54446 XM1=PMAS(PYCOMP(KSUSY1+15),1)
54447 XM2=PMAS(PYCOMP(KSUSY1+16),1)
54448 IF(XMI.GE.XM1+XM2) THEN
54449 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54450 LKNT=LKNT+1
54451 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,1)**2
54452 IDLAM(LKNT,1)=-(KSUSY1+15)
54453 IDLAM(LKNT,2)= KSUSY1+16
54454 IDLAM(LKNT,3)=0
54455 ENDIF
54456
54457C...H+ -> TAU2 NUTAUL
54458 XM1=PMAS(PYCOMP(KSUSY2+15),1)
54459 XM2=PMAS(PYCOMP(KSUSY1+16),1)
54460 IF(XMI.GE.XM1+XM2) THEN
54461 XL=PYLAMF(XMI2,XM1**2,XM2**2)
54462 LKNT=LKNT+1
54463 XLAM(LKNT)=CF*SQRT(XL)/4D0*C1/XMI3*GL**2*SFMIX(15,3)**2
54464 IDLAM(LKNT,1)=-(KSUSY2+15)
54465 IDLAM(LKNT,2)= KSUSY1+16
54466 IDLAM(LKNT,3)=0
54467 ENDIF
54468
54469 270 CONTINUE
54470 IKNT=LKNT
54471 XLAM(0)=0D0
54472 DO 280 I=1,IKNT
54473 IF(XLAM(I).LE.0D0) XLAM(I)=0D0
54474 XLAM(0)=XLAM(0)+XLAM(I)
54475 280 CONTINUE
54476 IF(XLAM(0).EQ.0D0) XLAM(0)=1D-6
54477
54478 RETURN
54479 END
54480
54481C*********************************************************************
54482
54483C...PYH2XX
54484C...Calculates the decay rate for a Higgs to an ino pair.
54485
54486 FUNCTION PYH2XX(C1,XM1,XM2,XM3,GX2,GLR)
54487
54488C...Double precision and integer declarations.
54489 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54490 IMPLICIT INTEGER(I-N)
54491 INTEGER PYK,PYCHGE,PYCOMP
54492C...Commonblocks.
54493 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54494 SAVE /PYDAT1/
54495
54496C...Local variables.
54497 DOUBLE PRECISION PYH2XX,XM1,XM2,XM3,GL,GR
54498 DOUBLE PRECISION XL,PYLAMF,C1
54499 DOUBLE PRECISION XMI2,XMJ2,XMK2,XMI3
54500
54501 XMI2=XM1**2
54502 XMI3=ABS(XM1**3)
54503 XMJ2=XM2**2
54504 XMK2=XM3**2
54505 XL=PYLAMF(XMI2,XMJ2,XMK2)
54506 PYH2XX=C1/4D0/XMI3*SQRT(XL)
54507 &*(GX2*(XMI2-XMJ2-XMK2)-
54508 &4D0*GLR*XM3*XM2)
54509 IF(PYH2XX.LT.0D0) PYH2XX=0D0
54510
54511 RETURN
54512 END
54513
54514C*********************************************************************
54515
54516C...PYGAUS
54517C...Integration by adaptive Gaussian quadrature.
54518C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
54519
54520 FUNCTION PYGAUS(F, A, B, EPS)
54521
54522C...Double precision and integer declarations.
54523 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54524 IMPLICIT INTEGER(I-N)
54525 INTEGER PYK,PYCHGE,PYCOMP
54526
54527C...Local declarations.
54528 EXTERNAL F
54529 DOUBLE PRECISION F,W(12), X(12)
54530 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
54531 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
54532 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
54533 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
54534 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
54535 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
54536 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
54537 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
54538 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
54539 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
54540 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
54541 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
54542
54543C...The Gaussian quadrature algorithm.
54544 H = 0D0
54545 IF(B .EQ. A) GOTO 140
54546 CONST = 5D-3 / ABS(B-A)
54547 BB = A
54548 100 CONTINUE
54549 AA = BB
54550 BB = B
54551 110 CONTINUE
54552 C1 = 0.5D0*(BB+AA)
54553 C2 = 0.5D0*(BB-AA)
54554 S8 = 0D0
54555 DO 120 I = 1, 4
54556 U = C2*X(I)
54557 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
54558 120 CONTINUE
54559 S16 = 0D0
54560 DO 130 I = 5, 12
54561 U = C2*X(I)
54562 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
54563 130 CONTINUE
54564 S16 = C2*S16
54565 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
54566 H = H + S16
54567 IF(BB .NE. B) GOTO 100
54568 ELSE
54569 BB = C1
54570 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
54571 H = 0D0
54572 CALL PYERRM(18,'(PYGAUS:) too high accuracy required')
54573 GOTO 140
54574 ENDIF
54575 140 CONTINUE
54576 PYGAUS = H
54577
54578 RETURN
54579 END
54580
54581C*********************************************************************
54582
54583C...PYGAU2
54584C...Integration by adaptive Gaussian quadrature.
54585C...Adapted from the CERNLIB DGAUSS routine by K.S. Kolbig.
54586C...Carbon copy of PYGAUS, but avoids having to use it recursively.
54587
54588 FUNCTION PYGAU2(F, A, B, EPS)
54589
54590C...Double precision and integer declarations.
54591 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54592 IMPLICIT INTEGER(I-N)
54593 INTEGER PYK,PYCHGE,PYCOMP
54594
54595C...Local declarations.
54596 EXTERNAL F
54597 DOUBLE PRECISION F,W(12), X(12)
54598 DATA X( 1) /9.6028985649753623D-1/, W( 1) /1.0122853629037626D-1/
54599 DATA X( 2) /7.9666647741362674D-1/, W( 2) /2.2238103445337447D-1/
54600 DATA X( 3) /5.2553240991632899D-1/, W( 3) /3.1370664587788729D-1/
54601 DATA X( 4) /1.8343464249564980D-1/, W( 4) /3.6268378337836198D-1/
54602 DATA X( 5) /9.8940093499164993D-1/, W( 5) /2.7152459411754095D-2/
54603 DATA X( 6) /9.4457502307323258D-1/, W( 6) /6.2253523938647893D-2/
54604 DATA X( 7) /8.6563120238783174D-1/, W( 7) /9.5158511682492785D-2/
54605 DATA X( 8) /7.5540440835500303D-1/, W( 8) /1.2462897125553387D-1/
54606 DATA X( 9) /6.1787624440264375D-1/, W( 9) /1.4959598881657673D-1/
54607 DATA X(10) /4.5801677765722739D-1/, W(10) /1.6915651939500254D-1/
54608 DATA X(11) /2.8160355077925891D-1/, W(11) /1.8260341504492359D-1/
54609 DATA X(12) /9.5012509837637440D-2/, W(12) /1.8945061045506850D-1/
54610
54611C...The Gaussian quadrature algorithm.
54612 H = 0D0
54613 IF(B .EQ. A) GOTO 140
54614 CONST = 5D-3 / ABS(B-A)
54615 BB = A
54616 100 CONTINUE
54617 AA = BB
54618 BB = B
54619 110 CONTINUE
54620 C1 = 0.5D0*(BB+AA)
54621 C2 = 0.5D0*(BB-AA)
54622 S8 = 0D0
54623 DO 120 I = 1, 4
54624 U = C2*X(I)
54625 S8 = S8 + W(I) * (F(C1+U) + F(C1-U))
54626 120 CONTINUE
54627 S16 = 0D0
54628 DO 130 I = 5, 12
54629 U = C2*X(I)
54630 S16 = S16 + W(I) * (F(C1+U) + F(C1-U))
54631 130 CONTINUE
54632 S16 = C2*S16
54633 IF(DABS(S16-C2*S8) .LE. EPS*(1D0+DABS(S16))) THEN
54634 H = H + S16
54635 IF(BB .NE. B) GOTO 100
54636 ELSE
54637 BB = C1
54638 IF(1D0 + CONST*ABS(C2) .NE. 1D0) GOTO 110
54639 H = 0D0
54640 CALL PYERRM(18,'(PYGAU2:) too high accuracy required')
54641 GOTO 140
54642 ENDIF
54643 140 CONTINUE
54644 PYGAU2 = H
54645
54646 RETURN
54647 END
54648
54649C*********************************************************************
54650
54651C...PYSIMP
54652C...Simpson formula for an integral.
54653
54654 FUNCTION PYSIMP(Y,X0,X1,N)
54655
54656C...Double precision and integer declarations.
54657 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54658 IMPLICIT INTEGER(I-N)
54659 INTEGER PYK,PYCHGE,PYCOMP
54660
54661C...Local variables.
54662 DOUBLE PRECISION Y,X0,X1,H,S
54663 DIMENSION Y(0:N)
54664
54665 S=0D0
54666 H=(X1-X0)/N
54667 DO 100 I=0,N-2,2
54668 S=S+Y(I)+4D0*Y(I+1)+Y(I+2)
54669 100 CONTINUE
54670 PYSIMP=S*H/3D0
54671
54672 RETURN
54673 END
54674
54675C*********************************************************************
54676
54677C...PYLAMF
54678C...The standard lambda function.
54679
54680 FUNCTION PYLAMF(X,Y,Z)
54681
54682C...Double precision and integer declarations.
54683 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54684 IMPLICIT INTEGER(I-N)
54685 INTEGER PYK,PYCHGE,PYCOMP
54686
54687C...Local variables.
54688 DOUBLE PRECISION PYLAMF,X,Y,Z
54689
54690 PYLAMF=(X-(Y+Z))**2-4D0*Y*Z
54691 IF(PYLAMF.LT.0D0) PYLAMF=0D0
54692
54693 RETURN
54694 END
54695
54696C*********************************************************************
54697
54698C...PYTBDY
54699C...Generates 3-body decays of gauginos.
54700
54701 SUBROUTINE PYTBDY(IDIN)
54702
54703C...Double precision and integer declarations.
54704 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
54705 IMPLICIT INTEGER(I-N)
54706 INTEGER PYK,PYCHGE,PYCOMP
54707C...Parameter statement to help give large particle numbers.
54708 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
54709 &KEXCIT=4000000,KDIMEN=5000000)
54710C...Commonblocks.
54711 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
54712 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
54713 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
54714C COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
54715 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
54716 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
54717 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
54718C SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYPARS/,/PYSSMT/
54719 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYSSMT/
54720
54721C...Local variables.
54722 DOUBLE PRECISION XM(5)
54723 COMPLEX*16 OLPP,ORPP,QLL,QLR,QRR,QRL,GLIJ,GRIJ,PROPZ
54724 COMPLEX*16 QLLS,QRRS,QLRS,QRLS,QLLU,QRRU,QLRT,QRLT
54725 COMPLEX*16 ZMIXC(4,4),UMIXC(2,2),VMIXC(2,2)
54726 DOUBLE PRECISION S12MIN,S12MAX,YJACO1,S23AVE,S23DF1,S23DF2
54727 DOUBLE PRECISION D1,D2,D3,P1,P2,P3,CTHE1,STHE1,CTHE3,STHE3
54728 DOUBLE PRECISION CPHI1,SPHI1
54729 DOUBLE PRECISION S23DEL,EPS
54730 DOUBLE PRECISION GOLDEN,AX,BX,CX,TOL,XMIN,R,C
54731 PARAMETER (R=0.61803399D0,C=1D0-R,TOL=1D-3)
54732 DOUBLE PRECISION F1,F2,X0,X1,X2,X3
54733 INTEGER INOID(4)
54734 DATA INOID/22,23,25,35/
54735 DATA EPS/1D-6/
54736
54737 ID=IDIN
54738 ISKIP=1
54739 XM(1)=P(N+1,5)
54740 XM(2)=P(N+2,5)
54741 XM(3)=P(N+3,5)
54742 XM(5)=P(ID,5)
54743
54744C...GENERATE S12
54745 S12MIN=(XM(1)+XM(2))**2
54746 S12MAX=(XM(5)-XM(3))**2
54747 YJACO1=S12MAX-S12MIN
54748
54749C...Initialize some parameters
54750 XW=PARU(102)
54751 XW1=1D0-XW
54752 TANW=SQRT(XW/XW1)
54753 IZID1=0
54754 IWID1=0
54755 IZID2=0
54756 IWID2=0
54757
54758 IA=K(N+2,2)
54759 JA=K(N+3,2)
54760
54761C...Mrenna: check that we are indeed decaying a SUSY particle
54762 IF(IABS(K(ID,2)).LT.KSUSY1.OR.IABS(K(ID,2)).GE.3000000) THEN
54763
54764 ELSE
54765 DO 100 I1=1,4
54766 IF(MOD(K(N+1,2),KSUSY1).EQ.INOID(I1)) IZID1=I1
54767 IF(MOD(K(ID,2),KSUSY1).EQ.INOID(I1)) IZID2=I1
54768 100 CONTINUE
54769 IF(MOD(K(N+1,2),KSUSY1).EQ.24) IWID1=1
54770 IF(MOD(K(N+1,2),KSUSY1).EQ.37) IWID1=2
54771 IF(MOD(K(ID,2),KSUSY1).EQ.24) IWID2=1
54772 IF(MOD(K(ID,2),KSUSY1).EQ.37) IWID2=2
54773 ZM12=XM(5)**2
54774 ZM22=XM(1)**2
54775 EI=KCHG(PYCOMP(IABS(IA)),1)/3D0
54776 T3I=SIGN(1D0,EI+1D-6)/2D0
54777 ENDIF
54778
54779 IF(MSTP(47).EQ.0) THEN
54780 ISKIP=0
54781 ELSEIF(MAX(ABS(IA),ABS(JA)).EQ.6) THEN
54782 ISKIP=0
54783 ELSEIF(IZID1*IZID2.NE.0) THEN
54784 SQMZ=PMAS(23,1)**2
54785 GMMZ=PMAS(23,1)*PMAS(23,2)
54786 DO 110 I=1,4
54787 ZMIXC(IZID1,I)=DCMPLX(ZMIX(IZID1,I),ZMIXI(IZID1,I))
54788 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
54789 110 CONTINUE
54790 OLPP=(ZMIXC(IZID1,3)*DCONJG(ZMIXC(IZID2,3))-
54791 & ZMIXC(IZID1,4)*DCONJG(ZMIXC(IZID2,4)))/2D0
54792 ORPP=DCONJG(OLPP)
54793 XLL2=PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
54794 XLR2=XLL2
54795 XRR2=PMAS(PYCOMP(KSUSY2+IABS(IA)),1)**2
54796 XRL2=XRR2
54797 GLIJ=(T3I*ZMIXC(IZID1,2)-TANW*(T3I-EI)*ZMIXC(IZID1,1))*
54798 & DCONJG(T3I*ZMIXC(IZID2,2)-TANW*(T3I-EI)*ZMIXC(IZID2,1))
54799 GRIJ=ZMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1))*(EI*TANW)**2
54800 XM1M2=SMZ(IZID1)*SMZ(IZID2)
54801 QLLS=DCMPLX((T3I-EI*XW)/XW1)*OLPP
54802 QLLU=-GLIJ
54803 QLRS=-DCMPLX((T3I-EI*XW)/XW1)*ORPP
54804 QLRT=DCONJG(GLIJ)
54805 QRLS=-DCMPLX((EI*XW)/XW1)*OLPP
54806 QRLT=GRIJ
54807 QRRS=DCMPLX((EI*XW)/XW1)*ORPP
54808 QRRU=-DCONJG(GRIJ)
54809 ELSEIF(IZID1*IWID2.NE.0.OR.IZID2*IWID1.NE.0) THEN
54810 IF(IZID1.NE.0) THEN
54811 XM1M2=SMZ(IZID1)*SMW(IWID2)
54812 IZID1=IWID2
54813 IZID2=IZID1
54814 ELSE
54815 XM1M2=SMZ(IZID2)*SMW(IWID1)
54816 IZID1=IWID1
54817 ENDIF
54818 RT2I = 1D0/SQRT(2D0)
54819 SQMZ=PMAS(24,1)**2
54820 GMMZ=PMAS(24,1)*PMAS(24,2)
54821 DO 120 I=1,2
54822 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54823 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54824 120 CONTINUE
54825 DO 130 I=1,4
54826 ZMIXC(IZID2,I)=DCMPLX(ZMIX(IZID2,I),ZMIXI(IZID2,I))
54827 130 CONTINUE
54828 QLLS=(DCONJG(ZMIXC(IZID2,2))*VMIXC(IZID1,1)-
54829 & DCONJG(ZMIXC(IZID2,4))*VMIXC(IZID1,2)*RT2I)
54830 QLRS=(ZMIXC(IZID2,2)*DCONJG(UMIXC(IZID1,1))+
54831 & ZMIXC(IZID2,3)*DCONJG(UMIXC(IZID1,2))*RT2I)
54832 EJ=KCHG(IABS(JA),1)/3D0
54833 T3J=SIGN(1D0,EJ+1D-6)/2D0
54834 QRLS=DCMPLX(0D0,0D0)
54835 QRLT=QRLS
54836 QRRS=QRLS
54837 QRRU=QRLS
54838 XRR2=1D6**2
54839 XRL2=XRR2
54840 XLR2 = PMAS(PYCOMP(KSUSY1+IABS(JA)),1)**2
54841 XLL2 = PMAS(PYCOMP(KSUSY1+IABS(IA)),1)**2
54842 IF(MOD(IA,2).EQ.0) THEN
54843 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EI-T3I)*
54844 & TANW+ZMIXC(IZID2,2)*T3I)
54845 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54846 & ZMIXC(IZID2,1)*(EJ-T3J)*TANW+ZMIXC(IZID2,2)*T3J)
54847 ELSE
54848 QLLU=VMIXC(IZID1,1)*DCONJG(ZMIXC(IZID2,1)*(EJ-T3J)*
54849 & TANW+ZMIXC(IZID2,2)*T3J)
54850 QLRT=-DCONJG(UMIXC(IZID1,1))*(
54851 & ZMIXC(IZID2,1)*(EI-T3I)*TANW+ZMIXC(IZID2,2)*T3I)
54852 ENDIF
54853 ELSEIF(IWID1*IWID2.NE.0) THEN
54854 IZID1=IWID1
54855 IZID2=IWID2
54856 XM1M2=SMW(IWID1)*SMW(IWID2)
54857 SQMZ=PMAS(23,1)**2
54858 GMMZ=PMAS(23,1)*PMAS(23,2)
54859 DO 140 I=1,2
54860 VMIXC(IZID1,I)=DCMPLX(VMIX(IZID1,I),VMIXI(IZID1,I))
54861 UMIXC(IZID1,I)=DCMPLX(UMIX(IZID1,I),UMIXI(IZID1,I))
54862 VMIXC(IZID2,I)=DCMPLX(VMIX(IZID2,I),VMIXI(IZID2,I))
54863 UMIXC(IZID2,I)=DCMPLX(UMIX(IZID2,I),UMIXI(IZID2,I))
54864 140 CONTINUE
54865 OLPP=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))-
54866 & VMIXC(IZID2,2)*DCONJG(VMIXC(IZID1,2))/2D0
54867 ORPP=-UMIXC(IZID1,1)*DCONJG(UMIXC(IZID2,1))-
54868 & UMIXC(IZID1,2)*DCONJG(UMIXC(IZID2,2))/2D0
54869 QRLS=-DCMPLX(EI/XW1)*ORPP
54870 QLLS=DCMPLX((T3I-XW*EI)/XW/XW1)*ORPP
54871 QRRS=-DCMPLX(EI/XW1)*OLPP
54872 QLRS=DCMPLX((T3I-XW*EI)/XW/XW1)*OLPP
54873 IF(MOD(IA,2).EQ.0) THEN
54874 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)-1),1)**2
54875 QLRT=-UMIXC(IZID2,1)*DCONJG(UMIXC(IZID1,1))*DCMPLX(T3I/XW)
54876 ELSE
54877 XLR2=PMAS(PYCOMP(KSUSY1+IABS(IA)+1),1)**2
54878 QLRT=-VMIXC(IZID2,1)*DCONJG(VMIXC(IZID1,1))*DCMPLX(T3I/XW)
54879 ENDIF
54880 ELSEIF(MOD(K(N+1,2),KSUSY1).EQ.21.OR.MOD(K(ID,2),KSUSY1).EQ.21)
54881 &THEN
54882 ISKIP=0
54883 ELSE
54884 ISKIP=0
54885 ENDIF
54886
54887 IF(ISKIP.NE.0) THEN
54888 WTMAX=0D0
54889 DO 160 KT=1,100
54890 S12=S12MIN+YJACO1*(KT-1)/99
54891 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
54892 & *(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
54893 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
54894 & -(2D0*XM(1)*XM(2))**2
54895 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
54896 & -(2D0*XM(3)*XM(5))**2
54897 S23DF1=S23DF1*EPS
54898 S23DF2=S23DF2*EPS
54899 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
54900 S23DEL=S23DEL/EPS
54901 S23MIN=S23AVE-S23DEL
54902 S23MAX=S23AVE+S23DEL
54903 YJACO2=S23MAX-S23MIN
54904 TH=S12
54905 DO 150 KS=1,100
54906 S23=S23MIN+YJACO2*(KS-1)/99
54907 SH=S23
54908 UH=ZM12+ZM22-SH-TH
54909 WU2 = (UH-ZM12)*(UH-ZM22)
54910 WT2 = (TH-ZM12)*(TH-ZM22)
54911 WS2 = XM1M2*SH
54912 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
54913 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
54914 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
54915 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
54916 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
54917 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
54918 WT0=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
54919 & (ABS(QRL)**2+ABS(QLR)**2)*WT2+
54920 & 2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
54921 IF(WT0.GT.WTMAX) WTMAX=WT0
54922 150 CONTINUE
54923 160 CONTINUE
54924
54925 WTMAX=WTMAX*1.05D0
54926 ENDIF
54927
54928C...FIND S12*
54929 AX=S12MIN
54930 CX=S12MAX
54931 BX=S12MIN+0.5D0*YJACO1
54932 X0=AX
54933 X3=CX
54934 IF(ABS(CX-BX).GT.ABS(BX-AX))THEN
54935 X1=BX
54936 X2=BX+C*(CX-BX)
54937 ELSE
54938 X2=BX
54939 X1=BX-C*(BX-AX)
54940 ENDIF
54941
54942C...SOLVE FOR F1 AND F2
54943 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54944 &-(2D0*XM(1)*XM(2))**2
54945 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54946 &-(2D0*XM(3)*XM(5))**2
54947 S23DF1=S23DF1*EPS
54948 S23DF2=S23DF2*EPS
54949 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54950 F1=-2D0*S23DEL/EPS
54951 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54952 &-(2D0*XM(1)*XM(2))**2
54953 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54954 &-(2D0*XM(3)*XM(5))**2
54955 S23DF1=S23DF1*EPS
54956 S23DF2=S23DF2*EPS
54957 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54958 F2=-2D0*S23DEL/EPS
54959
54960 170 IF(ABS(X3-X0).GT.TOL*(ABS(X1)+ABS(X2)))THEN
54961C...Possibility of infinite loop with .LT.; changed to .LE. (SKANDS)
54962 IF(F2.LE.F1)THEN
54963 X0=X1
54964 X1=X2
54965 X2=R*X1+C*X3
54966 F1=F2
54967 S23DF1=(X2-XM(2)**2-XM(1)**2)**2
54968 & -(2D0*XM(1)*XM(2))**2
54969 S23DF2=(X2-XM(3)**2-XM(5)**2)**2
54970 & -(2D0*XM(3)*XM(5))**2
54971 S23DF1=S23DF1*EPS
54972 S23DF2=S23DF2*EPS
54973 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X2)
54974 F2=-2D0*S23DEL/EPS
54975 ELSE
54976 X3=X2
54977 X2=X1
54978 X1=R*X2+C*X0
54979 F2=F1
54980 S23DF1=(X1-XM(2)**2-XM(1)**2)**2
54981 & -(2D0*XM(1)*XM(2))**2
54982 S23DF2=(X1-XM(3)**2-XM(5)**2)**2
54983 & -(2D0*XM(3)*XM(5))**2
54984 S23DF1=S23DF1*EPS
54985 S23DF2=S23DF2*EPS
54986 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*X1)
54987 F1=-2D0*S23DEL/EPS
54988 ENDIF
54989 GOTO 170
54990 ENDIF
54991C...WE WANT THE MAXIMUM, NOT THE MINIMUM
54992 IF(F1.LT.F2)THEN
54993 GOLDEN=-F1
54994 XMIN=X1
54995 ELSE
54996 GOLDEN=-F2
54997 XMIN=X2
54998 ENDIF
54999
55000 IKNT=0
55001 180 S12=S12MIN+PYR(0)*YJACO1
55002 IKNT=IKNT+1
55003C...GENERATE S23
55004 S23AVE=XM(2)**2+XM(3)**2-(S12+XM(2)**2-XM(1)**2)
55005 &*(S12+XM(3)**2-XM(5)**2)/(2D0*S12)
55006 S23DF1=(S12-XM(2)**2-XM(1)**2)**2
55007 &-(2D0*XM(1)*XM(2))**2
55008 S23DF2=(S12-XM(3)**2-XM(5)**2)**2
55009 &-(2D0*XM(3)*XM(5))**2
55010 S23DF1=S23DF1*EPS
55011 S23DF2=S23DF2*EPS
55012 S23DEL=SQRT(MAX(0D0,S23DF1*S23DF2))/(2D0*S12)
55013 S23DEL=S23DEL/EPS
55014 S23MIN=S23AVE-S23DEL
55015 S23MAX=S23AVE+S23DEL
55016 YJACO2=S23MAX-S23MIN
55017 S23=S23MIN+PYR(0)*YJACO2
55018
55019C...CHECK THE SAMPLING
55020 IF(IKNT.GT.100) THEN
55021 WRITE(MSTU(11),*) ' IKNT > 100 IN PYTBDY '
55022 GOTO 190
55023 ENDIF
55024 IF(YJACO2.LT.PYR(0)*GOLDEN) GOTO 180
55025
55026 IF(ISKIP.EQ.0) GOTO 190
55027
55028 SH=S23
55029 TH=S12
55030 UH=ZM12+ZM22-SH-TH
55031
55032 WU2 = (UH-ZM12)*(UH-ZM22)
55033 WT2 = (TH-ZM12)*(TH-ZM22)
55034 WS2 = XM1M2*SH
55035 PROPZ2 = (SH-SQMZ)**2 + GMMZ**2
55036 PROPZ=DCMPLX(SH-SQMZ,-GMMZ)/DCMPLX(PROPZ2)
55037
55038 QLL=QLLS*PROPZ+QLLU/DCMPLX(UH-XLL2)
55039 QLR=QLRS*PROPZ+QLRT/DCMPLX(TH-XLR2)
55040 QRL=QRLS*PROPZ+QRLT/DCMPLX(TH-XRL2)
55041 QRR=QRRS*PROPZ+QRRU/DCMPLX(UH-XRR2)
55042c QLL=DCMPLX((T3I-EI*XW)/XW1)*OLPP*PROPZ-GLIJ/DCMPLX(UH-XML2)
55043c QLR=-DCMPLX((T3I-EI*XW)/XW1)*ORPP*PROPZ+DCONJG(GLIJ)
55044c &/DCMPLX(TH-XML2)
55045c QRL=-DCMPLX((EI*XW)/XW1)*OLPP*PROPZ+GRIJ/DCMPLX(TH-XMR2)
55046c QRR=DCMPLX((EI*XW)/XW1)*ORPP*PROPZ
55047c &-DCONJG(GRIJ)/DCMPLX(UH-XMR2)
55048 WT=-((ABS(QLL)**2+ABS(QRR)**2)*WU2+
55049 &(ABS(QRL)**2+ABS(QLR)**2)*WT2+
55050 &2D0*DBLE(QLR*DCONJG(QLL)+QRL*DCONJG(QRR))*WS2)
55051
55052 IF(WT.LT.PYR(0)*WTMAX) GOTO 180
55053 IF(WT.GT.WTMAX) PRINT*,' WT > WTMAX ',WT,WTMAX
55054
55055 190 D3=(XM(5)**2+XM(3)**2-S12)/(2D0*XM(5))
55056 D1=(XM(5)**2+XM(1)**2-S23)/(2D0*XM(5))
55057 D2=XM(5)-D1-D3
55058 P1=SQRT(D1*D1-XM(1)**2)
55059 P2=SQRT(D2*D2-XM(2)**2)
55060 P3=SQRT(D3*D3-XM(3)**2)
55061 CTHE1=2D0*PYR(0)-1D0
55062 ANG1=2D0*PYR(0)*PARU(1)
55063 CPHI1=COS(ANG1)
55064 SPHI1=SIN(ANG1)
55065 ARG=1D0-CTHE1**2
55066 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
55067 STHE1=SQRT(ARG)
55068 P(N+1,1)=P1*STHE1*CPHI1
55069 P(N+1,2)=P1*STHE1*SPHI1
55070 P(N+1,3)=P1*CTHE1
55071 P(N+1,4)=D1
55072
55073C...GET CPHI3
55074 ANG3=2D0*PYR(0)*PARU(1)
55075 CPHI3=COS(ANG3)
55076 SPHI3=SIN(ANG3)
55077 CTHE3=(P2**2-P1**2-P3**2)/2D0/P1/P3
55078 ARG=1D0-CTHE3**2
55079 IF(ARG.LT.0D0.AND.ARG.GT.-1D-3) ARG=0D0
55080 STHE3=SQRT(ARG)
55081 P(N+3,1)=-P3*STHE3*CPHI3*CTHE1*CPHI1
55082 &+P3*STHE3*SPHI3*SPHI1
55083 &+P3*CTHE3*STHE1*CPHI1
55084 P(N+3,2)=-P3*STHE3*CPHI3*CTHE1*SPHI1
55085 &-P3*STHE3*SPHI3*CPHI1
55086 &+P3*CTHE3*STHE1*SPHI1
55087 P(N+3,3)=P3*STHE3*CPHI3*STHE1
55088 &+P3*CTHE3*CTHE1
55089 P(N+3,4)=D3
55090
55091 DO 200 I=1,3
55092 P(N+2,I)=-P(N+1,I)-P(N+3,I)
55093 200 CONTINUE
55094 P(N+2,4)=D2
55095
55096 RETURN
55097 END
55098
55099
55100C*********************************************************************
55101
55102C...PYTECM
55103C...Finds the s-hat dependent eigenvalues of the inverse propagator
55104C...matrix for gamma, Z, techni-rho, and techni-omega to optimize the
55105C...phase space generation. Extended to include techni-a meson, and
55106C...to return the width.
55107
55108 SUBROUTINE PYTECM(SMIN,SMOU,WIDO,IOPT)
55109
55110C...Double precision and integer declarations.
55111 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55112 IMPLICIT INTEGER(I-N)
55113 INTEGER PYK,PYCHGE,PYCOMP
55114C...Parameter statement to help give large particle numbers.
55115 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
55116 &KEXCIT=4000000,KDIMEN=5000000)
55117C...Commonblocks.
55118 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55119 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55120 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
55121 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
55122 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/,/PYTCSM/
55123
55124C...Local variables.
55125 DOUBLE PRECISION AR(5,5),WR(5),ZR(5,5),ZI(5,5),WORK(12,12),
55126 &AT(5,5),WI(5),FV1(5),FV2(5),FV3(5),SH,AEM,TANW,CT2W,QUPD,ALPRHT,
55127 &FAR,FAO,FZR,FZO,SHR,R1,R2,S1,S2,WDTP(0:400),WDTE(0:400,0:5),WX(5)
55128 INTEGER i,j,ierr
55129
55130 SH=SMIN
55131 SHR=SQRT(SH)
55132 AEM=PYALEM(SH)
55133
55134 SINW=MIN(SQRT(PARU(102)),1D0)
55135 COSW=SQRT(1D0-SINW**2)
55136 TANW=SINW/COSW
55137 CT2W=(1D0-2D0*PARU(102))/(2D0*PARU(102)/TANW)
55138 QUPD=2D0*RTCM(2)-1D0
55139
55140 ALPRHT=2.16D0*(3D0/DBLE(ITCM(1)))
55141 FAR=SQRT(AEM/ALPRHT)
55142 FAO=FAR*QUPD
55143 FZR=FAR*CT2W
55144 FZO=-FAO*TANW
55145 FZX=-FAR/RTCM(47)/(2D0*SINW*COSW)
55146 FWR=FAR/(2D0*SINW)
55147 FWX=-FWR/RTCM(47)
55148
55149 DO 110 I=1,5
55150 DO 100 J=1,5
55151 AT(I,J)=0D0
55152 100 CONTINUE
55153 110 CONTINUE
55154
55155C...NC
55156 IF(IOPT.EQ.1) THEN
55157 AR(1,1) = SH
55158 AR(2,2) = SH-PMAS(23,1)**2
55159 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+113),1)**2
55160 AR(4,4) = SH-PMAS(PYCOMP(KTECHN+223),1)**2
55161 AR(5,5) = SH-PMAS(PYCOMP(KTECHN+115),1)**2
55162 AR(1,2) = 0D0
55163 AR(2,1) = 0D0
55164 AR(1,3) = SH*FAR
55165 AR(3,1) = AR(1,3)
55166 AR(1,4) = SH*FAO
55167 AR(4,1) = AR(1,4)
55168 AR(2,3) = SH*FZR
55169 AR(3,2) = AR(2,3)
55170 AR(2,4) = SH*FZO
55171 AR(4,2) = AR(2,4)
55172 AR(3,4) = 0D0
55173 AR(4,3) = 0D0
55174 AR(2,5) = SH*FZX
55175 AR(5,2) = AR(2,5)
55176 AR(1,5) = 0D0
55177 AR(5,1) = AR(1,5)
55178 AR(3,5) = 0D0
55179 AR(5,3) = AR(3,5)
55180 AR(4,5) = 0D0
55181 AR(5,4) = AR(4,5)
55182 CALL PYWIDT(23,SH,WDTP,WDTE)
55183 AT(2,2) = WDTP(0)*SHR
55184 CALL PYWIDT(KTECHN+113,SH,WDTP,WDTE)
55185 AT(3,3) = WDTP(0)*SHR
55186 CALL PYWIDT(KTECHN+223,SH,WDTP,WDTE)
55187 AT(4,4) = WDTP(0)*SHR
55188 CALL PYWIDT(KTECHN+115,SH,WDTP,WDTE)
55189 AT(5,5) = WDTP(0)*SHR
55190 IDIM=5
55191C...CC
55192 ELSE
55193 AR(1,1) = SH-PMAS(24,1)**2
55194 AR(2,2) = SH-PMAS(PYCOMP(KTECHN+213),1)**2
55195 AR(3,3) = SH-PMAS(PYCOMP(KTECHN+215),1)**2
55196 AR(1,2) = SH*FWR
55197 AR(2,1) = AR(1,2)
55198 AR(1,3) = SH*FWX
55199 AR(3,1) = AR(1,3)
55200 AR(2,3) = 0D0
55201 AR(3,2) = 0D0
55202 CALL PYWIDT(24,SH,WDTP,WDTE)
55203 AT(1,1) = WDTP(0)*SHR
55204 CALL PYWIDT(KTECHN+213,SH,WDTP,WDTE)
55205 AT(2,2) = WDTP(0)*SHR
55206 CALL PYWIDT(KTECHN+215,SH,WDTP,WDTE)
55207 AT(3,3) = WDTP(0)*SHR
55208 IDIM=3
55209 ENDIF
55210 CALL PYEICG(IDIM,IDIM,AR,AT,WR,WI,0,ZR,ZI,FV1,FV2,FV3,IERR)
55211
55212 IMIN=1
55213 SXMN=1D20
55214 DO 120 I=1,IDIM
55215 WX(I)=SQRT(ABS(SH-WR(I)))
55216 WR(I)=ABS(WR(I))
55217 IF(WR(I).LT.SXMN) THEN
55218 SXMN=WR(I)
55219 IMIN=I
55220 ENDIF
55221 120 CONTINUE
55222 SMOU=WX(IMIN)**2
55223 WIDO=WI(IMIN)/SHR
55224
55225 RETURN
55226 END
55227C*********************************************************************
55228
55229C...PYXDIN
55230C...Universal Extra Dimensions Model (UED)
55231C...Initialize the xd masses and widths
55232C...M. ELKACIMI 4/03/2006
55233C...Modified for inclusion in Pythia Apr 2008, H. Przysiezniak, P. Skands
55234
55235 SUBROUTINE PYXDIN
55236
55237C...Double precision and integer declarations.
55238 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55239 IMPLICIT INTEGER(I-N)
55240 INTEGER PYK,PYCHGE,PYCOMP
55241C...Commonblocks.
55242 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55243 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
55244 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
55245C...UED Pythia common
55246 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55247
55248C...SAVE statements
55249 SAVE /PYDAT1/,/PYDAT3/,/PYSUBS/,/PYPUED/
55250
55251C...Print out some info about the UED model
55252 WRITE(MSTU(11),7000)
55253 & ' ',
55254 & '********** PYXDIN: initialization of UED ******************',
55255 & ' ',
55256 & 'Universal Extra Dimensions (UED) switched on ',
55257 & ' ',
55258 & 'This implementation is courtesy of',
55259 & ' M.Elkacimi, D.Goujdami, H.Przysiezniak, ',
55260 & ' see [hep-ph/0602198] (Les Houches 2005) ',
55261 & ' ',
55262 & 'The model follows [hep-ph/0012100] (Appelquist, Cheng, ',
55263 & 'Dobrescu), with gravity-mediated decay widths calculated in',
55264 & '[hep-ph/0001335] (DeRujula, Donini, Gavela, Rigolin) and ',
55265 & 'radiative corrections to the KK masses from [hep/ph0204342]',
55266 & '(Cheng, Matchev, Schmaltz).'
55267 WRITE(MSTU(11),7000)
55268 & ' ',
55269 & 'SM particles can propagate into one small extra dimension ',
55270 & 'of size 1/R = RUED(1) GeV. For gravity-mediated decays, the',
55271 & 'graviton is further allowed to propagate into N = IUED(4)',
55272 & 'large (eV^-1) extra dimensions.'
55273 WRITE(MSTU(11),7000)
55274 & ' ',
55275 & 'The switches and parameters for UED are:',
55276 & ' IUED(1): (D=0) main UED ON(=1)/OFF(=0) switch ',
55277 & ' IUED(2): (D=0) Grav. med. decays are set ON(=1)/OFF(=0)',
55278 & ' IUED(3): (D=5) number of quark flavours',
55279 & ' IUED(4): (D=6) number of large extra dimensions into',
55280 & ' which the graviton propagates',
55281 & ' IUED(5): (D=0) Lambda (=0) or Lambda*R (=1) is used',
55282 & ' IUED(6): (D=1) With/without rad.corrs. (=1/0)',
55283 & ' ',
55284 & ' RUED(1): (D=1000.) curvature 1/R of the UED (in GeV)',
55285 & ' RUED(2): (D=5000.) gravity mediated (GM) scale (in GeV)',
55286 & ' RUED(3): (D=20000.) Lambda cutoff scale (in GeV). Used',
55287 & ' when IUED(5)=0',
55288 & ' RUED(4): (D=20.) Lambda*R. Used when IUED(5)=1'
55289 WRITE(MSTU(11),7000)
55290 & ' ',
55291 & 'N.B.: the Higgs mass is also a free parameter of the UED ',
55292 & 'model, but is set through pmas(25,1).',
55293 & ' '
55294
55295C...Hardcoded switch, required by current implementation
55296 CALL PYGIVE('MSTP(42)=0')
55297
55298C...Turn the gravity mediated decay (for the KK pphoton) ON or OFF
55299 IF(IUED(2).EQ.0) CALL PYGIVE('MDCY(C5100022,1)=0')
55300
55301C...Calculated the radiative corrections to the KK particle masses
55302 CALL PYUEDC
55303
55304C...Initialize the graviton mass
55305C...only if the KK particles decays gravitationally
55306 IF(IUED(2).EQ.1) CALL PYGRAM(0)
55307
55308 WRITE(MSTU(11),7000)
55309 & '********** PYXDIN: UED initialization completed ***********'
55310
55311C...Format to use for comments
55312 7000 FORMAT(' * ',A)
55313
55314 RETURN
55315 END
55316C*********************************************************************
55317
55318C...PYUEDC
55319C...Auxiliary to PYXDIN
55320C...Mass kk states radiative corrections
55321C...Radiative corrections are included (hep/ph0204342)
55322
55323 SUBROUTINE PYUEDC
55324
55325C...Double precision and integer declarations.
55326 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55327 IMPLICIT INTEGER(I-N)
55328 INTEGER PYK,PYCHGE,PYCOMP
55329
55330 PARAMETER(KKPART=25,KKFLA=450)
55331
55332C...UED Pythia common
55333 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55334C...Pythia common: particles properties
55335 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55336C...Parameters.
55337 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55338C...Decay information.
55339 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
55340C...Resonance width and secondary decay treatment.
55341 COMMON/PYINT4/MWID(500),WIDS(500,5)
55342 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
55343
55344C...Local variables
55345 DOUBLE PRECISION PI,QUP,QDW
55346 DOUBLE PRECISION WDTP,WDTE
55347 DIMENSION WDTP(0:400),WDTE(0:400,0:5)
55348 DOUBLE PRECISION Q2,ALPHEM,ALPHS,SW2,CW2,RMKK,RMKK2,ZETA3
55349 DOUBLE PRECISION DSMG2,LOGLAM,DBMG2
55350 DOUBLE PRECISION DBMQU,DBMQD,DBMQDO,DBMLDO,DBMLE
55351 DOUBLE PRECISION DSMA2,DSMB2,DBMA2,DBMB2
55352 DOUBLE PRECISION RFACT,RMW,RMZ,RMZ2,RMW2,A,B,C,SQRDEL,DMB2,DMA2
55353 DOUBLE PRECISION SWW1,CWW1
55354 DOUBLE PRECISION RMGST,RMPHST,RMZST,RMWST
55355 DOUBLE PRECISION RMDQST,RMSQUS,RMSQDS,RMLSLD,RMLSLE
55356 DOUBLE PRECISION SW21,CW21,SW021,CW021
55357 COMMON/SW1/SW021,CW021
55358C...UED related declarations:
55359C...equivalences between ordered particles (451->475)
55360C...and UED particle code (5 000 000 + id)
55361 DIMENSION IUEDEQ(475)
55362 DATA (IUEDEQ(I),I=451,475)/
55363C...Singlet quarks
55364 & 6100001,6100002,6100003,6100004,6100005,6100006,
55365C...Doublet quarks
55366 & 5100001,5100002,5100003,5100004,5100005,5100006,
55367C...Singlet leptons
55368 & 6100011,6100013,6100015,
55369C...Doublet leptons
55370 & 5100012,5100011,5100014,5100013,5100016,5100015,
55371C...Gauge boson KK excitations
55372 & 5100021,5100022,5100023,5100024/
55373
55374C...N.B. rinv=rued(1)
55375 IF(RUED(1).LE.0.)THEN
55376 WRITE(MSTU(11),*) 'PYUEDC: RINV < 0 : ',RUED(1)
55377 WRITE(MSTU(11),*) 'DEFAULT KK STATE MASSES ARE TAKEN '
55378 RETURN
55379 ENDIF
55380
55381 PI=DACOS(-1.D0)
55382 RMZ = PMAS(23,1)
55383 RMZ2 = RMZ**2
55384 RMW = PMAS(24,1)
55385 RMW2 = RMW**2
55386 ALPHEM = PARU(101)
55387 QUP = 2./3.
55388 QDW = -1./3.
55389
55390c...qt is q-tilde, qs is q-star
55391c...strong coupling value
55392 Q2 = RUED(1)**2
55393 ALPHS=PYALPS(Q2)
55394
55395c...weak mixing angle
55396 SW2=PARU(102)
55397 CW2=1D0-PARU(102)
55398
55399c...for the mass corrections
55400 RMKK = RUED(1)
55401 RMKK2 = RMKK**2
55402 ZETA3= 1.2
55403
55404C... Either fix the cutoff scale LAMUED
55405 IF(IUED(5).EQ.0)THEN
55406 LOGLAM = DLOG((RUED(3)*(1./RUED(1)))**2)
55407C... or the ratio LAMUED/RINV (=product Lambda*R)
55408 ELSEIF(IUED(5).EQ.1)THEN
55409 LOGLAM = DLOG(RUED(4)**2)
55410 ELSE
55411 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(5)'
55412 CALL PYSTOP(6000)
55413 ENDIF
55414
55415C...Calculate the radiative corrections for the UED KK masses
55416 IF(IUED(6).EQ.1)THEN
55417 RFACT=1.D0
55418C...or induce a minute mass difference
55419C...keeping the UED KK mass values nearly equal to 1/R
55420 ELSEIF(IUED(6).EQ.0)THEN
55421 RFACT=0.01D0
55422 ELSE
55423 WRITE(MSTU(11),*) '(PYUEDC:) INVALID VALUE FOR IUED(6)'
55424 CALL PYSTOP(6001)
55425 ENDIF
55426
55427c...Take into account only the strong interactions:
55428
55429c...The space bulk corrections :
55430 DSMG2 = RMKK2*(-1.5)*(ALPHS/4./PI)*ZETA3/PI**2
55431c...The boundary terms:
55432 DBMG2 = RMKK2*(23./2.)*(ALPHS/4./PI)*LOGLAM
55433
55434c...Mass corrections for fermions are extracted from
55435c...Phys. Rev. D66 036005(2002)9
55436 DBMQDO=RMKK*(3.*(ALPHS/4./PI)+27./16.*(ALPHEM/4./PI/SW2)
55437 . +1./16.*(ALPHEM/4./PI/CW2))*LOGLAM
55438 DBMQU=RMKK*(3.*(ALPHS/4./PI)
55439 . +(ALPHEM/4./PI/CW2))*LOGLAM
55440 DBMQD=RMKK*(3.*(ALPHS/4./PI)
55441 . +0.25*(ALPHEM/4./PI/CW2))*LOGLAM
55442
55443 DBMLDO=RMKK *((27./16.)*(ALPHEM/4./PI/SW2)+9./16.*
55444 . (ALPHEM/4./PI/CW2))*LOGLAM
55445 DBMLE=RMKK *(9./4.*(ALPHEM/4./PI/CW2))*LOGLAM
55446
55447c...Vector boson masss matrix diagonalization
55448 DBMB2 = RMKK2*(-1./6.)*(ALPHEM/4./PI/CW2)*LOGLAM
55449 DSMB2 = RMKK2*(-39./2.)*(ALPHEM/4./PI**3/CW2)*ZETA3
55450 DBMA2 = RMKK2*(15./2.)*(ALPHEM/4./PI/SW2)*LOGLAM
55451 DSMA2 = RMKK2*(-5./2.)*(ALPHEM/4./PI**3/SW2)*ZETA3
55452
55453c...Elements of the mass matrix
55454 A = RMZ2*SW2 + DBMB2 + DSMB2
55455 B = RMZ2*CW2 + DBMA2 + DSMA2
55456 C = RMZ2*DSQRT(SW2*CW2)
55457 SQRDEL = DSQRT( (A-B)**2 + 4*C**2 )
55458
55459c...Eigenvalues: corrections to X1 and Z1 masses
55460 DMB2 = (A+B-SQRDEL)/2.
55461 DMA2 = (A+B+SQRDEL)/2.
55462
55463c...Rotation angles
55464 SWW1 = 2*C
55465 CWW1 = A-B-SQRDEL
55466C...Weinberg angle
55467 SW21= SWW1**2/(SWW1**2 + CWW1**2)
55468 CW21= 1. - SW21
55469
55470 SW021=SW21
55471 CW021=CW21
55472
55473c...Masses:
55474 RMGST = RMKK+RFACT*(DSQRT(RMKK2 + DSMG2 + DBMG2)-RMKK)
55475
55476 RMDQST=RMKK+RFACT*DBMQDO
55477 RMSQUS=RMKK+RFACT*DBMQU
55478 RMSQDS=RMKK+RFACT*DBMQD
55479
55480C...Note: MZ mass is included in ma2
55481 RMPHST= RMKK+RFACT*(DSQRT(RMKK2 + DMB2)-RMKK)
55482 RMZST = RMKK+RFACT*(DSQRT(RMKK2 + DMA2)-RMKK)
55483 RMWST = RMKK+RFACT*(DSQRT(RMKK2 + DBMA2 + DSMA2 + RMW**2)-RMKK)
55484
55485 RMLSLD=RMKK+RFACT*DBMLDO
55486 RMLSLE=RMKK+RFACT*DBMLE
55487
55488 DO 100 IPART=1,5,2
55489 PMAS(KKFLA+IPART,1)=RMSQDS
55490 100 CONTINUE
55491 DO 110 IPART=2,6,2
55492 PMAS(KKFLA+IPART,1)=RMSQUS
55493 110 CONTINUE
55494 DO 120 IPART=7,12
55495 PMAS(KKFLA+IPART,1)=RMDQST
55496 120 CONTINUE
55497 DO 130 IPART=13,15
55498 PMAS(KKFLA+IPART,1)=RMLSLE
55499 130 CONTINUE
55500 DO 140 IPART=16,21
55501 PMAS(KKFLA+IPART,1)=RMLSLD
55502 140 CONTINUE
55503 PMAS(KKFLA+22,1)=RMGST
55504 PMAS(KKFLA+23,1)=RMPHST
55505 PMAS(KKFLA+24,1)=RMZST
55506 PMAS(KKFLA+25,1)=RMWST
55507
55508 WRITE(MSTU(11),7000) ' PYUEDC: ',
55509 & 'UED Mass Spectrum (GeV) :'
55510 WRITE(MSTU(11),7100) ' m(d*_S,s*_S,b*_S) = ',RMSQDS
55511 WRITE(MSTU(11),7100) ' m(u*_S,c*_S,t*_S) = ',RMSQUS
55512 WRITE(MSTU(11),7100) ' m(q*_D) = ',RMDQST
55513 WRITE(MSTU(11),7100) ' m(l*_S) = ',RMLSLE
55514 WRITE(MSTU(11),7100) ' m(l*_D) = ',RMLSLD
55515 WRITE(MSTU(11),7100) ' m(g*) = ',RMGST
55516 WRITE(MSTU(11),7100) ' m(gamma*) = ',RMPHST
55517 WRITE(MSTU(11),7100) ' m(Z*) = ',RMZST
55518 WRITE(MSTU(11),7100) ' m(W*) = ',RMWST
55519 WRITE(MSTU(11),7000) ' '
55520
55521C...Initialize widths, branching ratios and life time
55522 DO 199 IPART=1,25
55523 KC=KKFLA+IPART
55524 IF(MWID(KC).EQ.1.AND.MDCY(KC,1).EQ.1)THEN
55525 CALL PYWIDT(IUEDEQ(KC),PMAS(KC,1)**2,WDTP,WDTE)
55526 IF(WDTP(0).LE.0)THEN
55527 WRITE(MSTU(11),*)
55528 + 'PYUEDC WARNING: TOTAL WIDTH = 0 --> KC ', KC
55529 WRITE(MSTU(11),*) 'INITIAL VALUE IS TAKEN',PMAS(KC,2)
55530 GOTO 199
55531 ELSE
55532 DO 180 IDC=1,MDCY(KC,3)
55533 IC=IDC+MDCY(KC,2)-1
55534 IF(MDME(IC,1).EQ.1.AND.WDTP(IDC).GT.0.)THEN
55535C...Life time in cm^{-1}. paru(3) gev^{-1} -> fm
55536 PMAS(KC,4)=PARU(3)/WDTP(IDC)*1.D-12
55537 BRAT(IC)=WDTP(IDC)/WDTP(0)
55538 ENDIF
55539 180 CONTINUE
55540 ENDIF
55541 ENDIF
55542 199 CONTINUE
55543
55544C...Format to use for comments
55545 7000 FORMAT(' * ',A)
55546 7100 FORMAT(' * ',A,F12.3)
55547
55548 END
55549C********************************************************************
55550C...PYXUED
55551C... Last change:
55552C... 13/01/2009 : H. Przysiezniak Frey, P. Skands
55553C... Original version:
55554C... M. El Kacimi
55555C... 05/07/2005
55556C Universal Extra Dimensions Subprocess cross sections
55557C The expressions used are from atl-com-phys-2005-003
55558C What is coded here is shat**2/pi * dsigma/dt = |M|**2
55559C For each UED subprocess, the color flow used is the same
55560C as the equivalent QCD subprocess. Different configuration
55561C color flows are considered to have the same probability.
55562C
55563C The Xsection is calculated following ATL-PHYS-PUB-2005-003
55564C by G.Azuelos and P.H.Beauchemin.
55565C
55566C This routine is called from pysigh.
55567
55568 SUBROUTINE PYXUED(NCHN,SIGS)
55569
55570C...Double precision and integer declarations
55571 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55572 IMPLICIT INTEGER(I-N)
55573C...
55574 INTEGER NGRDEC
55575 COMMON/DECMOD/NGRDEC
55576C...
55577 PARAMETER(KKPART=25,KKFLA=450)
55578C...Commonblocks
55579 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55580 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
55581 COMMON/PYINT1/MINT(400),VINT(400)
55582 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
55583 COMMON/PYSGCM/ISUB,ISUBSV,MMIN1,MMAX1,MMIN2,MMAX2,MMINA,MMAXA,
55584 &KFAC(2,-40:40),COMFAC,FACK,FACA,SH,TH,UH,SH2,TH2,UH2,SQM3,SQM4,
55585 &SHR,SQPTH,TAUP,BE34,CTH,X(2),SQMZ,SQMW,GMMZ,GMMW,
55586 &AEM,AS,XW,XW1,XWC,XWV,POLL,POLR,POLLL,POLRR
55587 SAVE /PYDAT2/,/PYINT1/,/PYINT3/,/PYPARS/
55588C...UED Pythia common
55589 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55590C...Local arrays and complex variables
55591 DOUBLE PRECISION SHAT,SP,THAT,TP,UHAT,UP,ALPHAS
55592 + ,FAC1,XMNKK,XMUED,SIGS
55593 INTEGER NCHN
55594
55595C...Return if UED not switched on
55596 IF (IUED(1).LE.0) THEN
55597 RETURN
55598 ENDIF
55599
55600C...Energy scale of the parton processus
55601C...taken equal to the mass of the final state kk
55602c Q2=XMNKK**2
55603
55604C...Default Mandlestam variable (u/t)hatp=(u/t)hatp-xmnkk**2
55605 XMNKK=PMAS(KKFLA+23,1)
55606
55607C...To compare the cross section with phys-pub-2005-03
55608C...(no radiative corrections),
55609C...take xmnkk=rinv and q2=rinv**2
55610c++lnk
55611C...n.b. (rinv=rued(1))
55612c IF(NGRDEC.EQ.1)XMNKK=RUED(0)
55613 IF(NGRDEC.EQ.1)XMNKK=RUED(1)
55614c--lnk
55615
55616 SHAT=VINT(44)
55617 SP=SHAT
55618 THAT=VINT(45)
55619 TP=THAT-XMNKK**2
55620 UHAT=VINT(46)
55621 UP=UHAT-XMNKK**2
55622 BETA34=DSQRT(1.D0-4.D0*XMNKK**2/SHAT)
55623 PI=DACOS(-1.D0)
55624c++lnk
55625c Q2=RUED(0)**2+(TP*UP-RUED(0)**4)/SP
55626 Q2=RUED(1)**2+(TP*UP-RUED(1)**4)/SP
55627
55628c IF(NGRDEC.EQ.1)Q2=RUED(0)**2
55629 IF(NGRDEC.EQ.1)Q2=RUED(1)**2
55630c--lnk
55631
55632C...Strong coupling value
55633 ALPHAS=PYALPS(Q2)
55634
55635 IF(ISUB.EQ.311)THEN
55636C...gg --> g* g*
55637 FAC1=9./8.*ALPHAS**2/(SP*TP*UP)**2
55638 XMUED=FAC1*(XMNKK**4*(6.*TP**4+18.*TP**3*UP+
55639 & 24.*TP**2*UP**2+18.*TP*UP**3+6.*UP**4)
55640 & +XMNKK**2*(6.*TP**4*UP+12.*TP**3*UP**2+
55641 & 12.*TP**2*UP**3+6*TP*UP**4)
55642 & +2.*TP**6+6*TP**5*UP+13*TP**4*UP**2+
55643 & 15.*TP**3*UP**3+13*TP**2*UP**4+
55644 & 6.*TP*UP**5+2.*UP**6)
55645 NCHN=NCHN+1
55646 ISIG(NCHN,1)=21
55647 ISIG(NCHN,2)=21
55648C...Three color flow configurations (qcd g+g->g+g)
55649 XCOL=PYR(0)
55650 IF(XCOL.LE.1./3.)THEN
55651 ISIG(NCHN,3)=1
55652 ELSEIF(XCOL.LE.2./3.)THEN
55653 ISIG(NCHN,3)=2
55654 ELSE
55655 ISIG(NCHN,3)=3
55656 ENDIF
55657 SIGH(NCHN)=COMFAC*XMUED
55658 ELSEIF(ISUB.EQ.312)THEN
55659C...q + g -> q*_D + g*, q*_S + g*
55660C...(the two channels have the same cross section)
55661 FAC1=-1./36.*ALPHAS**2/(SP*TP*UP)**2
55662 XMUED=FAC1*(12.*SP*UP**5+5.*SP**2*UP**4+22.*SP**3*UP**3+
55663 & 5.*SP**4*UP**2+12.*SP**5*UP)
55664 XMUED=COMFAC*2.*XMUED
55665
55666 DO 190 I=MMINA,MMAXA
55667 IF(I.EQ.0.OR.IABS(I).GT.10) GOTO 190
55668 DO 180 ISDE=1,2
55669
55670 IF(ISDE.EQ.1.AND.KFAC(1,I)*KFAC(2,21).EQ.0) GOTO 180
55671 IF(ISDE.EQ.2.AND.KFAC(1,21)*KFAC(2,I).EQ.0) GOTO 180
55672 NCHN=NCHN+1
55673 ISIG(NCHN,ISDE)=I
55674 ISIG(NCHN,3-ISDE)=21
55675 ISIG(NCHN,3)=1
55676 SIGH(NCHN)=XMUED
55677 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
55678 180 CONTINUE
55679 190 CONTINUE
55680
55681 ELSEIF(ISUB.EQ.313)THEN
55682C...qi + qj -> q*_Di + q*_Dj, q*_Si + q*_Sj
55683C...(the two channels have the same cross section)
55684C...qi and qj have the same charge sign
55685 DO 100 I=MMIN1,MMAX1
55686 IA=IABS(I)
55687 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 100
55688 DO 101 J=MMIN2,MMAX2
55689 JA=IABS(J)
55690 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).
55691 & EQ.0) GOTO 101
55692 IF(J*I.LE.0)GOTO 101
55693 NCHN=NCHN+1
55694 ISIG(NCHN,1)=I
55695 ISIG(NCHN,2)=J
55696 IF(J.EQ.I)THEN
55697 FAC1=1./72.*ALPHAS**2/(TP*UP)**2
55698 XMUED=FAC1*
55699 & (XMNKK**2*(8*TP**3+4./3.*TP**2*UP+4./3.*TP*UP**2
55700 & +8.*UP**3)+8.*TP**4+56./3.*TP**3*UP+
55701 & 20.*TP**2*UP**2+56./3.*
55702 & TP*UP**3+8.*UP**4)
55703 SIGH(NCHN)=COMFAC*2.*XMUED
55704 ISIG(NCHN,3)=1
55705 IF(PYR(0).GT.0.5)ISIG(NCHN,3)=2
55706 ELSE
55707 FAC1=2./9.*ALPHAS**2/TP**2
55708 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
55709 SIGH(NCHN)=COMFAC*2.*XMUED
55710 ISIG(NCHN,3)=1
55711 ENDIF
55712 101 CONTINUE
55713 100 CONTINUE
55714 ELSEIF(ISUB.EQ.314)THEN
55715C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
55716C...(the two channels have the same cross section)
55717 NCHN=NCHN+1
55718 ISIG(NCHN,1)=21
55719 ISIG(NCHN,2)=21
55720 ISIG(NCHN,3)=INT(1.5+PYR(0))
55721
55722 FAC1=5./6.*ALPHAS**2/(SP*TP*UP)**2
55723 XMUED=FAC1*(-XMNKK**4*(8.*TP*UP**3+8.*TP**2*UP**2+8.*TP**3*UP
55724 + +4.*UP**4+4*TP**4)
55725 + -XMNKK**2*(0.5*TP*UP**4+4.*TP**2*UP**3+15./2.*TP**3
55726 + *UP**2+ 4.*TP**4*UP)+TP*UP**5-0.25*TP**2*UP**4+
55727 + 2.*TP**3*UP**3-0.25*TP**4*UP**2+TP**5*UP)
55728
55729 SIGH(NCHN)=COMFAC*XMUED
55730C...has been multiplied by 5: all possible quark flavors in final state
55731
55732 ELSEIF(ISUB.EQ.315)THEN
55733C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
55734C...(the two channels have the same cross section)
55735 DO 141 I=MMIN1,MMAX1
55736 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
55737 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 141
55738 DO 142 J=MMIN2,MMAX2
55739 IF(J.EQ.0.OR.ABS(I).NE.ABS(J).OR.I*J.GE.0) GOTO 142
55740 FAC1=2./9.*ALPHAS**2*1./(SP*TP)**2
55741 XMUED=FAC1*(XMNKK**2*SP*(4.*TP**2-SP*TP-SP**2)+
55742 & 4.*TP**4+3.*SP*TP**3+11./12.*TP**2*SP**2-
55743 & 2./3.*SP**3*TP+SP**4)
55744 NCHN=NCHN+1
55745 ISIG(NCHN,1)=I
55746 ISIG(NCHN,2)=-I
55747 ISIG(NCHN,3)=1
55748 SIGH(NCHN)=COMFAC*2.*XMUED
55749 142 CONTINUE
55750 141 CONTINUE
55751 ELSEIF(ISUB.EQ.316)THEN
55752C...q + qbar' -> q*_D + q*_Sbar'
55753 FAC1=2./9.*ALPHAS**2
55754 DO 300 I=MMIN1,MMAX1
55755 IA=IABS(I)
55756 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 300
55757 DO 301 J=MMIN2,MMAX2
55758 JA=IABS(J)
55759 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 301
55760 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 301
55761 NCHN=NCHN+1
55762 ISIG(NCHN,1)=I
55763 ISIG(NCHN,2)=J
55764 ISIG(NCHN,3)=1
55765 FAC1=2./9.*ALPHAS**2/TP**2
55766 XMUED=FAC1*(-XMNKK**2*SP+SP**2+0.25*TP**2)
55767 SIGH(NCHN)=COMFAC*XMUED
55768 301 CONTINUE
55769 300 CONTINUE
55770
55771 ELSEIF(ISUB.EQ.317)THEN
55772C...q + qbar' -> q*_D + q*_Dbar' , q*_S + q*_Sbar'
55773C...(the two channels have the same cross section)
55774 DO 400 I=MMIN1,MMAX1
55775 IA=IABS(I)
55776 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 400
55777 DO 401 J=MMIN1,MMAX1
55778 JA=IABS(J)
55779 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 401
55780 IF(J*I.GE.0.OR.IA.EQ.JA)GOTO 401
55781 NCHN=NCHN+1
55782 ISIG(NCHN,1)=I
55783 ISIG(NCHN,2)=J
55784 ISIG(NCHN,3)=1
55785 FAC1=1./18.*ALPHAS**2/TP**2
55786 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
55787 SIGH(NCHN)=COMFAC*2.*XMUED
55788 401 CONTINUE
55789 400 CONTINUE
55790 ELSEIF(ISUB.EQ.318)THEN
55791C...q + q' -> q*_D + q*_S'
55792 DO 500 I=MMIN1,MMAX1
55793 IA=IABS(I)
55794 IF(I.EQ.0.OR.IA.GT.MSTP(58).OR.KFAC(1,I).EQ.0) GOTO 500
55795 DO 501 J=MMIN2,MMAX2
55796 JA=IABS(J)
55797 IF(J.EQ.0.OR.JA.GT.MSTP(58).OR.KFAC(2,J).EQ.0) GOTO 501
55798 IF(J*I.LE.0)GOTO 501
55799 IF(IA.EQ.JA)THEN
55800 NCHN=NCHN+1
55801 ISIG(NCHN,1)=I
55802 ISIG(NCHN,2)=J
55803 ISIG(NCHN,3)=INT(1.5+PYR(0))
55804 FAC1=1./36.*ALPHAS**2/(TP*UP)**2
55805 XMUED=FAC1*(-8.*XMNKK**2*(TP**3+TP**2*UP+TP*UP**2+UP**3)
55806 & +8.*TP**4+4.*TP**2*UP**2+8.*UP**4)
55807 SIGH(NCHN)=COMFAC*XMUED
55808 ELSE
55809 NCHN=NCHN+1
55810 ISIG(NCHN,1)=I
55811 ISIG(NCHN,2)=J
55812 ISIG(NCHN,3)=1
55813 FAC1=1./18.*ALPHAS**2/TP**2
55814 XMUED=FAC1*(4.*XMNKK**2*SP+4.*SP**2+8.*SP*TP+5*TP**2)
55815 SIGH(NCHN)=COMFAC*2.*XMUED
55816 ENDIF
55817 501 CONTINUE
55818 500 CONTINUE
55819 ELSEIF(ISUB.EQ.319)THEN
55820C...q + qbar -> q*_D' +q*_Dbar' , q*_S' + q*_Sbar'
55821C...(the two channels have the same cross section)
55822 DO 741 I=MMIN1,MMAX1
55823 IF(I.EQ.0.OR.IABS(I).GT.MSTP(58).OR.
55824 & KFAC(1,I)*KFAC(2,-I).EQ.0) GOTO 741
55825 DO 742 J=MMIN2,MMAX2
55826 IF(J.EQ.0.OR.IABS(J).NE.IABS(I).OR.J*I.GT.0) GOTO 742
55827 FAC1=16./9.*ALPHAS**2*1./(SP)**2
55828 XMUED=FAC1*(2.*XMNKK**2*SP+SP**2+2.*SP*TP+2.*TP**2)
55829 NCHN=NCHN+1
55830 ISIG(NCHN,1)=I
55831 ISIG(NCHN,2)=-I
55832 ISIG(NCHN,3)=1
55833 SIGH(NCHN)=COMFAC*2.*XMUED
55834 742 CONTINUE
55835 741 CONTINUE
55836
55837 ENDIF
55838
55839 RETURN
55840 END
55841C*********************************************************************
55842
55843C...PYGRAM
55844C...Universal Extra Dimensions Model (UED)
55845C...Computation of the Graviton mass.
55846
55847 SUBROUTINE PYGRAM(IN)
55848
55849C...Double precision and integer declarations
55850 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
55851 IMPLICIT INTEGER(I-N)
55852
55853C...Pythia commonblocks
55854 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55855 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
55856C...UED Pythia common
55857 COMMON/PYPUED/IUED(0:99),RUED(0:99)
55858
55859C...Local variables
55860 INTEGER KCFLA,NMAX
55861 PARAMETER(KCFLA=450,NMAX=5000)
55862 DIMENSION YVEC(5000),RESVEC(5000)
55863 COMMON/INTSAV/YSAV,YMAX,RESMAX
55864 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55865 COMMON/KAPPA/XKAPPA
55866
55867C...External function (used in call to PYGAUS)
55868 EXTERNAL PYGRAW
55869
55870C...SAVE statements
55871 SAVE /PYDAT1/,/PYDAT2/,/PYPUED/,/INTSAV/
55872
55873C...Initialization
55874 NDIM=IUED(4)
55875 RINV=RUED(1)
55876 XMD=RUED(2)
55877 PI=PARU(1)
55878
55879C...Initialize for numerical integration
55880 XMPLNK=2.4D+18
55881 XKAPPA=DSQRT(2.D0)/XMPLNK
55882
55883C...For NDIM=2, compute graviton mass distribution numerically
55884 IF(NDIM.EQ.2)THEN
55885
55886C... For first event: tabulate distribution of stepwise integrals:
55887C... int_y1^y2 dy dGamma/dy , with y = MG*/MgammaKK
55888 IF(IN.EQ.0)THEN
55889 RESMAX = 0D0
55890 YMAX = 0D0
55891 DO 100 I=1,NMAX
55892 YSAV = (I-0.5)/DBLE(NMAX)
55893 TOL = 1D-6
55894C...Integral of PYGRAW from 0 to 1, with precision TOL, for given YSAV
55895 RESINT = PYGAUS(PYGRAW,0D0,1D0,TOL)
55896 YVEC(I) = YSAV
55897 RESVEC(I) = RESINT
55898C... Save max of distribution (for accept/reject below)
55899 IF(RESINT.GT.RESMAX)THEN
55900 RESMAX = RESINT
55901 YMAX = YVEC(I)
55902 ENDIF
55903 100 CONTINUE
55904 ENDIF
55905
55906C... Generate Mg for each graviton (1D0 ensures a minimal open phase space)
55907 PCUJET=1D0
55908 KCGAKK=KCFLA+23
55909 XMGAMK=PMAS(KCGAKK,1)
55910
55911C... Pick random graviton mass, accept according to stored integrals
55912 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55913 110 RMG=AMMAX*PYR(0)
55914 X=RMG/XMGAMK
55915
55916C... Bin enumeration starts at 1, but make sure always in range
55917 IBIN=INT(NMAX*X)+1
55918 IBIN=MIN(IBIN,NMAX)
55919 IF(RESVEC(IBIN)/RESMAX.LT.PYR(0)) GOTO 110
55920
55921C... For NDIM=4 and 6, the analytical expression for the
55922C... graviton mass distribution integral is used.
55923 ELSEIF(NDIM.EQ.4.OR.NDIM.EQ.6)THEN
55924
55925C... Ensure minimal open phase space (max(mG*) < m(gamma*))
55926 PCUJET=1D0
55927
55928C... KK photon (?) compressed code and mass
55929 KCGAKK=KCFLA+23
55930 XMGAMK=PMAS(KCGAKK,1)
55931
55932C... Find maximum of (dGamma/dMg)
55933 IF(IN.EQ.0)THEN
55934 RESMAX=0D0
55935 YMAX=0D0
55936 DO 120 I=1,NMAX-1
55937 Y=I/DBLE(NMAX)
55938 RESINT=Y**(NDIM-3)*(1D0/(1D0-Y**2))*(1D0+DCOS(PI*Y))
55939 IF(RESINT.GE.RESMAX)THEN
55940 RESMAX=RESINT
55941 YMAX=Y
55942 ENDIF
55943 120 CONTINUE
55944 ENDIF
55945
55946C... Pick random graviton mass, accept/reject
55947 AMMAX=DSQRT(XMGAMK**2-2D0*XMGAMK*PCUJET)
55948 130 RMG=AMMAX*PYR(0)
55949 X=RMG/XMGAMK
55950 DGADMG=X**(NDIM-3)*(1./(1.-X**2))*(1.+DCOS(PI*X))
55951 IF(DGADMG/RESMAX.LT.PYR(0)) GOTO 130
55952
55953C... If the user has not chosen N=2,4 or 6, STOP
55954 ELSE
55955 WRITE(MSTU(11),*) '(PYGRAM:) BAD VALUE N(LARGE XD) =',NDIM,
55956 & ' (MUST BE 2, 4, OR 6) '
55957 CALL PYSTOP(6002)
55958 ENDIF
55959
55960C... Now store the sampled Mg
55961 PMAS(39,1)=RMG
55962
55963 RETURN
55964 END
55965
55966C*********************************************************************
55967
55968C...PYGRAW
55969C...Universal Extra Dimensions Model (UED)
55970C...
55971C...See Macesanu etal. hep-ph/0201300 eqns.31 and 34.
55972C...
55973C...Integrand for the KK boson -> SM boson + graviton
55974C...graviton mass distribution (and gravity mediated total width),
55975C...which contains (see 0201300 and below for the full product)
55976C...the gravity mediated partial decay width Gamma(xx, yy)
55977C... i.e. GRADEN(YY)*PYWDKK(XXA)
55978C... where xx is exclusive to gravity
55979C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
55980C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions.
55981
55982 DOUBLE PRECISION FUNCTION PYGRAW(YIN)
55983
55984C...Double precision and integer declarations
55985 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
55986 IMPLICIT INTEGER (I-N)
55987
55988C...Pythia commonblocks
55989 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
55990
55991C...Local UED commonblocks and variables
55992 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
55993 COMMON/INTSAV/YSAV,YMAX,RESMAX
55994
55995C...SAVE statements
55996 SAVE /PYDAT1/,/INTSAV/
55997
55998C...External: Pythia's Gamma function
55999 EXTERNAL PYGAMM
56000
56001C...Pi
56002 PI=PARU(1)
56003 PI2=PI*PI
56004
56005 YMIN=1.D-9/RINV
56006 YY=YSAV
56007 XX=DSQRT(1.-YY**2)*YIN
56008 DJAC=(1.-YMIN)*DSQRT(1.-YY**2)
56009 FAC=2.*PI**((NDIM-1.)/2.)*XMPLNK**2*RINV**NDIM/XMD**(NDIM+2)
56010 XND=(NDIM-1.)/2.
56011 GAMMN=PYGAMM(XND)
56012 FAC=FAC/GAMMN
56013 XXA=DSQRT(XX**2+YY**2)
56014 GRADEN=4./PI2 * (YY**2/(1.-YY**2)**2)*(1.+DCOS(PI*YY))
56015
56016 PYGRAW=DJAC*
56017 + FAC*XX**(NDIM-2)*GRADEN*PYWDKK(XXA)
56018
56019 RETURN
56020 END
56021C*********************************************************************
56022
56023C...PYWDKK
56024C...Universal Extra Dimensions Model (UED)
56025C...
56026C...Multiplied by the square modulus of a form factor
56027C...(see GRADEN in function PYGRAW)
56028C...PYWDKK is the KK boson -> SM boson + graviton
56029C...gravity mediated partial decay width Gamma(xx, yy)
56030C... where xx is exclusive to gravity
56031C... yy=m_Graviton/m_bosonKK denotes the Universal extra dimension
56032C... and xxa=sqrt(xx**2+yy**2) refers to all of the extra dimensions
56033C...
56034C...N.B. The Feynman rules for the couplings of the graviton fields
56035C...to the UED fields are related to the corresponding couplings of
56036C...the graviton fields to the SM fields by the form factor.
56037
56038 DOUBLE PRECISION FUNCTION PYWDKK(X)
56039
56040C...Double precision and integer declarations
56041 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
56042 IMPLICIT INTEGER (I-N)
56043
56044C...Pythia commonblocks
56045 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
56046 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
56047
56048C...Local UED commonblocks and variables
56049 COMMON/UEDGRA/XMPLNK,XMD,RINV,NDIM
56050 COMMON/KAPPA/XKAPPA
56051
56052C...SAVE statements
56053 SAVE /PYDAT1/,/PYDAT2/,/UEDGRA/,/KAPPA/
56054
56055 PI=PARU(1)
56056
56057C...gamma* mass 473
56058 KCQKK=473
56059 XMNKK=PMAS(KCQKK,1)
56060
56061C...Bosons partial width Macesanu hep-ph/0201300
56062 PYWDKK=XKAPPA**2/(96.*PI)*XMNKK**3/X**4*
56063 + ((1.-X**2)**2*(1.+3.*X**2+6.*X**4))
56064
56065 RETURN
56066 END
56067
56068C*********************************************************************
56069
56070C...PYEIGC
56071C...Finds eigenvalues of a general complex matrix
56072C
56073C THIS SUBROUTINE CALLS THE RECOMMENDED SEQUENCE OF
56074C SUBROUTINES FROM THE EIGENSYSTEM SUBROUTINE PACKAGE (EISPACK)
56075C TO FIND THE EIGENVALUES AND EIGENVECTORS (IF DESIRED)
56076C OF A COMPLEX GENERAL MATRIX.
56077C
56078C ON INPUT
56079C
56080C NM MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL
56081C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56082C DIMENSION STATEMENT.
56083C
56084C N IS THE ORDER OF THE MATRIX A=(AR,AI).
56085C
56086C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56087C RESPECTIVELY, OF THE COMPLEX GENERAL MATRIX.
56088C
56089C MATZ IS AN INTEGER VARIABLE SET EQUAL TO ZERO IF
56090C ONLY EIGENVALUES ARE DESIRED. OTHERWISE IT IS SET TO
56091C ANY NON-ZERO INTEGER FOR BOTH EIGENVALUES AND EIGENVECTORS.
56092C
56093C ON OUTPUT
56094C
56095C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
56096C RESPECTIVELY, OF THE EIGENVALUES.
56097C
56098C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56099C RESPECTIVELY, OF THE EIGENVECTORS IF MATZ IS NOT ZERO.
56100C
56101C IERR IS AN INTEGER OUTPUT VARIABLE SET EQUAL TO AN ERROR
56102C COMPLETION CODE DESCRIBED IN THE DOCUMENTATION FOR COMQR
56103C AND COMQR2. THE NORMAL COMPLETION CODE IS ZERO.
56104C
56105C FV1, FV2, AND FV3 ARE TEMPORARY STORAGE ARRAYS.
56106C
56107C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56108C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56109C
56110C THIS VERSION DATED AUGUST 1983.
56111C
56112
56113 SUBROUTINE PYEICG(NM,N,AR,AI,WR,WI,MATZ,ZR,ZI,FV1,FV2,FV3,IERR)
56114
56115 INTEGER N,NM,IS1,IS2,IERR,MATZ
56116 DOUBLE PRECISION AR(5,5),AI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
56117 X FV1(5),FV2(5),FV3(5)
56118 IF (N .LE. NM) GOTO 100
56119 IERR = 10 * N
56120 GOTO 120
56121C
56122 100 CALL PYCBAL(NM,N,AR,AI,IS1,IS2,FV1)
56123 CALL PYCRTH(NM,N,IS1,IS2,AR,AI,FV2,FV3)
56124 IF (MATZ .NE. 0) GOTO 110
56125C .......... FIND EIGENVALUES ONLY ..........
56126 CALL PYCMQR(NM,N,IS1,IS2,AR,AI,WR,WI,IERR)
56127 GOTO 120
56128C .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
56129 110 CALL PYCMQ2(NM,N,IS1,IS2,FV2,FV3,AR,AI,WR,WI,ZR,ZI,IERR)
56130 IF (IERR .NE. 0) GOTO 120
56131 CALL PYCBA2(NM,N,IS1,IS2,FV1,N,ZR,ZI)
56132 120 RETURN
56133 END
56134
56135C*********************************************************************
56136
56137C...PYCMQR
56138C...Auxiliary to PYEICG.
56139C
56140C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
56141C ALGOL PROCEDURE COMLR, NUM. MATH. 12, 369-376(1968) BY MARTIN
56142C AND WILKINSON.
56143C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 396-403(1971).
56144C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
56145C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
56146C
56147C THIS SUBROUTINE FINDS THE EIGENVALUES OF A COMPLEX
56148C UPPER HESSENBERG MATRIX BY THE QR METHOD.
56149C
56150C ON INPUT
56151C
56152C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56153C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56154C DIMENSION STATEMENT.
56155C
56156C N IS THE ORDER OF THE MATRIX.
56157C
56158C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56159C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56160C SET LOW=1, IGH=N.
56161C
56162C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
56163C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
56164C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN
56165C INFORMATION ABOUT THE UNITARY TRANSFORMATIONS USED IN
56166C THE REDUCTION BY CORTH, IF PERFORMED.
56167C
56168C ON OUTPUT
56169C
56170C THE UPPER HESSENBERG PORTIONS OF HR AND HI HAVE BEEN
56171C DESTROYED. THEREFORE, THEY MUST BE SAVED BEFORE
56172C CALLING COMQR IF SUBSEQUENT CALCULATION OF
56173C EIGENVECTORS IS TO BE PERFORMED.
56174C
56175C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
56176C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
56177C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
56178C FOR INDICES IERR+1,...,N.
56179C
56180C IERR IS SET TO
56181C ZERO FOR NORMAL RETURN,
56182C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
56183C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
56184C
56185C CALLS PYCDIV FOR COMPLEX DIVISION.
56186C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
56187C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56188C
56189C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56190C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56191C
56192C THIS VERSION DATED AUGUST 1983.
56193C
56194
56195 SUBROUTINE PYCMQR(NM,N,LOW,IGH,HR,HI,WR,WI,IERR)
56196
56197 INTEGER I,J,L,N,EN,LL,NM,IGH,ITN,ITS,LOW,LP1,ENM1,IERR
56198 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5)
56199 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
56200 X PYTHAG
56201
56202 IERR = 0
56203 IF (LOW .EQ. IGH) GOTO 130
56204C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
56205 L = LOW + 1
56206C
56207 DO 120 I = L, IGH
56208 LL = MIN0(I+1,IGH)
56209 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 120
56210 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
56211 YR = HR(I,I-1) / NORM
56212 YI = HI(I,I-1) / NORM
56213 HR(I,I-1) = NORM
56214 HI(I,I-1) = 0.0D0
56215C
56216 DO 100 J = I, IGH
56217 SI = YR * HI(I,J) - YI * HR(I,J)
56218 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
56219 HI(I,J) = SI
56220 100 CONTINUE
56221C
56222 DO 110 J = LOW, LL
56223 SI = YR * HI(J,I) + YI * HR(J,I)
56224 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
56225 HI(J,I) = SI
56226 110 CONTINUE
56227C
56228 120 CONTINUE
56229C .......... STORE ROOTS ISOLATED BY CBAL ..........
56230 130 DO 140 I = 1, N
56231 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
56232 WR(I) = HR(I,I)
56233 WI(I) = HI(I,I)
56234 140 CONTINUE
56235C
56236 EN = IGH
56237 TR = 0.0D0
56238 TI = 0.0D0
56239 ITN = 30*N
56240C .......... SEARCH FOR NEXT EIGENVALUE ..........
56241 150 IF (EN .LT. LOW) GOTO 320
56242 ITS = 0
56243 ENM1 = EN - 1
56244C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
56245C FOR L=EN STEP -1 UNTIL LOW D0 -- ..........
56246 160 DO 170 LL = LOW, EN
56247 L = EN + LOW - LL
56248 IF (L .EQ. LOW) GOTO 180
56249 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
56250 X + DABS(HR(L,L)) + DABS(HI(L,L))
56251 TST2 = TST1 + DABS(HR(L,L-1))
56252 IF (TST2 .EQ. TST1) GOTO 180
56253 170 CONTINUE
56254C .......... FORM SHIFT ..........
56255 180 IF (L .EQ. EN) GOTO 300
56256 IF (ITN .EQ. 0) GOTO 310
56257 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 200
56258 SR = HR(EN,EN)
56259 SI = HI(EN,EN)
56260 XR = HR(ENM1,EN) * HR(EN,ENM1)
56261 XI = HI(ENM1,EN) * HR(EN,ENM1)
56262 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 210
56263 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
56264 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
56265 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
56266 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 190
56267 ZZR = -ZZR
56268 ZZI = -ZZI
56269 190 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
56270 SR = SR - XR
56271 SI = SI - XI
56272 GOTO 210
56273C .......... FORM EXCEPTIONAL SHIFT ..........
56274 200 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
56275 SI = 0.0D0
56276C
56277 210 DO 220 I = LOW, EN
56278 HR(I,I) = HR(I,I) - SR
56279 HI(I,I) = HI(I,I) - SI
56280 220 CONTINUE
56281C
56282 TR = TR + SR
56283 TI = TI + SI
56284 ITS = ITS + 1
56285 ITN = ITN - 1
56286C .......... REDUCE TO TRIANGLE (ROWS) ..........
56287 LP1 = L + 1
56288C
56289 DO 240 I = LP1, EN
56290 SR = HR(I,I-1)
56291 HR(I,I-1) = 0.0D0
56292 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
56293 XR = HR(I-1,I-1) / NORM
56294 WR(I-1) = XR
56295 XI = HI(I-1,I-1) / NORM
56296 WI(I-1) = XI
56297 HR(I-1,I-1) = NORM
56298 HI(I-1,I-1) = 0.0D0
56299 HI(I,I-1) = SR / NORM
56300C
56301 DO 230 J = I, EN
56302 YR = HR(I-1,J)
56303 YI = HI(I-1,J)
56304 ZZR = HR(I,J)
56305 ZZI = HI(I,J)
56306 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
56307 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
56308 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
56309 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
56310 230 CONTINUE
56311C
56312 240 CONTINUE
56313C
56314 SI = HI(EN,EN)
56315 IF (SI .EQ. 0.0D0) GOTO 250
56316 NORM = PYTHAG(HR(EN,EN),SI)
56317 SR = HR(EN,EN) / NORM
56318 SI = SI / NORM
56319 HR(EN,EN) = NORM
56320 HI(EN,EN) = 0.0D0
56321C .......... INVERSE OPERATION (COLUMNS) ..........
56322 250 DO 280 J = LP1, EN
56323 XR = WR(J-1)
56324 XI = WI(J-1)
56325C
56326 DO 270 I = L, J
56327 YR = HR(I,J-1)
56328 YI = 0.0D0
56329 ZZR = HR(I,J)
56330 ZZI = HI(I,J)
56331 IF (I .EQ. J) GOTO 260
56332 YI = HI(I,J-1)
56333 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
56334 260 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
56335 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
56336 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
56337 270 CONTINUE
56338C
56339 280 CONTINUE
56340C
56341 IF (SI .EQ. 0.0D0) GOTO 160
56342C
56343 DO 290 I = L, EN
56344 YR = HR(I,EN)
56345 YI = HI(I,EN)
56346 HR(I,EN) = SR * YR - SI * YI
56347 HI(I,EN) = SR * YI + SI * YR
56348 290 CONTINUE
56349C
56350 GOTO 160
56351C .......... A ROOT FOUND ..........
56352 300 WR(EN) = HR(EN,EN) + TR
56353 WI(EN) = HI(EN,EN) + TI
56354 EN = ENM1
56355 GOTO 150
56356C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
56357C CONVERGED AFTER 30*N ITERATIONS ..........
56358 310 IERR = EN
56359 320 RETURN
56360 END
56361
56362C*********************************************************************
56363
56364C...PYCMQ2
56365C...Auxiliary to PYEICG.
56366C
56367C THIS SUBROUTINE IS A TRANSLATION OF A UNITARY ANALOGUE OF THE
56368C ALGOL PROCEDURE COMLR2, NUM. MATH. 16, 181-204(1970) BY PETERS
56369C AND WILKINSON.
56370C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 372-395(1971).
56371C THE UNITARY ANALOGUE SUBSTITUTES THE QR ALGORITHM OF FRANCIS
56372C (COMP. JOUR. 4, 332-345(1962)) FOR THE LR ALGORITHM.
56373C
56374C THIS SUBROUTINE FINDS THE EIGENVALUES AND EIGENVECTORS
56375C OF A COMPLEX UPPER HESSENBERG MATRIX BY THE QR
56376C METHOD. THE EIGENVECTORS OF A COMPLEX GENERAL MATRIX
56377C CAN ALSO BE FOUND IF CORTH HAS BEEN USED TO REDUCE
56378C THIS GENERAL MATRIX TO HESSENBERG FORM.
56379C
56380C ON INPUT
56381C
56382C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56383C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56384C DIMENSION STATEMENT.
56385C
56386C N IS THE ORDER OF THE MATRIX.
56387C
56388C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
56389C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
56390C SET LOW=1, IGH=N.
56391C
56392C ORTR AND ORTI CONTAIN INFORMATION ABOUT THE UNITARY TRANS-
56393C FORMATIONS USED IN THE REDUCTION BY CORTH, IF PERFORMED.
56394C ONLY ELEMENTS LOW THROUGH IGH ARE USED. IF THE EIGENVECTORS
56395C OF THE HESSENBERG MATRIX ARE DESIRED, SET ORTR(J) AND
56396C ORTI(J) TO 0.0D0 FOR THESE ELEMENTS.
56397C
56398C HR AND HI CONTAIN THE REAL AND IMAGINARY PARTS,
56399C RESPECTIVELY, OF THE COMPLEX UPPER HESSENBERG MATRIX.
56400C THEIR LOWER TRIANGLES BELOW THE SUBDIAGONAL CONTAIN FURTHER
56401C INFORMATION ABOUT THE TRANSFORMATIONS WHICH WERE USED IN THE
56402C REDUCTION BY CORTH, IF PERFORMED. IF THE EIGENVECTORS OF
56403C THE HESSENBERG MATRIX ARE DESIRED, THESE ELEMENTS MAY BE
56404C ARBITRARY.
56405C
56406C ON OUTPUT
56407C
56408C ORTR, ORTI, AND THE UPPER HESSENBERG PORTIONS OF HR AND HI
56409C HAVE BEEN DESTROYED.
56410C
56411C WR AND WI CONTAIN THE REAL AND IMAGINARY PARTS,
56412C RESPECTIVELY, OF THE EIGENVALUES. IF AN ERROR
56413C EXIT IS MADE, THE EIGENVALUES SHOULD BE CORRECT
56414C FOR INDICES IERR+1,...,N.
56415C
56416C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
56417C RESPECTIVELY, OF THE EIGENVECTORS. THE EIGENVECTORS
56418C ARE UNNORMALIZED. IF AN ERROR EXIT IS MADE, NONE OF
56419C THE EIGENVECTORS HAS BEEN FOUND.
56420C
56421C IERR IS SET TO
56422C ZERO FOR NORMAL RETURN,
56423C J IF THE LIMIT OF 30*N ITERATIONS IS EXHAUSTED
56424C WHILE THE J-TH EIGENVALUE IS BEING SOUGHT.
56425C
56426C CALLS PYCDIV FOR COMPLEX DIVISION.
56427C CALLS PYCSRT FOR COMPLEX SQUARE ROOT.
56428C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
56429C
56430C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56431C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56432C
56433C THIS VERSION DATED OCTOBER 1989.
56434C
56435C MESHED OVERFLOW CONTROL WITH VECTORS OF ISOLATED ROOTS (10/19/89 BSG)
56436C MESHED OVERFLOW CONTROL WITH TRIANGULAR MULTIPLY (10/30/89 BSG)
56437C
56438
56439 SUBROUTINE PYCMQ2(NM,N,LOW,IGH,ORTR,ORTI,HR,HI,WR,WI,ZR,ZI,IERR)
56440
56441 INTEGER I,J,K,L,M,N,EN,II,JJ,LL,NM,NN,IGH,IP1,
56442 X ITN,ITS,LOW,LP1,ENM1,IEND,IERR
56443 DOUBLE PRECISION HR(5,5),HI(5,5),WR(5),WI(5),ZR(5,5),ZI(5,5),
56444 X ORTR(5),ORTI(5)
56445 DOUBLE PRECISION SI,SR,TI,TR,XI,XR,YI,YR,ZZI,ZZR,NORM,TST1,TST2,
56446 X PYTHAG
56447
56448 IERR = 0
56449C .......... INITIALIZE EIGENVECTOR MATRIX ..........
56450 DO 110 J = 1, N
56451C
56452 DO 100 I = 1, N
56453 ZR(I,J) = 0.0D0
56454 ZI(I,J) = 0.0D0
56455 100 CONTINUE
56456 ZR(J,J) = 1.0D0
56457 110 CONTINUE
56458C .......... FORM THE MATRIX OF ACCUMULATED TRANSFORMATIONS
56459C FROM THE INFORMATION LEFT BY CORTH ..........
56460 IEND = IGH - LOW - 1
56461 IF (IEND.LT.0) GOTO 220
56462 IF (IEND.EQ.0) GOTO 170
56463C .......... FOR I=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
56464 DO 160 II = 1, IEND
56465 I = IGH - II
56466 IF (ORTR(I) .EQ. 0.0D0 .AND. ORTI(I) .EQ. 0.0D0) GOTO 160
56467 IF (HR(I,I-1) .EQ. 0.0D0 .AND. HI(I,I-1) .EQ. 0.0D0) GOTO 160
56468C .......... NORM BELOW IS NEGATIVE OF H FORMED IN CORTH ..........
56469 NORM = HR(I,I-1) * ORTR(I) + HI(I,I-1) * ORTI(I)
56470 IP1 = I + 1
56471C
56472 DO 120 K = IP1, IGH
56473 ORTR(K) = HR(K,I-1)
56474 ORTI(K) = HI(K,I-1)
56475 120 CONTINUE
56476C
56477 DO 150 J = I, IGH
56478 SR = 0.0D0
56479 SI = 0.0D0
56480C
56481 DO 130 K = I, IGH
56482 SR = SR + ORTR(K) * ZR(K,J) + ORTI(K) * ZI(K,J)
56483 SI = SI + ORTR(K) * ZI(K,J) - ORTI(K) * ZR(K,J)
56484 130 CONTINUE
56485C
56486 SR = SR / NORM
56487 SI = SI / NORM
56488C
56489 DO 140 K = I, IGH
56490 ZR(K,J) = ZR(K,J) + SR * ORTR(K) - SI * ORTI(K)
56491 ZI(K,J) = ZI(K,J) + SR * ORTI(K) + SI * ORTR(K)
56492 140 CONTINUE
56493C
56494 150 CONTINUE
56495C
56496 160 CONTINUE
56497C .......... CREATE REAL SUBDIAGONAL ELEMENTS ..........
56498 170 L = LOW + 1
56499C
56500 DO 210 I = L, IGH
56501 LL = MIN0(I+1,IGH)
56502 IF (HI(I,I-1) .EQ. 0.0D0) GOTO 210
56503 NORM = PYTHAG(HR(I,I-1),HI(I,I-1))
56504 YR = HR(I,I-1) / NORM
56505 YI = HI(I,I-1) / NORM
56506 HR(I,I-1) = NORM
56507 HI(I,I-1) = 0.0D0
56508C
56509 DO 180 J = I, N
56510 SI = YR * HI(I,J) - YI * HR(I,J)
56511 HR(I,J) = YR * HR(I,J) + YI * HI(I,J)
56512 HI(I,J) = SI
56513 180 CONTINUE
56514C
56515 DO 190 J = 1, LL
56516 SI = YR * HI(J,I) + YI * HR(J,I)
56517 HR(J,I) = YR * HR(J,I) - YI * HI(J,I)
56518 HI(J,I) = SI
56519 190 CONTINUE
56520C
56521 DO 200 J = LOW, IGH
56522 SI = YR * ZI(J,I) + YI * ZR(J,I)
56523 ZR(J,I) = YR * ZR(J,I) - YI * ZI(J,I)
56524 ZI(J,I) = SI
56525 200 CONTINUE
56526C
56527 210 CONTINUE
56528C .......... STORE ROOTS ISOLATED BY CBAL ..........
56529 220 DO 230 I = 1, N
56530 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 230
56531 WR(I) = HR(I,I)
56532 WI(I) = HI(I,I)
56533 230 CONTINUE
56534C
56535 EN = IGH
56536 TR = 0.0D0
56537 TI = 0.0D0
56538 ITN = 30*N
56539C .......... SEARCH FOR NEXT EIGENVALUE ..........
56540 240 IF (EN .LT. LOW) GOTO 430
56541 ITS = 0
56542 ENM1 = EN - 1
56543C .......... LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT
56544C FOR L=EN STEP -1 UNTIL LOW DO -- ..........
56545 250 DO 260 LL = LOW, EN
56546 L = EN + LOW - LL
56547 IF (L .EQ. LOW) GOTO 270
56548 TST1 = DABS(HR(L-1,L-1)) + DABS(HI(L-1,L-1))
56549 X + DABS(HR(L,L)) + DABS(HI(L,L))
56550 TST2 = TST1 + DABS(HR(L,L-1))
56551 IF (TST2 .EQ. TST1) GOTO 270
56552 260 CONTINUE
56553C .......... FORM SHIFT ..........
56554 270 IF (L .EQ. EN) GOTO 420
56555 IF (ITN .EQ. 0) GOTO 550
56556 IF (ITS .EQ. 10 .OR. ITS .EQ. 20) GOTO 290
56557 SR = HR(EN,EN)
56558 SI = HI(EN,EN)
56559 XR = HR(ENM1,EN) * HR(EN,ENM1)
56560 XI = HI(ENM1,EN) * HR(EN,ENM1)
56561 IF (XR .EQ. 0.0D0 .AND. XI .EQ. 0.0D0) GOTO 300
56562 YR = (HR(ENM1,ENM1) - SR) / 2.0D0
56563 YI = (HI(ENM1,ENM1) - SI) / 2.0D0
56564 CALL PYCSRT(YR**2-YI**2+XR,2.0D0*YR*YI+XI,ZZR,ZZI)
56565 IF (YR * ZZR + YI * ZZI .GE. 0.0D0) GOTO 280
56566 ZZR = -ZZR
56567 ZZI = -ZZI
56568 280 CALL PYCDIV(XR,XI,YR+ZZR,YI+ZZI,XR,XI)
56569 SR = SR - XR
56570 SI = SI - XI
56571 GOTO 300
56572C .......... FORM EXCEPTIONAL SHIFT ..........
56573 290 SR = DABS(HR(EN,ENM1)) + DABS(HR(ENM1,EN-2))
56574 SI = 0.0D0
56575C
56576 300 DO 310 I = LOW, EN
56577 HR(I,I) = HR(I,I) - SR
56578 HI(I,I) = HI(I,I) - SI
56579 310 CONTINUE
56580C
56581 TR = TR + SR
56582 TI = TI + SI
56583 ITS = ITS + 1
56584 ITN = ITN - 1
56585C .......... REDUCE TO TRIANGLE (ROWS) ..........
56586 LP1 = L + 1
56587C
56588 DO 330 I = LP1, EN
56589 SR = HR(I,I-1)
56590 HR(I,I-1) = 0.0D0
56591 NORM = PYTHAG(PYTHAG(HR(I-1,I-1),HI(I-1,I-1)),SR)
56592 XR = HR(I-1,I-1) / NORM
56593 WR(I-1) = XR
56594 XI = HI(I-1,I-1) / NORM
56595 WI(I-1) = XI
56596 HR(I-1,I-1) = NORM
56597 HI(I-1,I-1) = 0.0D0
56598 HI(I,I-1) = SR / NORM
56599C
56600 DO 320 J = I, N
56601 YR = HR(I-1,J)
56602 YI = HI(I-1,J)
56603 ZZR = HR(I,J)
56604 ZZI = HI(I,J)
56605 HR(I-1,J) = XR * YR + XI * YI + HI(I,I-1) * ZZR
56606 HI(I-1,J) = XR * YI - XI * YR + HI(I,I-1) * ZZI
56607 HR(I,J) = XR * ZZR - XI * ZZI - HI(I,I-1) * YR
56608 HI(I,J) = XR * ZZI + XI * ZZR - HI(I,I-1) * YI
56609 320 CONTINUE
56610C
56611 330 CONTINUE
56612C
56613 SI = HI(EN,EN)
56614 IF (SI .EQ. 0.0D0) GOTO 350
56615 NORM = PYTHAG(HR(EN,EN),SI)
56616 SR = HR(EN,EN) / NORM
56617 SI = SI / NORM
56618 HR(EN,EN) = NORM
56619 HI(EN,EN) = 0.0D0
56620 IF (EN .EQ. N) GOTO 350
56621 IP1 = EN + 1
56622C
56623 DO 340 J = IP1, N
56624 YR = HR(EN,J)
56625 YI = HI(EN,J)
56626 HR(EN,J) = SR * YR + SI * YI
56627 HI(EN,J) = SR * YI - SI * YR
56628 340 CONTINUE
56629C .......... INVERSE OPERATION (COLUMNS) ..........
56630 350 DO 390 J = LP1, EN
56631 XR = WR(J-1)
56632 XI = WI(J-1)
56633C
56634 DO 370 I = 1, J
56635 YR = HR(I,J-1)
56636 YI = 0.0D0
56637 ZZR = HR(I,J)
56638 ZZI = HI(I,J)
56639 IF (I .EQ. J) GOTO 360
56640 YI = HI(I,J-1)
56641 HI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
56642 360 HR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
56643 HR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
56644 HI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
56645 370 CONTINUE
56646C
56647 DO 380 I = LOW, IGH
56648 YR = ZR(I,J-1)
56649 YI = ZI(I,J-1)
56650 ZZR = ZR(I,J)
56651 ZZI = ZI(I,J)
56652 ZR(I,J-1) = XR * YR - XI * YI + HI(J,J-1) * ZZR
56653 ZI(I,J-1) = XR * YI + XI * YR + HI(J,J-1) * ZZI
56654 ZR(I,J) = XR * ZZR + XI * ZZI - HI(J,J-1) * YR
56655 ZI(I,J) = XR * ZZI - XI * ZZR - HI(J,J-1) * YI
56656 380 CONTINUE
56657C
56658 390 CONTINUE
56659C
56660 IF (SI .EQ. 0.0D0) GOTO 250
56661C
56662 DO 400 I = 1, EN
56663 YR = HR(I,EN)
56664 YI = HI(I,EN)
56665 HR(I,EN) = SR * YR - SI * YI
56666 HI(I,EN) = SR * YI + SI * YR
56667 400 CONTINUE
56668C
56669 DO 410 I = LOW, IGH
56670 YR = ZR(I,EN)
56671 YI = ZI(I,EN)
56672 ZR(I,EN) = SR * YR - SI * YI
56673 ZI(I,EN) = SR * YI + SI * YR
56674 410 CONTINUE
56675C
56676 GOTO 250
56677C .......... A ROOT FOUND ..........
56678 420 HR(EN,EN) = HR(EN,EN) + TR
56679 WR(EN) = HR(EN,EN)
56680 HI(EN,EN) = HI(EN,EN) + TI
56681 WI(EN) = HI(EN,EN)
56682 EN = ENM1
56683 GOTO 240
56684C .......... ALL ROOTS FOUND. BACKSUBSTITUTE TO FIND
56685C VECTORS OF UPPER TRIANGULAR FORM ..........
56686 430 NORM = 0.0D0
56687C
56688 DO 440 I = 1, N
56689C
56690 DO 440 J = I, N
56691 TR = DABS(HR(I,J)) + DABS(HI(I,J))
56692 IF (TR .GT. NORM) NORM = TR
56693 440 CONTINUE
56694C
56695 IF (N .EQ. 1 .OR. NORM .EQ. 0.0D0) GOTO 560
56696C .......... FOR EN=N STEP -1 UNTIL 2 DO -- ..........
56697 DO 500 NN = 2, N
56698 EN = N + 2 - NN
56699 XR = WR(EN)
56700 XI = WI(EN)
56701 HR(EN,EN) = 1.0D0
56702 HI(EN,EN) = 0.0D0
56703 ENM1 = EN - 1
56704C .......... FOR I=EN-1 STEP -1 UNTIL 1 DO -- ..........
56705 DO 490 II = 1, ENM1
56706 I = EN - II
56707 ZZR = 0.0D0
56708 ZZI = 0.0D0
56709 IP1 = I + 1
56710C
56711 DO 450 J = IP1, EN
56712 ZZR = ZZR + HR(I,J) * HR(J,EN) - HI(I,J) * HI(J,EN)
56713 ZZI = ZZI + HR(I,J) * HI(J,EN) + HI(I,J) * HR(J,EN)
56714 450 CONTINUE
56715C
56716 YR = XR - WR(I)
56717 YI = XI - WI(I)
56718 IF (YR .NE. 0.0D0 .OR. YI .NE. 0.0D0) GOTO 470
56719 TST1 = NORM
56720 YR = TST1
56721 460 YR = 0.01D0 * YR
56722 TST2 = NORM + YR
56723 IF (TST2 .GT. TST1) GOTO 460
56724 470 CONTINUE
56725 CALL PYCDIV(ZZR,ZZI,YR,YI,HR(I,EN),HI(I,EN))
56726C .......... OVERFLOW CONTROL ..........
56727 TR = DABS(HR(I,EN)) + DABS(HI(I,EN))
56728 IF (TR .EQ. 0.0D0) GOTO 490
56729 TST1 = TR
56730 TST2 = TST1 + 1.0D0/TST1
56731 IF (TST2 .GT. TST1) GOTO 490
56732 DO 480 J = I, EN
56733 HR(J,EN) = HR(J,EN)/TR
56734 HI(J,EN) = HI(J,EN)/TR
56735 480 CONTINUE
56736C
56737 490 CONTINUE
56738C
56739 500 CONTINUE
56740C .......... END BACKSUBSTITUTION ..........
56741C .......... VECTORS OF ISOLATED ROOTS ..........
56742 DO 520 I = 1, N
56743 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 520
56744C
56745 DO 510 J = I, N
56746 ZR(I,J) = HR(I,J)
56747 ZI(I,J) = HI(I,J)
56748 510 CONTINUE
56749C
56750 520 CONTINUE
56751C .......... MULTIPLY BY TRANSFORMATION MATRIX TO GIVE
56752C VECTORS OF ORIGINAL FULL MATRIX.
56753C FOR J=N STEP -1 UNTIL LOW DO -- ..........
56754 DO 540 JJ = LOW, N
56755 J = N + LOW - JJ
56756 M = MIN0(J,IGH)
56757C
56758 DO 540 I = LOW, IGH
56759 ZZR = 0.0D0
56760 ZZI = 0.0D0
56761C
56762 DO 530 K = LOW, M
56763 ZZR = ZZR + ZR(I,K) * HR(K,J) - ZI(I,K) * HI(K,J)
56764 ZZI = ZZI + ZR(I,K) * HI(K,J) + ZI(I,K) * HR(K,J)
56765 530 CONTINUE
56766C
56767 ZR(I,J) = ZZR
56768 ZI(I,J) = ZZI
56769 540 CONTINUE
56770C
56771 GOTO 560
56772C .......... SET ERROR -- ALL EIGENVALUES HAVE NOT
56773C CONVERGED AFTER 30*N ITERATIONS ..........
56774 550 IERR = EN
56775 560 RETURN
56776 END
56777
56778C*********************************************************************
56779
56780C...PYCDIV
56781C...Auxiliary to PYCMQR
56782C
56783C COMPLEX DIVISION, (CR,CI) = (AR,AI)/(BR,BI)
56784C
56785
56786 SUBROUTINE PYCDIV(AR,AI,BR,BI,CR,CI)
56787
56788 DOUBLE PRECISION AR,AI,BR,BI,CR,CI
56789 DOUBLE PRECISION S,ARS,AIS,BRS,BIS
56790
56791 S = DABS(BR) + DABS(BI)
56792 ARS = AR/S
56793 AIS = AI/S
56794 BRS = BR/S
56795 BIS = BI/S
56796 S = BRS**2 + BIS**2
56797 CR = (ARS*BRS + AIS*BIS)/S
56798 CI = (AIS*BRS - ARS*BIS)/S
56799 RETURN
56800 END
56801
56802C*********************************************************************
56803
56804C...PYCSRT
56805C...Auxiliary to PYCMQR
56806C
56807C (YR,YI) = COMPLEX DSQRT(XR,XI)
56808C BRANCH CHOSEN SO THAT YR .GE. 0.0 AND SIGN(YI) .EQ. SIGN(XI)
56809C
56810
56811 SUBROUTINE PYCSRT(XR,XI,YR,YI)
56812
56813 DOUBLE PRECISION XR,XI,YR,YI
56814 DOUBLE PRECISION S,TR,TI,PYTHAG
56815
56816 TR = XR
56817 TI = XI
56818 S = DSQRT(0.5D0*(PYTHAG(TR,TI) + DABS(TR)))
56819 IF (TR .GE. 0.0D0) YR = S
56820 IF (TI .LT. 0.0D0) S = -S
56821 IF (TR .LE. 0.0D0) YI = S
56822 IF (TR .LT. 0.0D0) YR = 0.5D0*(TI/YI)
56823 IF (TR .GT. 0.0D0) YI = 0.5D0*(TI/YR)
56824 RETURN
56825 END
56826
56827 DOUBLE PRECISION FUNCTION PYTHAG(A,B)
56828 DOUBLE PRECISION A,B
56829C
56830C FINDS DSQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
56831C
56832 DOUBLE PRECISION P,R,S,T,U
56833 P = DMAX1(DABS(A),DABS(B))
56834 IF (P .EQ. 0.0D0) GOTO 110
56835 R = (DMIN1(DABS(A),DABS(B))/P)**2
56836 100 CONTINUE
56837 T = 4.0D0 + R
56838 IF (T .EQ. 4.0D0) GOTO 110
56839 S = R/T
56840 U = 1.0D0 + 2.0D0*S
56841 P = U*P
56842 R = (S/U)**2 * R
56843 GOTO 100
56844 110 PYTHAG = P
56845 RETURN
56846 END
56847
56848C*********************************************************************
56849
56850C...PYCBAL
56851C...Auxiliary to PYEICG
56852C
56853C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
56854C CBALANCE, WHICH IS A COMPLEX VERSION OF BALANCE,
56855C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
56856C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
56857C
56858C THIS SUBROUTINE BALANCES A COMPLEX MATRIX AND ISOLATES
56859C EIGENVALUES WHENEVER POSSIBLE.
56860C
56861C ON INPUT
56862C
56863C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
56864C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
56865C DIMENSION STATEMENT.
56866C
56867C N IS THE ORDER OF THE MATRIX.
56868C
56869C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56870C RESPECTIVELY, OF THE COMPLEX MATRIX TO BE BALANCED.
56871C
56872C ON OUTPUT
56873C
56874C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
56875C RESPECTIVELY, OF THE BALANCED MATRIX.
56876C
56877C LOW AND IGH ARE TWO INTEGERS SUCH THAT AR(I,J) AND AI(I,J)
56878C ARE EQUAL TO ZERO IF
56879C (1) I IS GREATER THAN J AND
56880C (2) J=1,...,LOW-1 OR I=IGH+1,...,N.
56881C
56882C SCALE CONTAINS INFORMATION DETERMINING THE
56883C PERMUTATIONS AND SCALING FACTORS USED.
56884C
56885C SUPPOSE THAT THE PRINCIPAL SUBMATRIX IN ROWS LOW THROUGH IGH
56886C HAS BEEN BALANCED, THAT P(J) DENOTES THE INDEX INTERCHANGED
56887C WITH J DURING THE PERMUTATION STEP, AND THAT THE ELEMENTS
56888C OF THE DIAGONAL MATRIX USED ARE DENOTED BY D(I,J). THEN
56889C SCALE(J) = P(J), FOR J = 1,...,LOW-1
56890C = D(J,J) J = LOW,...,IGH
56891C = P(J) J = IGH+1,...,N.
56892C THE ORDER IN WHICH THE INTERCHANGES ARE MADE IS N TO IGH+1,
56893C THEN 1 TO LOW-1.
56894C
56895C NOTE THAT 1 IS RETURNED FOR IGH IF IGH IS ZERO FORMALLY.
56896C
56897C THE ALGOL PROCEDURE EXC CONTAINED IN CBALANCE APPEARS IN
56898C CBAL IN LINE. (NOTE THAT THE ALGOL ROLES OF IDENTIFIERS
56899C K,L HAVE BEEN REVERSED.)
56900C
56901C ARITHMETIC IS REAL THROUGHOUT.
56902C
56903C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
56904C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
56905C
56906C THIS VERSION DATED AUGUST 1983.
56907C
56908
56909 SUBROUTINE PYCBAL(NM,N,AR,AI,LOW,IGH,SCALE)
56910
56911 INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC
56912 DOUBLE PRECISION AR(5,5),AI(5,5),SCALE(5)
56913 DOUBLE PRECISION C,F,G,R,S,B2,RADIX
56914 LOGICAL NOCONV
56915
56916 RADIX = 16.0D0
56917C
56918 B2 = RADIX * RADIX
56919 K = 1
56920 L = N
56921 GOTO 150
56922C .......... IN-LINE PROCEDURE FOR ROW AND
56923C COLUMN EXCHANGE ..........
56924 100 SCALE(M) = J
56925 IF (J .EQ. M) GOTO 130
56926C
56927 DO 110 I = 1, L
56928 F = AR(I,J)
56929 AR(I,J) = AR(I,M)
56930 AR(I,M) = F
56931 F = AI(I,J)
56932 AI(I,J) = AI(I,M)
56933 AI(I,M) = F
56934 110 CONTINUE
56935C
56936 DO 120 I = K, N
56937 F = AR(J,I)
56938 AR(J,I) = AR(M,I)
56939 AR(M,I) = F
56940 F = AI(J,I)
56941 AI(J,I) = AI(M,I)
56942 AI(M,I) = F
56943 120 CONTINUE
56944C
56945 130 IF(IEXC.EQ.1) GOTO 140
56946 IF(IEXC.EQ.2) GOTO 180
56947C .......... SEARCH FOR ROWS ISOLATING AN EIGENVALUE
56948C AND PUSH THEM DOWN ..........
56949 140 IF (L .EQ. 1) GOTO 320
56950 L = L - 1
56951C .......... FOR J=L STEP -1 UNTIL 1 DO -- ..........
56952 150 DO 170 JJ = 1, L
56953 J = L + 1 - JJ
56954C
56955 DO 160 I = 1, L
56956 IF (I .EQ. J) GOTO 160
56957 IF (AR(J,I) .NE. 0.0D0 .OR. AI(J,I) .NE. 0.0D0) GOTO 170
56958 160 CONTINUE
56959C
56960 M = L
56961 IEXC = 1
56962 GOTO 100
56963 170 CONTINUE
56964C
56965 GOTO 190
56966C .......... SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE
56967C AND PUSH THEM LEFT ..........
56968 180 K = K + 1
56969C
56970 190 DO 210 J = K, L
56971C
56972 DO 200 I = K, L
56973 IF (I .EQ. J) GOTO 200
56974 IF (AR(I,J) .NE. 0.0D0 .OR. AI(I,J) .NE. 0.0D0) GOTO 210
56975 200 CONTINUE
56976C
56977 M = K
56978 IEXC = 2
56979 GOTO 100
56980 210 CONTINUE
56981C .......... NOW BALANCE THE SUBMATRIX IN ROWS K TO L ..........
56982 DO 220 I = K, L
56983 220 SCALE(I) = 1.0D0
56984C .......... ITERATIVE LOOP FOR NORM REDUCTION ..........
56985 230 NOCONV = .FALSE.
56986C
56987 DO 310 I = K, L
56988 C = 0.0D0
56989 R = 0.0D0
56990C
56991 DO 240 J = K, L
56992 IF (J .EQ. I) GOTO 240
56993 C = C + DABS(AR(J,I)) + DABS(AI(J,I))
56994 R = R + DABS(AR(I,J)) + DABS(AI(I,J))
56995 240 CONTINUE
56996C .......... GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW ..........
56997 IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GOTO 310
56998 G = R / RADIX
56999 F = 1.0D0
57000 S = C + R
57001 250 IF (C .GE. G) GOTO 260
57002 F = F * RADIX
57003 C = C * B2
57004 GOTO 250
57005 260 G = R * RADIX
57006 270 IF (C .LT. G) GOTO 280
57007 F = F / RADIX
57008 C = C / B2
57009 GOTO 270
57010C .......... NOW BALANCE ..........
57011 280 IF ((C + R) / F .GE. 0.95D0 * S) GOTO 310
57012 G = 1.0D0 / F
57013 SCALE(I) = SCALE(I) * F
57014 NOCONV = .TRUE.
57015C
57016 DO 290 J = K, N
57017 AR(I,J) = AR(I,J) * G
57018 AI(I,J) = AI(I,J) * G
57019 290 CONTINUE
57020C
57021 DO 300 J = 1, L
57022 AR(J,I) = AR(J,I) * F
57023 AI(J,I) = AI(J,I) * F
57024 300 CONTINUE
57025C
57026 310 CONTINUE
57027C
57028 IF (NOCONV) GOTO 230
57029C
57030 320 LOW = K
57031 IGH = L
57032 RETURN
57033 END
57034
57035C*********************************************************************
57036
57037C...PYCBA2
57038C...Auxiliary to PYEICG.
57039C
57040C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE
57041C CBABK2, WHICH IS A COMPLEX VERSION OF BALBAK,
57042C NUM. MATH. 13, 293-304(1969) BY PARLETT AND REINSCH.
57043C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 315-326(1971).
57044C
57045C THIS SUBROUTINE FORMS THE EIGENVECTORS OF A COMPLEX GENERAL
57046C MATRIX BY BACK TRANSFORMING THOSE OF THE CORRESPONDING
57047C BALANCED MATRIX DETERMINED BY CBAL.
57048C
57049C ON INPUT
57050C
57051C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
57052C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
57053C DIMENSION STATEMENT.
57054C
57055C N IS THE ORDER OF THE MATRIX.
57056C
57057C LOW AND IGH ARE INTEGERS DETERMINED BY CBAL.
57058C
57059C SCALE CONTAINS INFORMATION DETERMINING THE PERMUTATIONS
57060C AND SCALING FACTORS USED BY CBAL.
57061C
57062C M IS THE NUMBER OF EIGENVECTORS TO BE BACK TRANSFORMED.
57063C
57064C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
57065C RESPECTIVELY, OF THE EIGENVECTORS TO BE
57066C BACK TRANSFORMED IN THEIR FIRST M COLUMNS.
57067C
57068C ON OUTPUT
57069C
57070C ZR AND ZI CONTAIN THE REAL AND IMAGINARY PARTS,
57071C RESPECTIVELY, OF THE TRANSFORMED EIGENVECTORS
57072C IN THEIR FIRST M COLUMNS.
57073C
57074C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
57075C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
57076C
57077C THIS VERSION DATED AUGUST 1983.
57078C
57079
57080 SUBROUTINE PYCBA2(NM,N,LOW,IGH,SCALE,M,ZR,ZI)
57081
57082 INTEGER I,J,K,M,N,II,NM,IGH,LOW
57083 DOUBLE PRECISION SCALE(5),ZR(5,5),ZI(5,5)
57084 DOUBLE PRECISION S
57085
57086 IF (M .EQ. 0) GOTO 150
57087 IF (IGH .EQ. LOW) GOTO 120
57088C
57089 DO 110 I = LOW, IGH
57090 S = SCALE(I)
57091C .......... LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED
57092C IF THE FOREGOING STATEMENT IS REPLACED BY
57093C S=1.0D0/SCALE(I). ..........
57094 DO 100 J = 1, M
57095 ZR(I,J) = ZR(I,J) * S
57096 ZI(I,J) = ZI(I,J) * S
57097 100 CONTINUE
57098C
57099 110 CONTINUE
57100C .......... FOR I=LOW-1 STEP -1 UNTIL 1,
57101C IGH+1 STEP 1 UNTIL N DO -- ..........
57102 120 DO 140 II = 1, N
57103 I = II
57104 IF (I .GE. LOW .AND. I .LE. IGH) GOTO 140
57105 IF (I .LT. LOW) I = LOW - II
57106 K = SCALE(I)
57107 IF (K .EQ. I) GOTO 140
57108C
57109 DO 130 J = 1, M
57110 S = ZR(I,J)
57111 ZR(I,J) = ZR(K,J)
57112 ZR(K,J) = S
57113 S = ZI(I,J)
57114 ZI(I,J) = ZI(K,J)
57115 ZI(K,J) = S
57116 130 CONTINUE
57117C
57118 140 CONTINUE
57119C
57120 150 RETURN
57121 END
57122
57123C*********************************************************************
57124
57125C...PYCRTH
57126C...Auxiliary to PYEICG.
57127C
57128C THIS SUBROUTINE IS A TRANSLATION OF A COMPLEX ANALOGUE OF
57129C THE ALGOL PROCEDURE ORTHES, NUM. MATH. 12, 349-368(1968)
57130C BY MARTIN AND WILKINSON.
57131C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
57132C
57133C GIVEN A COMPLEX GENERAL MATRIX, THIS SUBROUTINE
57134C REDUCES A SUBMATRIX SITUATED IN ROWS AND COLUMNS
57135C LOW THROUGH IGH TO UPPER HESSENBERG FORM BY
57136C UNITARY SIMILARITY TRANSFORMATIONS.
57137C
57138C ON INPUT
57139C
57140C NM MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL
57141C ARRAY PARAMETERS AS DECLARED IN THE CALLING PROGRAM
57142C DIMENSION STATEMENT.
57143C
57144C N IS THE ORDER OF THE MATRIX.
57145C
57146C LOW AND IGH ARE INTEGERS DETERMINED BY THE BALANCING
57147C SUBROUTINE CBAL. IF CBAL HAS NOT BEEN USED,
57148C SET LOW=1, IGH=N.
57149C
57150C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
57151C RESPECTIVELY, OF THE COMPLEX INPUT MATRIX.
57152C
57153C ON OUTPUT
57154C
57155C AR AND AI CONTAIN THE REAL AND IMAGINARY PARTS,
57156C RESPECTIVELY, OF THE HESSENBERG MATRIX. INFORMATION
57157C ABOUT THE UNITARY TRANSFORMATIONS USED IN THE REDUCTION
57158C IS STORED IN THE REMAINING TRIANGLES UNDER THE
57159C HESSENBERG MATRIX.
57160C
57161C ORTR AND ORTI CONTAIN FURTHER INFORMATION ABOUT THE
57162C TRANSFORMATIONS. ONLY ELEMENTS LOW THROUGH IGH ARE USED.
57163C
57164C CALLS PYTHAG FOR DSQRT(A*A + B*B) .
57165C
57166C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
57167C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
57168C
57169C THIS VERSION DATED AUGUST 1983.
57170C
57171
57172 SUBROUTINE PYCRTH(NM,N,LOW,IGH,AR,AI,ORTR,ORTI)
57173
57174 INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
57175 DOUBLE PRECISION AR(5,5),AI(5,5),ORTR(5),ORTI(5)
57176 DOUBLE PRECISION F,G,H,FI,FR,SCALE,PYTHAG
57177
57178 LA = IGH - 1
57179 KP1 = LOW + 1
57180 IF (LA .LT. KP1) GOTO 210
57181C
57182 DO 200 M = KP1, LA
57183 H = 0.0D0
57184 ORTR(M) = 0.0D0
57185 ORTI(M) = 0.0D0
57186 SCALE = 0.0D0
57187C .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
57188 DO 100 I = M, IGH
57189 100 SCALE = SCALE + DABS(AR(I,M-1)) + DABS(AI(I,M-1))
57190C
57191 IF (SCALE .EQ. 0.0D0) GOTO 200
57192 MP = M + IGH
57193C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
57194 DO 110 II = M, IGH
57195 I = MP - II
57196 ORTR(I) = AR(I,M-1) / SCALE
57197 ORTI(I) = AI(I,M-1) / SCALE
57198 H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
57199 110 CONTINUE
57200C
57201 G = DSQRT(H)
57202 F = PYTHAG(ORTR(M),ORTI(M))
57203 IF (F .EQ. 0.0D0) GOTO 120
57204 H = H + F * G
57205 G = G / F
57206 ORTR(M) = (1.0D0 + G) * ORTR(M)
57207 ORTI(M) = (1.0D0 + G) * ORTI(M)
57208 GOTO 130
57209C
57210 120 ORTR(M) = G
57211 AR(M,M-1) = SCALE
57212C .......... FORM (I-(U*UT)/H) * A ..........
57213 130 DO 160 J = M, N
57214 FR = 0.0D0
57215 FI = 0.0D0
57216C .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
57217 DO 140 II = M, IGH
57218 I = MP - II
57219 FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
57220 FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
57221 140 CONTINUE
57222C
57223 FR = FR / H
57224 FI = FI / H
57225C
57226 DO 150 I = M, IGH
57227 AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
57228 AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
57229 150 CONTINUE
57230C
57231 160 CONTINUE
57232C .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
57233 DO 190 I = 1, IGH
57234 FR = 0.0D0
57235 FI = 0.0D0
57236C .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
57237 DO 170 JJ = M, IGH
57238 J = MP - JJ
57239 FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
57240 FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
57241 170 CONTINUE
57242C
57243 FR = FR / H
57244 FI = FI / H
57245C
57246 DO 180 J = M, IGH
57247 AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
57248 AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
57249 180 CONTINUE
57250C
57251 190 CONTINUE
57252C
57253 ORTR(M) = SCALE * ORTR(M)
57254 ORTI(M) = SCALE * ORTI(M)
57255 AR(M,M-1) = -G * AR(M,M-1)
57256 AI(M,M-1) = -G * AI(M,M-1)
57257 200 CONTINUE
57258C
57259 210 RETURN
57260 END
57261
57262C*********************************************************************
57263
57264C...PYLDCM
57265C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
57266C...processes.
57267
57268 SUBROUTINE PYLDCM(A,N,NP,INDX,D)
57269 IMPLICIT NONE
57270 INTEGER N,NP,INDX(N)
57271 REAL*8 D,TINY
57272 COMPLEX*16 A(NP,NP)
57273 PARAMETER (TINY=1.0D-20)
57274 INTEGER I,IMAX,J,K
57275 REAL*8 AAMAX,VV(6),DUM
57276 COMPLEX*16 SUM,DUMC
57277
57278 D=1D0
57279 DO 110 I=1,N
57280 AAMAX=0D0
57281 DO 100 J=1,N
57282 IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
57283 100 CONTINUE
57284 IF (AAMAX.EQ.0D0) CALL PYERRM(28,'(PYLDCM:) singular matrix')
57285 VV(I)=1D0/AAMAX
57286 110 CONTINUE
57287 DO 180 J=1,N
57288 DO 130 I=1,J-1
57289 SUM=A(I,J)
57290 DO 120 K=1,I-1
57291 SUM=SUM-A(I,K)*A(K,J)
57292 120 CONTINUE
57293 A(I,J)=SUM
57294 130 CONTINUE
57295 AAMAX=0D0
57296 DO 150 I=J,N
57297 SUM=A(I,J)
57298 DO 140 K=1,J-1
57299 SUM=SUM-A(I,K)*A(K,J)
57300 140 CONTINUE
57301 A(I,J)=SUM
57302 DUM=VV(I)*ABS(SUM)
57303 IF (DUM.GE.AAMAX) THEN
57304 IMAX=I
57305 AAMAX=DUM
57306 ENDIF
57307 150 CONTINUE
57308 IF (J.NE.IMAX)THEN
57309 DO 160 K=1,N
57310 DUMC=A(IMAX,K)
57311 A(IMAX,K)=A(J,K)
57312 A(J,K)=DUMC
57313 160 CONTINUE
57314 D=-D
57315 VV(IMAX)=VV(J)
57316 ENDIF
57317 INDX(J)=IMAX
57318 IF(ABS(A(J,J)).EQ.0D0) A(J,J)=DCMPLX(TINY,0D0)
57319 IF(J.NE.N)THEN
57320 DO 170 I=J+1,N
57321 A(I,J)=A(I,J)/A(J,J)
57322 170 CONTINUE
57323 ENDIF
57324 180 CONTINUE
57325
57326 RETURN
57327 END
57328
57329C*********************************************************************
57330
57331C...PYBKSB
57332C...Auxiliary to PYSIGH, for technicolor corrections to QCD 2 -> 2
57333C...processes.
57334
57335 SUBROUTINE PYBKSB(A,N,NP,INDX,B)
57336 IMPLICIT NONE
57337 INTEGER N,NP,INDX(N)
57338 COMPLEX*16 A(NP,NP),B(N)
57339 INTEGER I,II,J,LL
57340 COMPLEX*16 SUM
57341
57342 II=0
57343 DO 110 I=1,N
57344 LL=INDX(I)
57345 SUM=B(LL)
57346 B(LL)=B(I)
57347 IF (II.NE.0)THEN
57348 DO 100 J=II,I-1
57349 SUM=SUM-A(I,J)*B(J)
57350 100 CONTINUE
57351 ELSE IF (ABS(SUM).NE.0D0) THEN
57352 II=I
57353 ENDIF
57354 B(I)=SUM
57355 110 CONTINUE
57356 DO 130 I=N,1,-1
57357 SUM=B(I)
57358 DO 120 J=I+1,N
57359 SUM=SUM-A(I,J)*B(J)
57360 120 CONTINUE
57361 B(I)=SUM/A(I,I)
57362 130 CONTINUE
57363 RETURN
57364 END
57365
57366C***********************************************************************
57367
57368C...PYWIDX
57369C...Calculates full and partial widths of resonances.
57370C....copy of PYWIDT, used for techniparticle widths
57371
57372 SUBROUTINE PYWIDX(KFLR,SH,WDTP,WDTE)
57373
57374C...Double precision and integer declarations.
57375 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57376 IMPLICIT INTEGER(I-N)
57377 INTEGER PYK,PYCHGE,PYCOMP
57378C...Parameter statement to help give large particle numbers.
57379 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57380 &KEXCIT=4000000,KDIMEN=5000000)
57381C...Commonblocks.
57382 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57383 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57384 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
57385 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
57386 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
57387 COMMON/PYINT1/MINT(400),VINT(400)
57388 COMMON/PYINT4/MWID(500),WIDS(500,5)
57389 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57390 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
57391 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/,/PYINT1/,
57392 &/PYINT4/,/PYMSSM/,/PYTCSM/
57393C...Local arrays and saved variables.
57394 DIMENSION WDTP(0:400),WDTE(0:400,0:5),MOFSV(3,2),WIDWSV(3,2),
57395 &WID2SV(3,2)
57396 SAVE MOFSV,WIDWSV,WID2SV
57397 DATA MOFSV/6*0/,WIDWSV/6*0D0/,WID2SV/6*0D0/
57398
57399C...Compressed code and sign; mass.
57400 KFLA=IABS(KFLR)
57401 KFLS=ISIGN(1,KFLR)
57402 KC=PYCOMP(KFLA)
57403 SHR=SQRT(SH)
57404 PMR=PMAS(KC,1)
57405
57406C...Reset width information.
57407 DO I=0,400
57408 WDTP(I)=0D0
57409 ENDDO
57410
57411C...Common electroweak and strong constants.
57412 XW=PARU(102)
57413 XWV=XW
57414 IF(MSTP(8).GE.2) XW=1D0-(PMAS(24,1)/PMAS(23,1))**2
57415 XW1=1D0-XW
57416 AEM=PYALEM(SH)
57417 IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
57418 AS=PYALPS(SH)
57419 RADC=1D0+AS/PARU(1)
57420
57421 IF(KFLA.EQ.23) THEN
57422C...Z0:
57423 XWC=1D0/(16D0*XW*XW1)
57424 FAC=(AEM*XWC/3D0)*SHR
57425 120 CONTINUE
57426 DO 130 I=1,MDCY(KC,3)
57427 IDC=I+MDCY(KC,2)-1
57428 IF(MDME(IDC,1).LT.0) GOTO 130
57429 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
57430 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
57431 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 130
57432 IF(I.LE.8) THEN
57433C...Z0 -> q + qbar
57434 EF=KCHG(I,1)/3D0
57435 AF=SIGN(1D0,EF+0.1D0)
57436 VF=AF-4D0*EF*XWV
57437 FCOF=3D0*RADC
57438 IF(I.GE.6.AND.MSTP(35).GE.1) FCOF=FCOF*PYHFTH(SH,SH*RM1,1D0)
57439 ELSEIF(I.LE.16) THEN
57440C...Z0 -> l+ + l-, nu + nubar
57441 EF=KCHG(I+2,1)/3D0
57442 AF=SIGN(1D0,EF+0.1D0)
57443 VF=AF-4D0*EF*XWV
57444 FCOF=1D0
57445 ENDIF
57446 BE34=SQRT(MAX(0D0,1D0-4D0*RM1))
57447 WDTP(I)=FAC*FCOF*(VF**2*(1D0+2D0*RM1)+AF**2*(1D0-4D0*RM1))*
57448 & BE34
57449 WDTP(0)=WDTP(0)+WDTP(I)
57450 130 CONTINUE
57451
57452
57453 ELSEIF(KFLA.EQ.24) THEN
57454C...W+/-:
57455 FAC=(AEM/(24D0*XW))*SHR
57456 DO 140 I=1,MDCY(KC,3)
57457 IDC=I+MDCY(KC,2)-1
57458 IF(MDME(IDC,1).LT.0) GOTO 140
57459 RM1=PMAS(PYCOMP(KFDP(IDC,1)),1)**2/SH
57460 RM2=PMAS(PYCOMP(KFDP(IDC,2)),1)**2/SH
57461 IF(SQRT(RM1)+SQRT(RM2).GT.1D0) GOTO 140
57462 WID2=1D0
57463 IF(I.LE.16) THEN
57464C...W+/- -> q + qbar'
57465 FCOF=3D0*RADC*VCKM((I-1)/4+1,MOD(I-1,4)+1)
57466 ELSEIF(I.LE.20) THEN
57467C...W+/- -> l+/- + nu
57468 FCOF=1D0
57469 ENDIF
57470 WDTP(I)=FAC*FCOF*(2D0-RM1-RM2-(RM1-RM2)**2)*
57471 & SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
57472 WDTP(0)=WDTP(0)+WDTP(I)
57473 140 CONTINUE
57474
57475C.....V8 -> quark anti-quark
57476 ELSEIF(KFLA.EQ.KTECHN+100021) THEN
57477 FAC=AS/6D0*SHR
57478 TANT3=RTCM(21)
57479 IF(ITCM(2).EQ.0) THEN
57480 IMDL=1
57481 ELSEIF(ITCM(2).EQ.1) THEN
57482 IMDL=2
57483 ENDIF
57484 DO 150 I=1,MDCY(KC,3)
57485 IDC=I+MDCY(KC,2)-1
57486 IF(MDME(IDC,1).LT.0) GOTO 150
57487 PM1=PMAS(PYCOMP(KFDP(IDC,1)),1)
57488 RM1=PM1**2/SH
57489 IF(RM1.GT.0.25D0) GOTO 150
57490 WID2=1D0
57491 IF(I.EQ.5.OR.I.EQ.6.OR.IMDL.EQ.2) THEN
57492 FMIX=1D0/TANT3**2
57493 ELSE
57494 FMIX=TANT3**2
57495 ENDIF
57496 WDTP(I)=FAC*(1D0+2D0*RM1)*SQRT(1D0-4D0*RM1)*FMIX
57497 IF(I.EQ.6) WID2=WIDS(6,1)
57498 WDTP(0)=WDTP(0)+WDTP(I)
57499 150 CONTINUE
57500 ENDIF
57501
57502 RETURN
57503 END
57504
57505C*********************************************************************
57506
57507C...PYRVSF
57508C...Calculates R-violating decays of sfermions.
57509C...P. Z. Skands
57510
57511 SUBROUTINE PYRVSF(KFIN,XLAM,IDLAM,LKNT)
57512
57513C...Double precision and integer declarations.
57514 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57515 IMPLICIT INTEGER(I-N)
57516C...Parameter statement to help give large particle numbers.
57517 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57518 &KEXCIT=4000000,KDIMEN=5000000)
57519C...Commonblocks.
57520 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57521 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57522 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57523 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57524 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57525C...Local variables.
57526 DOUBLE PRECISION XLAM(0:400)
57527 INTEGER IDLAM(400,3), PYCOMP
57528 SAVE /PYMSRV/,/PYSSMT/,/PYMSSM/,/PYDAT2/
57529
57530C...IS R-VIOLATION ON ?
57531 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57532C...Mass eigenstate counter
57533 ICNT=INT(KFIN/KSUSY1)
57534C...SM KF code of SUSY particle
57535 KFSM=KFIN-ICNT*KSUSY1
57536C...Squared Sparticle Mass
57537 SM=PMAS(PYCOMP(KFIN),1)**2
57538C... Squared mass of top quark
57539 SMT=PMAS(PYCOMP(6),1)**2
57540C...IS L-VIOLATION ON ?
57541 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1)) THEN
57542C...SLEPTON -> NU(BAR) + LEPTON and UBAR + D
57543 IF(ICNT.NE.0.AND.(KFSM.EQ.11.OR.KFSM.EQ.13.OR.KFSM.EQ.15))
57544 & THEN
57545 K=INT((KFSM-9)/2)
57546 DO 110 I=1,3
57547 DO 100 J=1,3
57548 IF(I.NE.J) THEN
57549C...~e,~mu,~tau -> nu_I + lepton-_J
57550 LKNT = LKNT+1
57551 IDLAM(LKNT,1)= 12 +2*(I-1)
57552 IDLAM(LKNT,2)= 11 +2*(J-1)
57553 IDLAM(LKNT,3)= 0
57554 XLAM(LKNT)=0D0
57555 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57556 IF (IMSS(51).NE.0) XLAM(LKNT) =
57557 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57558C...KINEMATICS CHECK
57559 IF (XLAM(LKNT).EQ.0D0) THEN
57560 LKNT=LKNT-1
57561 ENDIF
57562 ENDIF
57563 100 CONTINUE
57564 110 CONTINUE
57565C...~e,~mu,~tau -> nu_Ibar + lepton-_K
57566 J=INT((KFSM-9)/2)
57567 DO 130 I=1,3
57568 IF(I.NE.J) THEN
57569 DO 120 K=1,3
57570 LKNT = LKNT+1
57571 IDLAM(LKNT,1)=-12 -2*(I-1)
57572 IDLAM(LKNT,2)= 11 +2*(K-1)
57573 IDLAM(LKNT,3)= 0
57574 XLAM(LKNT)=0D0
57575 RM2=RVLAM(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57576 IF (IMSS(51).NE.0) XLAM(LKNT) =
57577 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57578C...KINEMATICS CHECK
57579 IF (XLAM(LKNT).EQ.0D0) THEN
57580 LKNT=LKNT-1
57581 ENDIF
57582 120 CONTINUE
57583 ENDIF
57584 130 CONTINUE
57585C...~e,~mu,~tau -> u_Jbar + d_K
57586 I=INT((KFSM-9)/2)
57587 DO 150 J=1,3
57588 DO 140 K=1,3
57589 LKNT = LKNT+1
57590 IDLAM(LKNT,1)=-2 -2*(J-1)
57591 IDLAM(LKNT,2)= 1 +2*(K-1)
57592 IDLAM(LKNT,3)= 0
57593 XLAM(LKNT)=0
57594 IF (IMSS(52).NE.0) THEN
57595C...Use massive top quark
57596 IF (IDLAM(LKNT,1).EQ.-6) THEN
57597 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2
57598 & * (SM-SMT)
57599 XLAM(LKNT) =
57600 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
57601C...If no top quark, all decay products massless
57602 ELSE
57603 RM2=3*RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57604 XLAM(LKNT) =
57605 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57606 ENDIF
57607C...KINEMATICS CHECK
57608 IF (XLAM(LKNT).EQ.0D0) THEN
57609 LKNT=LKNT-1
57610 ENDIF
57611 ENDIF
57612 140 CONTINUE
57613 150 CONTINUE
57614 ENDIF
57615C * SNEUTRINO -> LEPTON+ + LEPTON- and DBAR + D
57616C...No right-handed neutrinos
57617 IF(ICNT.EQ.1) THEN
57618 IF(KFSM.EQ.12.OR.KFSM.EQ.14.OR.KFSM.EQ.16) THEN
57619 J=INT((KFSM-10)/2)
57620 DO 170 I=1,3
57621 DO 160 K=1,3
57622 IF (I.NE.J) THEN
57623C...~nu_J -> lepton+_I + lepton-_K
57624 LKNT = LKNT+1
57625 IDLAM(LKNT,1)=-11 -2*(I-1)
57626 IDLAM(LKNT,2)= 11 +2*(K-1)
57627 IDLAM(LKNT,3)= 0
57628 XLAM(LKNT)=0D0
57629 RM2=RVLAM(I,J,K)**2 * SM
57630 IF (IMSS(51).NE.0) XLAM(LKNT) =
57631 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57632C...KINEMATICS CHECK
57633 IF (XLAM(LKNT).EQ.0D0) THEN
57634 LKNT=LKNT-1
57635 ENDIF
57636 ENDIF
57637 160 CONTINUE
57638 170 CONTINUE
57639C...~nu_I -> dbar_J + d_K
57640 I=INT((KFSM-10)/2)
57641 DO 190 J=1,3
57642 DO 180 K=1,3
57643 LKNT = LKNT+1
57644 IDLAM(LKNT,1)=-1 -2*(J-1)
57645 IDLAM(LKNT,2)= 1 +2*(K-1)
57646 IDLAM(LKNT,3)= 0
57647 XLAM(LKNT)=0D0
57648 RM2=3*RVLAMP(I,J,K)**2 * SM
57649 IF (IMSS(52).NE.0) XLAM(LKNT) =
57650 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57651C...KINEMATICS CHECK
57652 IF (XLAM(LKNT).EQ.0D0) THEN
57653 LKNT=LKNT-1
57654 ENDIF
57655 180 CONTINUE
57656 190 CONTINUE
57657 ENDIF
57658 ENDIF
57659C * SDOWN -> NU(BAR) + D and LEPTON- + U
57660 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
57661 J=INT((KFSM+1)/2)
57662 DO 210 I=1,3
57663 DO 200 K=1,3
57664C...~d_J -> nu_Ibar + d_K
57665 LKNT = LKNT+1
57666 IDLAM(LKNT,1)=-12 -2*(I-1)
57667 IDLAM(LKNT,2)= 1 +2*(K-1)
57668 IDLAM(LKNT,3)= 0
57669 XLAM(LKNT)=0D0
57670 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57671 IF (IMSS(52).NE.0) XLAM(LKNT) =
57672 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57673C...KINEMATICS CHECK
57674 IF (XLAM(LKNT).EQ.0D0) THEN
57675 LKNT=LKNT-1
57676 ENDIF
57677 200 CONTINUE
57678 210 CONTINUE
57679 K=INT((KFSM+1)/2)
57680 DO 240 I=1,3
57681 DO 230 J=1,3
57682C...~d_K -> nu_I + d_J
57683 LKNT = LKNT+1
57684 IDLAM(LKNT,1)= 12 +2*(I-1)
57685 IDLAM(LKNT,2)= 1 +2*(J-1)
57686 IDLAM(LKNT,3)= 0
57687 XLAM(LKNT)=0D0
57688 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57689 IF (IMSS(52).NE.0) XLAM(LKNT) =
57690 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57691C...KINEMATICS CHECK
57692 IF (XLAM(LKNT).EQ.0D0) THEN
57693 LKNT=LKNT-1
57694 ENDIF
57695C...~d_K -> lepton_I- + u_J
57696 220 LKNT = LKNT+1
57697 IDLAM(LKNT,1)= 11 +2*(I-1)
57698 IDLAM(LKNT,2)= 2 +2*(J-1)
57699 IDLAM(LKNT,3)= 0
57700 XLAM(LKNT)=0D0
57701 IF (IMSS(52).NE.0) THEN
57702C...Use massive top quark
57703 IF (IDLAM(LKNT,2).EQ.6) THEN
57704 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT)
57705 XLAM(LKNT) =
57706 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,2)
57707C...If no top quark, all decay products massless
57708 ELSE
57709 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57710 XLAM(LKNT) =
57711 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57712 ENDIF
57713C...KINEMATICS CHECK
57714 IF (XLAM(LKNT).EQ.0D0) THEN
57715 LKNT=LKNT-1
57716 ENDIF
57717 ENDIF
57718 230 CONTINUE
57719 240 CONTINUE
57720 ENDIF
57721C * SUP -> LEPTON+ + D
57722 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
57723 J=NINT(KFSM/2.)
57724 DO 260 I=1,3
57725 DO 250 K=1,3
57726C...~u_J -> lepton_I+ + d_K
57727 LKNT = LKNT+1
57728 IDLAM(LKNT,1)=-11 -2*(I-1)
57729 IDLAM(LKNT,2)= 1 +2*(K-1)
57730 IDLAM(LKNT,3)= 0
57731 XLAM(LKNT)=0D0
57732 RM2=RVLAMP(I,J,K)**2*SFMIX(KFSM,2*ICNT-1)**2 * SM
57733 IF (IMSS(52).NE.0) XLAM(LKNT) =
57734 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57735C...KINEMATICS CHECK
57736 IF (XLAM(LKNT).EQ.0D0) THEN
57737 LKNT=LKNT-1
57738 ENDIF
57739 250 CONTINUE
57740 260 CONTINUE
57741 ENDIF
57742 ENDIF
57743C...BARYON NUMBER VIOLATING DECAYS
57744 IF (IMSS(53).GE.1) THEN
57745C * SUP -> DBAR + DBAR
57746 IF(ICNT.NE.0.AND.(KFSM.EQ.2.OR.KFSM.EQ.4.OR.KFSM.EQ.6)) THEN
57747 I = KFSM/2
57748 DO 280 J=1,3
57749 DO 270 K=1,3
57750C...~u_I -> dbar_J + dbar_K
57751 IF (J.LT.K) THEN
57752C...(anti-) symmetry J <-> K.
57753 LKNT = LKNT + 1
57754 IDLAM(LKNT,1) = -1 -2*(J-1)
57755 IDLAM(LKNT,2) = -1 -2*(K-1)
57756 IDLAM(LKNT,3) = 0
57757 XLAM(LKNT) = 0D0
57758 RM2 = 2.*(RVLAMB(I,J,K)**2)
57759 & * SFMIX(KFSM,2*ICNT)**2 * SM
57760 XLAM(LKNT) =
57761 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57762C...KINEMATICS CHECK
57763 IF (XLAM(LKNT).EQ.0D0) THEN
57764 LKNT = LKNT-1
57765 ENDIF
57766 ENDIF
57767 270 CONTINUE
57768 280 CONTINUE
57769 ENDIF
57770C * SDOWN -> UBAR + DBAR
57771 IF(ICNT.NE.0.AND.(KFSM.EQ.1.OR.KFSM.EQ.3.OR.KFSM.EQ.5)) THEN
57772 K=(KFSM+1)/2
57773 DO 300 I=1,3
57774 DO 290 J=1,3
57775C...LAMB coupling antisymmetric in J and K.
57776 IF (J.NE.K) THEN
57777C...~d_K -> ubar_I + dbar_K
57778 LKNT = LKNT + 1
57779 IDLAM(LKNT,1)= -2 -2*(I-1)
57780 IDLAM(LKNT,2)= -1 -2*(J-1)
57781 IDLAM(LKNT,3)= 0
57782 XLAM(LKNT)=0D0
57783C...Use massive top quark
57784 IF (IDLAM(LKNT,1).EQ.-6) THEN
57785 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2*(SM-SMT
57786 & )
57787 XLAM(LKNT) =
57788 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,3)
57789C...If no top quark, all decay products massless
57790 ELSE
57791 RM2=2*RVLAMB(I,J,K)**2*SFMIX(KFSM,2*ICNT)**2 * SM
57792 XLAM(LKNT) =
57793 & PYRVSB(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),RM2,4)
57794 ENDIF
57795C...KINEMATICS CHECK
57796 IF (XLAM(LKNT).EQ.0D0) THEN
57797 LKNT=LKNT-1
57798 ENDIF
57799 ENDIF
57800 290 CONTINUE
57801 300 CONTINUE
57802 ENDIF
57803 ENDIF
57804 ENDIF
57805
57806 RETURN
57807 END
57808
57809C*********************************************************************
57810
57811C...PYRVNE
57812C...Calculates R-violating neutralino decay widths (pure 1->3 parts).
57813C...P. Z. Skands
57814
57815 SUBROUTINE PYRVNE(KFIN,XLAM,IDLAM,LKNT)
57816
57817C...Double precision and integer declarations.
57818 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
57819 IMPLICIT INTEGER(I-N)
57820C...Parameter statement to help give large particle numbers.
57821 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
57822 &KEXCIT=4000000,KDIMEN=5000000)
57823C...Commonblocks.
57824 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
57825 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
57826 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
57827 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
57828 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
57829 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
57830C...Local variables.
57831 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
57832 & ,DCMASS,KFR(3)
57833 DOUBLE PRECISION XLAM(0:400)
57834 DOUBLE PRECISION ZPMIX(4,4), NMIX(4,4), RMQ(6)
57835 INTEGER IDLAM(400,3), PYCOMP
57836 LOGICAL DCMASS
57837 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/
57838
57839C...R-VIOLATING DECAYS
57840 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
57841 KFSM=KFIN-KSUSY1
57842 IF(KFSM.EQ.22.OR.KFSM.EQ.23.OR.KFSM.EQ.25.OR.KFSM.EQ.35) THEN
57843C...WHICH NEUTRALINO ?
57844 NCHI=1
57845 IF (KFSM.EQ.23) NCHI=2
57846 IF (KFSM.EQ.25) NCHI=3
57847 IF (KFSM.EQ.35) NCHI=4
57848C...SIGN OF MASS (Opposite convention as HERWIG)
57849 ISM = 1
57850 IF (SMZ(NCHI).LT.0D0) ISM = -ISM
57851
57852C...Useful parameters for the calculation of the A and B constants.
57853 WMASS = PMAS(PYCOMP(24),1)
57854 ECHG = 2*SQRT(PARU(103)*PARU(1))
57855 COSB=1/(SQRT(1+RMSS(5)**2))
57856 SINB=RMSS(5)/SQRT(1+RMSS(5)**2)
57857 COSW=SQRT(1-PARU(102))
57858 SINW=SQRT(PARU(102))
57859 GW=2D0*SQRT(PARU(103)*PARU(1))/SINW
57860C...Run quark masses to neutralino mass squared (for Higgs-type
57861C...couplings)
57862 SQMCHI=PMAS(PYCOMP(KFIN),1)**2
57863 DO 100 I=1,6
57864 RMQ(I)=PYMRUN(I,SQMCHI)
57865 100 CONTINUE
57866C...EXPRESS NEUTRALINO MIXING IN (photino,Zino,~H_u,~H_d) BASIS
57867 DO 110 NCHJ=1,4
57868 ZPMIX(NCHJ,1)= ZMIX(NCHJ,1)*COSW+ZMIX(NCHJ,2)*SINW
57869 ZPMIX(NCHJ,2)=-ZMIX(NCHJ,1)*SINW+ZMIX(NCHJ,2)*COSW
57870 ZPMIX(NCHJ,3)= ZMIX(NCHJ,3)
57871 ZPMIX(NCHJ,4)= ZMIX(NCHJ,4)
57872 110 CONTINUE
57873 C1=GW*ZPMIX(NCHI,3)/(2D0*COSB*WMASS)
57874 C1U=GW*ZPMIX(NCHI,4)/(2D0*SINB*WMASS)
57875 C2=ECHG*ZPMIX(NCHI,1)
57876 C3=GW*ZPMIX(NCHI,2)/COSW
57877 EU=2D0/3D0
57878 ED=-1D0/3D0
57879C... AB(x,y,z):
57880C x=1-2 : Select A or B constant (1:A ; 2:B)
57881C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
57882C 11-16:e,nu_e,mu,...)
57883C z=1-2 : Mass eigenstate number
57884C...CALCULATE COUPLINGS
57885 DO 120 I = 11,15,2
57886 CMS=PMAS(PYCOMP(I),1)
57887C...Intermediate sleptons
57888 AB(1,I,1)=ISM*(CMS*C1*SFMIX(I,1) + SFMIX(I,2)
57889 & *(C2-C3*SINW**2))
57890 AB(1,I,2)=ISM*(CMS*C1*SFMIX(I,3) + SFMIX(I,4)
57891 & *(C2-C3*SINW**2))
57892 AB(2,I,1)= CMS*C1*SFMIX(I,2) - SFMIX(I,1)*(C2+C3*(5D-1-SINW
57893 & **2))
57894 AB(2,I,2)=CMS*C1*SFMIX(I,4) - SFMIX(I,3)*(C2+C3*(5D-1-SINW
57895 & **2))
57896C...Inermediate sneutrinos
57897 AB(1,I+1,1)=0D0
57898 AB(2,I+1,1)=5D-1*C3
57899 AB(1,I+1,2)=0D0
57900 AB(2,I+1,2)=0D0
57901C...Inermediate sdown
57902 J=I-10
57903 CMS=RMQ(J)
57904 AB(1,J,1)=ISM*(CMS*C1*SFMIX(J,1) - SFMIX(J,2)
57905 & *ED*(C2-C3*SINW**2))
57906 AB(1,J,2)=ISM*(CMS*C1*SFMIX(J,3) - SFMIX(J,4)
57907 & *ED*(C2-C3*SINW**2))
57908 AB(2,J,1)=CMS*C1*SFMIX(J,2) + SFMIX(J,1)
57909 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57910 AB(2,J,2)=CMS*C1*SFMIX(J,4) + SFMIX(J,3)
57911 & *(ED*C2-C3*(1D0/2D0+ED*SINW**2))
57912C...Inermediate sup
57913 J=J+1
57914 CMS=RMQ(J)
57915 AB(1,J,1)=ISM*(CMS*C1U*SFMIX(J,1) - SFMIX(J,2)
57916 & *EU*(C2-C3*SINW**2))
57917 AB(1,J,2)=ISM*(CMS*C1U*SFMIX(J,3) - SFMIX(J,4)
57918 & *EU*(C2-C3*SINW**2))
57919 AB(2,J,1)=CMS*C1U*SFMIX(J,2) + SFMIX(J,1)
57920 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57921 AB(2,J,2)=CMS*C1U*SFMIX(J,4) + SFMIX(J,3)
57922 & *(EU*C2+C3*(1D0/2D0-EU*SINW**2))
57923 120 CONTINUE
57924
57925 IF (IMSS(51).GE.1) THEN
57926C...LAMBDA COUPLINGS (LLE TYPE R-VIOLATION)
57927C * CHI0_I -> NUBAR_I + LEPTON+_J + lEPTON-_K.
57928C...STEP IN I,J,K USING SINGLE COUNTER
57929 DO 130 ISC=0,26
57930C...LAMBDA COUPLING ASYM IN I,J
57931 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
57932 LKNT = LKNT+1
57933 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57934 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
57935 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
57936 XLAM(LKNT) = 0D0
57937C...Set coupling, and decay product masses on/off
57938 RVLAMC = RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57939 & ,MOD(ISC,3)+1)**2
57940 DCMASS=.FALSE.
57941 IF (IDLAM(LKNT,2).EQ.-15.OR.IDLAM(LKNT,3).EQ.15)
57942 & DCMASS = .TRUE.
57943C...Resonance KF codes (1=I,2=J,3=K)
57944 KFR(1)=-IDLAM(LKNT,1)
57945 KFR(2)=-IDLAM(LKNT,2)
57946 KFR(3)=-IDLAM(LKNT,3)
57947C...Calculate width.
57948 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
57949 & IDLAM(LKNT,3),XLAM(LKNT))
57950 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57951C...Charge conjugate mode.
57952 LKNT=LKNT+1
57953 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57954 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57955 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57956 XLAM(LKNT)=XLAM(LKNT-1)
57957C...KINEMATICS CHECK
57958 IF (XLAM(LKNT).EQ.0D0) THEN
57959 LKNT=LKNT-2
57960 ENDIF
57961 ENDIF
57962 130 CONTINUE
57963 ENDIF
57964
57965 IF (IMSS(52).GE.1) THEN
57966C...LAMBDA' COUPLINGS. (LQD TYPE R-VIOLATION)
57967C * CHI0 -> NUBAR_I + DBAR_J + D_K
57968 DO 140 ISC=0,26
57969 LKNT = LKNT+1
57970 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
57971 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
57972 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
57973 XLAM(LKNT) = 0D0
57974C...Set coupling, and decay product masses on/off
57975 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
57976 & ,MOD(ISC,3)+1)**2
57977 DCMASS=.FALSE.
57978 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5)
57979 & DCMASS = .TRUE.
57980C...Resonance KF codes (1=I,2=J,3=K)
57981 KFR(1)=-IDLAM(LKNT,1)
57982 KFR(2)=-IDLAM(LKNT,2)
57983 KFR(3)=-IDLAM(LKNT,3)
57984C...Calculate width.
57985 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
57986 & ,XLAM(LKNT))
57987 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
57988C...Charge conjugate mode.
57989 LKNT=LKNT+1
57990 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
57991 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
57992 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
57993 XLAM(LKNT)=XLAM(LKNT-1)
57994C...KINEMATICS CHECK
57995 IF (XLAM(LKNT).EQ.0D0) THEN
57996 LKNT=LKNT-2
57997 ENDIF
57998
57999C * CHI0 -> LEPTON_I+ + UBAR_J + D_K
58000 LKNT = LKNT+1
58001 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58002 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
58003 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
58004 XLAM(LKNT) = 0D0
58005C...Set coupling, and decay product masses on/off
58006 RVLAMC = 3 * RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1
58007 & ,MOD(ISC,3)+1)**2
58008 DCMASS=.FALSE.
58009 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
58010 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
58011C...Resonance KF codes (1=I,2=J,3=K)
58012 KFR(1)=-IDLAM(LKNT,1)
58013 KFR(2)=-IDLAM(LKNT,2)
58014 KFR(3)=-IDLAM(LKNT,3)
58015C...Calculate width.
58016 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58017 & ,XLAM(LKNT))
58018 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58019C...Charge conjugate mode.
58020 LKNT=LKNT+1
58021 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
58022 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
58023 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
58024 XLAM(LKNT)=XLAM(LKNT-1)
58025C...KINEMATICS CHECK
58026 IF (XLAM(LKNT).EQ.0D0) THEN
58027 LKNT=LKNT-2
58028 ENDIF
58029 140 CONTINUE
58030 ENDIF
58031
58032 IF (IMSS(53).GE.1) THEN
58033C...LAMBDA'' COUPLINGS. (UDD TYPE R-VIOLATION)
58034C * CHI0 -> UBAR_I + DBAR_J + DBAR_K
58035 DO 150 ISC=0,26
58036C...Symmetry J<->K. Also, LAMB antisymmetric in J and K, so no J=K.
58037 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
58038 LKNT = LKNT+1
58039 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
58040 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58041 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58042 XLAM(LKNT) = 0D0
58043C...Set coupling, and decay product masses on/off
58044 RVLAMC = 6. * RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)
58045 & +1,MOD(ISC,3)+1)**2
58046 DCMASS=.FALSE.
58047 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
58048 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
58049C...Resonance KF codes (1=I,2=J,3=K)
58050 KFR(1) = IDLAM(LKNT,1)
58051 KFR(2) = IDLAM(LKNT,2)
58052 KFR(3) = IDLAM(LKNT,3)
58053C...Calculate width.
58054 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58055 & IDLAM(LKNT,3),XLAM(LKNT))
58056 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58057C...Charge conjugate mode.
58058 LKNT=LKNT+1
58059 IDLAM(LKNT,1)=-IDLAM(LKNT-1,1)
58060 IDLAM(LKNT,2)=-IDLAM(LKNT-1,2)
58061 IDLAM(LKNT,3)=-IDLAM(LKNT-1,3)
58062 XLAM(LKNT)=XLAM(LKNT-1)
58063C...KINEMATICS CHECK
58064 IF (XLAM(LKNT).EQ.0D0) THEN
58065 LKNT=LKNT-2
58066 ENDIF
58067 ENDIF
58068 150 CONTINUE
58069 ENDIF
58070 ENDIF
58071 ENDIF
58072
58073 RETURN
58074 END
58075
58076C*********************************************************************
58077
58078C...PYRVCH
58079C...Calculates R-violating chargino decay widths.
58080C...P. Z. Skands
58081
58082 SUBROUTINE PYRVCH(KFIN,XLAM,IDLAM,LKNT)
58083
58084C...Double precision and integer declarations.
58085 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58086 IMPLICIT INTEGER(I-N)
58087C...Parameter statement to help give large particle numbers.
58088 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58089 &KEXCIT=4000000,KDIMEN=5000000)
58090C...Commonblocks.
58091 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58092 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58093 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
58094 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58095 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58096 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
58097C...Local variables.
58098 DOUBLE PRECISION XLAM(0:400)
58099 INTEGER IDLAM(400,3), PYCOMP
58100C...Information from main routine to PYRVGW
58101 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58102 & ,DCMASS,KFR(3)
58103C...Auxiliary variables needed for BV (RV Gauge STOre)
58104 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
58105 & ,RVLJKI,RVLJIK
58106C...Running quark masses
58107 DOUBLE PRECISION RMQ(6)
58108C...Decay product masses on/off
58109 LOGICAL DCMASS
58110 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
58111 & /RVGSTO/
58112
58113
58114C...IF R-VIOLATION ON.
58115 IF ((IMSS(51).GE.1).OR.(IMSS(52).GE.1).OR.(IMSS(53).GE.1)) THEN
58116 KFSM=KFIN-KSUSY1
58117 IF(KFSM.EQ.24.OR.KFSM.EQ.37) THEN
58118C...WHICH CHARGINO ?
58119 NCHI = 1
58120 IF (KFSM.EQ.37) NCHI = 2
58121
58122C...Useful parameters for calculating the A and B constants.
58123C...SIGN OF MASS (Opposite convention as HERWIG)
58124 ISM = 1
58125 IF (SMW(NCHI).LT.0D0) ISM = -1
58126 WMASS = PMAS(PYCOMP(24),1)
58127 COSB = 1/(SQRT(1+RMSS(5)**2))
58128 SINB = RMSS(5)/SQRT(1+RMSS(5)**2)
58129 GW2 = 4*PARU(103)*PARU(1)/PARU(102)
58130 C1U = UMIX(NCHI,2)/(SQRT(2D0)*COSB*WMASS)
58131 C1V = VMIX(NCHI,2)/(SQRT(2D0)*SINB*WMASS)
58132 C2 = UMIX(NCHI,1)
58133 C3 = VMIX(NCHI,1)
58134C...Running masses at Q^2=MCHI^2.
58135 SQMCHI = PMAS(PYCOMP(KFSM),1)**2
58136 DO 100 I=1,6
58137 RMQ(I)=PYMRUN(I,SQMCHI)
58138 100 CONTINUE
58139
58140C... AB(x,y,z) coefficients:
58141C x=1-2 : A or B coefficient (1:A ; 2:B)
58142C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
58143C 11-16:e,nu_e,mu,...)
58144C z=1-2 : Mass eigenstate number
58145 DO 110 I = 11,15,2
58146C...Intermediate sleptons
58147 AB(1,I,1) = 0D0
58148 AB(1,I,2) = 0D0
58149 AB(2,I,1) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,2) +
58150 & SFMIX(I,1)*C2
58151 AB(2,I,2) = -PMAS(PYCOMP(I),1)*C1U*SFMIX(I,4) +
58152 & SFMIX(I,3)*C2
58153C...Intermediate sneutrinos
58154 AB(1,I+1,1) = -PMAS(PYCOMP(I),1)*C1U
58155 AB(1,I+1,2) = 0D0
58156 AB(2,I+1,1) = ISM*C3
58157 AB(2,I+1,2) = 0D0
58158C...Intermediate sdown
58159 J=I-10
58160 AB(1,J,1) = -RMQ(J+1)*C1V*SFMIX(J,1)
58161 AB(1,J,2) = -RMQ(J+1)*C1V*SFMIX(J,3)
58162 AB(2,J,1) = -ISM*(RMQ(J)*C1U*SFMIX(J,2) - SFMIX(J,1)*C2)
58163 AB(2,J,2) = -ISM*(RMQ(J)*C1U*SFMIX(J,4) - SFMIX(J,3)*C2)
58164C...Intermediate sup
58165 J=J+1
58166 AB(1,J,1) = -RMQ(J-1)*C1U*SFMIX(J,1)
58167 AB(1,J,2) = -RMQ(J-1)*C1U*SFMIX(J,3)
58168 AB(2,J,1) = -ISM*(RMQ(J)*C1V*SFMIX(J,2) - SFMIX(J,1)*C3)
58169 AB(2,J,2) = -ISM*(RMQ(J)*C1V*SFMIX(J,4) - SFMIX(J,3)*C3)
58170 110 CONTINUE
58171
58172C...LLE TYPE R-VIOLATION
58173 IF (IMSS(51).GE.1) THEN
58174C...LOOP OVER DECAY MODES
58175 DO 140 ISC=0,26
58176
58177C...CHI+ -> NUBAR_I + LEPTON+_J + NU_K.
58178 IF(MOD(ISC/9,3).NE.MOD(ISC/3,3)) THEN
58179 LKNT = LKNT+1
58180 IDLAM(LKNT,1) = -12 -2*MOD(ISC/9,3)
58181 IDLAM(LKNT,2) = -11 -2*MOD(ISC/3,3)
58182 IDLAM(LKNT,3) = 12 +2*MOD(ISC,3)
58183 XLAM(LKNT) = 0D0
58184C...Set coupling, and decay product masses on/off
58185 RVLAMC = GW2 * 5D-1 *
58186 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
58187 & **2
58188 DCMASS=.FALSE.
58189 IF (IDLAM(LKNT,2).EQ.-15) DCMASS = .TRUE.
58190C...Resonance KF codes (1=I,2=J,3=K).
58191 KFR(1) = 0
58192 KFR(2) = 0
58193 KFR(3) = -IDLAM(LKNT,3)+1
58194C...Calculate width.
58195 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58196 & IDLAM(LKNT,3),XLAM(LKNT))
58197 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58198C...KINEMATICS CHECK
58199 IF (XLAM(LKNT).EQ.0D0) THEN
58200 LKNT=LKNT-1
58201 ENDIF
58202
58203C * CHI+ -> NU_I + NU_J + LEPTON+_K. (NOTE: SYMM. IN I AND J)
58204 120 IF (MOD(ISC/9,3).LT.MOD(ISC/3,3)) THEN
58205 LKNT = LKNT+1
58206 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
58207 IDLAM(LKNT,2) = 12 +2*MOD(ISC/3,3)
58208 IDLAM(LKNT,3) =-11 -2*MOD(ISC,3)
58209 XLAM(LKNT) = 0D0
58210C...Set coupling, and decay product masses on/off
58211 RVLAMC = GW2 * 5D-1 *
58212 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58213C...I,J SYMMETRY => FACTOR 2
58214 RVLAMC=2*RVLAMC
58215 DCMASS=.FALSE.
58216 IF (IDLAM(LKNT,3).EQ.-15) DCMASS = .TRUE.
58217C...Resonance KF codes (1=I,2=J,3=K)
58218 KFR(1)=IDLAM(LKNT,1)-1
58219 KFR(2)=IDLAM(LKNT,2)-1
58220 KFR(3)=0
58221C...Calculate width.
58222 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58223 & IDLAM(LKNT,3),XLAM(LKNT))
58224 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58225C...KINEMATICS CHECK
58226 IF (XLAM(LKNT).EQ.0D0) THEN
58227 LKNT=LKNT-1
58228 ENDIF
58229
58230C * CHI+ -> LEPTON+_I + LEPTON+_J + LEPTON-_K (NOTE: SYMM. IN I AND J)
58231C * 19/04 2010: Bug corrected. Moved channel inside the I < J IF statement
58232C * from above, thanks to N.-E. Bomark.
58233 LKNT = LKNT+1
58234 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58235 IDLAM(LKNT,2) =-11 -2*MOD(ISC/3,3)
58236 IDLAM(LKNT,3) = 11 +2*MOD(ISC,3)
58237 XLAM(LKNT) = 0D0
58238C...Set coupling, and decay product masses on/off
58239 RVLAMC = GW2 * 5D-1 *
58240 & RVLAM(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58241C...I,J SYMMETRY => FACTOR 2
58242 RVLAMC=2*RVLAMC
58243 DCMASS=.FALSE.
58244 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-15
58245 & .OR.IDLAM(LKNT,3).EQ.15) DCMASS = .TRUE.
58246C...Resonance KF codes (1=I,2=J,3=K)
58247 KFR(1) =-IDLAM(LKNT,1)+1
58248 KFR(2) =-IDLAM(LKNT,2)+1
58249 KFR(3) = 0
58250C...Calculate width.
58251 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58252 & IDLAM(LKNT,3),XLAM(LKNT))
58253 XLAM(LKNT)=XLAM(LKNT)*RVLAMC
58254 & /((2*PARU(1)*RMS(0))**3*32)
58255C...KINEMATICS CHECK
58256 IF (XLAM(LKNT).EQ.0D0) THEN
58257 LKNT=LKNT-1
58258 ENDIF
58259 ENDIF
58260 ENDIF
58261 140 CONTINUE
58262 ENDIF
58263
58264C...LQD TYPE R-VIOLATION
58265 IF (IMSS(52).GE.1) THEN
58266C...LOOP OVER DECAY MODES
58267 DO 180 ISC=0,26
58268
58269C...CHI+ -> NUBAR_I + DBAR_J + U_K
58270 LKNT = LKNT+1
58271 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
58272 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58273 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
58274 XLAM(LKNT) = 0D0
58275C...Set coupling, and decay product masses on/off
58276 RVLAMC = 3. * GW2 * 5D-1 *
58277 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58278 DCMASS=.FALSE.
58279 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.6)
58280 & DCMASS = .TRUE.
58281C...Resonance KF codes (1=I,2=J,3=K)
58282 KFR(1)=0
58283 KFR(2)=0
58284 KFR(3)=-IDLAM(LKNT,3)+1
58285C...Calculate width.
58286 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58287 & ,XLAM(LKNT))
58288 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58289C...KINEMATICS CHECK
58290 IF (XLAM(LKNT).EQ.0D0) THEN
58291 LKNT=LKNT-1
58292 ENDIF
58293
58294C * CHI+ -> LEPTON+_I + UBAR_J + U_K.
58295 150 LKNT = LKNT+1
58296 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58297 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
58298 IDLAM(LKNT,3) = 2 +2*MOD(ISC,3)
58299 XLAM(LKNT) = 0D0
58300C...Set coupling, and decay product masses on/off
58301 RVLAMC = 3. * GW2 * 5D-1 *
58302 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58303 DCMASS=.FALSE.
58304 IF (IDLAM(LKNT,1).EQ.-11.OR.IDLAM(LKNT,2).EQ.-6
58305 & .OR.IDLAM(LKNT,3).EQ.6) DCMASS = .TRUE.
58306C...Resonance KF codes (1=I,2=J,3=K)
58307 KFR(1)=0
58308 KFR(2)=0
58309 KFR(3)=-IDLAM(LKNT,3)+1
58310C...Calculate width.
58311 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58312 & ,XLAM(LKNT))
58313 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58314C...KINEMATICS CHECK
58315 IF (XLAM(LKNT).EQ.0D0) THEN
58316 LKNT=LKNT-1
58317 ENDIF
58318
58319C * CHI+ -> LEPTON+_I + DBAR_J + D_K.
58320 160 LKNT = LKNT+1
58321 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58322 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58323 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
58324 XLAM(LKNT) = 0D0
58325C...Set coupling, and decay product masses on/off
58326 RVLAMC = 3. * GW2 * 5D-1 *
58327 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58328 DCMASS = .FALSE.
58329 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-5
58330 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
58331C...Resonance KF codes (1=I,2=J,3=K)
58332 KFR(1)=-IDLAM(LKNT,1)+1
58333 KFR(2)=-IDLAM(LKNT,2)+1
58334 KFR(3)=0
58335C...Calculate width.
58336 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58337 & ,XLAM(LKNT))
58338 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58339C...KINEMATICS CHECK
58340 IF (XLAM(LKNT).EQ.0D0) THEN
58341 LKNT=LKNT-1
58342 ENDIF
58343
58344C * CHI+ -> NU_I + U_J + DBAR_K.
58345 170 LKNT = LKNT+1
58346 IDLAM(LKNT,1) = 12 +2*MOD(ISC/9,3)
58347 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
58348 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58349 XLAM(LKNT) = 0D0
58350C...Set coupling, and decay product masses on/off
58351 DCMASS = .FALSE.
58352 RVLAMC = 3. * GW2 * 5D-1 *
58353 & RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58354 IF (IDLAM(LKNT,2).EQ.6.OR.IDLAM(LKNT,3).EQ.-5)
58355 & DCMASS = .TRUE.
58356C...Resonance KF codes (1=I,2=J,3=K)
58357 KFR(1)=IDLAM(LKNT,1)-1
58358 KFR(2)=IDLAM(LKNT,2)-1
58359 KFR(3)=0
58360C...Calculate width.
58361 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58362 & ,XLAM(LKNT))
58363 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58364C...KINEMATICS CHECK
58365 IF (XLAM(LKNT).EQ.0D0) THEN
58366 LKNT=LKNT-1
58367 ENDIF
58368
58369 180 CONTINUE
58370 ENDIF
58371
58372C...UDD TYPE R-VIOLATION
58373C...These decays need special treatment since more than one BV coupling
58374C...contributes (with interference). Consider e.g. (symbolically)
58375C |M|^2 = |l''_{ijk}|^2*(PYRVI1(RES_I) + PYRVI2(RES_I))
58376C +|l''_{jik}|^2*(PYRVI1(RES_J) + PYRVI2(RES_J))
58377C +l''_{ijk}*l''_{jik}*PYRVI3(PYRVI4(RES_I,RES_J))
58378C...The problem is that a single call to PYRVGW would evaluate all
58379C...these terms and sum them, but without the different couplings. The
58380C...way out is to call PYRVGW three times, once for the first line, once
58381C...for the second line, and then once for all the lines (it is
58382C...impossible to get just the last line out) without multiplying by
58383C...couplings. The last line is then obtained as the result of the third
58384C...call minus the results of the two first calls. Each term is then
58385C...multiplied by its respective coupling before the whole thing is
58386C...summed up in XLAM.
58387C...Note that with three interfering resonances, this procedure becomes
58388C...more complicated, as can be seen in the CHI+ -> 3*DBAR mode.
58389
58390 IF (IMSS(53).GE.1) THEN
58391C...LOOP OVER DECAY MODES
58392 DO 190 ISC=1,25
58393
58394C...CHI+ -> U_I + U_J + D_K
58395C...Decay mode I<->J symmetric.
58396 IF (MOD(ISC/9,3).LE.MOD(ISC/3,3).AND.ISC.NE.13) THEN
58397 LKNT = LKNT+1
58398 IDLAM(LKNT,1) = 2 +2*MOD(ISC/9,3)
58399 IDLAM(LKNT,2) = 2 +2*MOD(ISC/3,3)
58400 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
58401 XLAM(LKNT) = 0D0
58402C...Set coupling, and decay product masses on/off
58403 RVLAMC= 6. * GW2 * 5D-1
58404 RVLJIK= RVLAMB(MOD(ISC/3,3)+1,MOD(ISC/9,3)+1,MOD(ISC,3)
58405 & +1)
58406 RVLIJK= RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
58407 & +1)
58408 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3)) RVLAMC = 5D-1
58409 & * RVLAMC
58410 DCMASS=.FALSE.
58411 IF (IDLAM(LKNT,1).EQ.6.OR.IDLAM(LKNT,2).EQ.6
58412 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS =.TRUE.
58413C...Resonance KF codes (1=I,2=J,3=K)
58414 KFR(1) = -IDLAM(LKNT,1)+1
58415 KFR(2) = 0
58416 KFR(3) = 0
58417C...Calculate width.
58418 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58419 & IDLAM(LKNT,3),XRESI)
58420C...Resonance KF codes (1=I,2=J,3=K)
58421 KFR(1) = 0
58422 KFR(2) = -IDLAM(LKNT,2)+1
58423 KFR(3) = 0
58424C...Calculate width.
58425 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58426 & IDLAM(LKNT,3),XRESJ)
58427C...Resonance KF codes (1=I,2=J,3=K)
58428 KFR(1) = -IDLAM(LKNT,1)+1
58429 KFR(2) = -IDLAM(LKNT,2)+1
58430 KFR(3) = 0
58431C...Calculate width.
58432 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58433 & IDLAM(LKNT,3),XRESIJ)
58434 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
58435 XRESIJ = XRESIJ-XRESI-XRESJ
58436 ELSE
58437 XRESIJ = 0D0
58438 ENDIF
58439C...CALCULATE TOTAL WIDTH
58440 XLAM(LKNT) = RVLJIK**2 * XRESI + RVLIJK**2 * XRESJ
58441 & + RVLJIK*RVLIJK * XRESIJ
58442 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58443C...KINEMATICS CHECK
58444 IF (XLAM(LKNT).EQ.0D0) THEN
58445 LKNT=LKNT-1
58446 ENDIF
58447 ENDIF
58448C...CHI+ -> DBAR_I + DBAR_J + DBAR_K
58449C...Symmetry I<->J<->K.
58450 IF ((MOD(ISC/9,3).LE.MOD(ISC/3,3)).AND.(MOD(ISC/3,3).LE
58451 & .MOD(ISC,3)).AND.ISC.NE.13) THEN
58452 LKNT = LKNT+1
58453 IDLAM(LKNT,1) = -1 -2*MOD(ISC/9,3)
58454 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58455 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58456 XLAM(LKNT) = 0D0
58457C...Set coupling, and decay product masses on/off
58458 RVLAMC = 6. * GW2 * 5D-1
58459 RVLIJK = RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)
58460 & +1)
58461 RVLKIJ = RVLAMB(MOD(ISC,3)+1,MOD(ISC/9,3)+1,MOD(ISC/3,3)
58462 & +1)
58463 RVLJKI = RVLAMB(MOD(ISC/3,3)+1,MOD(ISC,3)+1,MOD(ISC/9,3)
58464 & +1)
58465 DCMASS = .FALSE.
58466 IF (IDLAM(LKNT,1).EQ.-5.OR.IDLAM(LKNT,2).EQ.-5
58467 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS = .TRUE.
58468C...Collect symmetry factors
58469 IF (MOD(ISC/9,3).EQ.MOD(ISC/3,3).OR.MOD(ISC/3,3).EQ
58470 & .MOD(ISC,3).OR.MOD(ISC/9,3).EQ.MOD(ISC,3))
58471 & RVLAMC = 5D-1 * RVLAMC
58472C...Resonance KF codes (1=I,2=J,3=K)
58473 KFR(1) = IDLAM(LKNT,1)-1
58474 KFR(2) = 0
58475 KFR(3) = 0
58476C...Calculate width.
58477 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58478 & IDLAM(LKNT,3),XRESI)
58479C...Resonance KF codes (1=I,2=J,3=K)
58480 KFR(1) = 0
58481 KFR(2) = IDLAM(LKNT,2)-1
58482 KFR(3) = 0
58483C...Calculate width.
58484 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58485 & IDLAM(LKNT,3),XRESJ)
58486C...Resonance KF codes (1=I,2=J,3=K)
58487 KFR(1) = 0
58488 KFR(2) = 0
58489 KFR(3) = IDLAM(LKNT,3)-1
58490C...Calculate width.
58491 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58492 & IDLAM(LKNT,3),XRESK)
58493C...Resonance KF codes (1=I,2=J,3=K)
58494 KFR(1) = IDLAM(LKNT,1)-1
58495 KFR(2) = IDLAM(LKNT,2)-1
58496 KFR(3) = 0
58497C...Calculate width.
58498 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58499 & IDLAM(LKNT,3),XRESIJ)
58500 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*(XRESI+XRESJ)) THEN
58501 XRESIJ = XRESI+XRESJ-XRESIJ
58502 ELSE
58503 XRESIJ = 0D0
58504 ENDIF
58505C...Resonance KF codes (1=I,2=J,3=K)
58506 KFR(1) = 0
58507 KFR(2) = IDLAM(LKNT,2)-1
58508 KFR(3) = IDLAM(LKNT,3)-1
58509C...Calculate width.
58510 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58511 & IDLAM(LKNT,3),XRESJK)
58512 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*(XRESJ+XRESK)) THEN
58513 XRESJK = XRESJ+XRESK-XRESJK
58514 ELSE
58515 XRESJK = 0D0
58516 ENDIF
58517C...Resonance KF codes (1=I,2=J,3=K)
58518 KFR(1) = IDLAM(LKNT,1)-1
58519 KFR(2) = 0
58520 KFR(3) = IDLAM(LKNT,3)-1
58521C...Calculate width.
58522 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),
58523 & IDLAM(LKNT,3),XRESIK)
58524 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*(XRESI+XRESK)) THEN
58525 XRESIK = XRESI+XRESK-XRESIK
58526 ELSE
58527 XRESIK = 0D0
58528 ENDIF
58529C...CALCULATE TOTAL WIDTH
58530 XLAM(LKNT) =
58531 & RVLIJK**2 * XRESI
58532 & + RVLJKI**2 * XRESJ
58533 & + RVLKIJ**2 * XRESK
58534 & + RVLIJK*RVLJKI * XRESIJ
58535 & + RVLIJK*RVLKIJ * XRESIK
58536 & + RVLJKI*RVLKIJ * XRESJK
58537 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2.*PARU(1)*RMS(0))**3*32)
58538C...KINEMATICS CHECK
58539 IF (XLAM(LKNT).EQ.0D0) THEN
58540 LKNT=LKNT-1
58541 ENDIF
58542 ENDIF
58543 190 CONTINUE
58544 ENDIF
58545 ENDIF
58546 ENDIF
58547
58548 RETURN
58549 END
58550
58551C*********************************************************************
58552
58553C...PYRVGL
58554C...Calculates R-violating gluino decay widths.
58555C...See BV part of PYRVCH for comments about the way the BV decay width
58556C...is calculated. Same comments apply here.
58557C...P. Z. Skands
58558
58559 SUBROUTINE PYRVGL(KFIN,XLAM,IDLAM,LKNT)
58560
58561C...Double precision and integer declarations.
58562 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
58563 IMPLICIT INTEGER(I-N)
58564C...Parameter statement to help give large particle numbers.
58565 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58566 &KEXCIT=4000000,KDIMEN=5000000)
58567C...Commonblocks.
58568 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58569 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58570 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
58571 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58572 &SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58573 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
58574C...Local variables.
58575 DOUBLE PRECISION XLAM(0:400)
58576 INTEGER IDLAM(400,3), PYCOMP
58577C...Information from main routine to PYRVGW
58578 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58579 & ,DCMASS,KFR(3)
58580C...Auxiliary variables needed for BV (RV Gauge STOre)
58581 COMMON/RVGSTO/XRESI,XRESJ,XRESK,XRESIJ,XRESIK,XRESJK,RVLIJK,RVLKIJ
58582 & ,RVLJKI,RVLJIK
58583C...Running quark masses
58584 DOUBLE PRECISION RMQ(6)
58585C...Decay product masses on/off
58586 LOGICAL DCMASS
58587 SAVE /PYDAT1/,/PYDAT2/,/PYMSSM/,/PYSSMT/,/PYMSRV/,/PYRVNV/,
58588 & /RVGSTO/
58589
58590C...IF LQD OR UDD TYPE R-VIOLATION ON.
58591 IF (IMSS(52).GE.1.OR.IMSS(53).GE.1) THEN
58592 KFSM=KFIN-KSUSY1
58593
58594C... AB(x,y,z):
58595C x=1-2 : Select A or B coupling (1:A ; 2:B)
58596C y=1-16 : Sparticle's SM code (1-6:d,u,s,c,b,t ;
58597C 11-16:e,nu_e,mu,... not used here)
58598C z=1-2 : Mass eigenstate number
58599 DO 100 I = 1,6
58600C...A Couplings
58601 AB(1,I,1) = SFMIX(I,2)
58602 AB(1,I,2) = SFMIX(I,4)
58603C...B Couplings
58604 AB(2,I,1) = -SFMIX(I,1)
58605 AB(2,I,2) = -SFMIX(I,3)
58606 100 CONTINUE
58607 GSTR2 = 4D0*PARU(1) * PYALPS(PMAS(PYCOMP(KFIN),1)**2)
58608C...LQD DECAYS.
58609 IF (IMSS(52).GE.1) THEN
58610C...STEP IN I,J,K USING SINGLE COUNTER
58611 DO 120 ISC=0,26
58612C * GLUINO -> NUBAR_I + DBAR_J + D_K.
58613 LKNT = LKNT+1
58614 IDLAM(LKNT,1) =-12 -2*MOD(ISC/9,3)
58615 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58616 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
58617 XLAM(LKNT)=0D0
58618C...Set coupling, and decay product masses on/off
58619 RVLAMC=RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)**2
58620 & * 5D-1 * GSTR2
58621 DCMASS = .FALSE.
58622 IF (IDLAM(LKNT,2).EQ.-5.OR.IDLAM(LKNT,3).EQ.5) DCMASS=.TRUE.
58623C...Resonance KF codes (1=I,2=J,3=K)
58624 KFR(1) = 0
58625 KFR(2) = -IDLAM(LKNT,2)
58626 KFR(3) = -IDLAM(LKNT,3)
58627C...Calculate width.
58628 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58629 & ,XLAM(LKNT))
58630C...Normalize
58631 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58632C...Charge conjugate mode.
58633 110 LKNT = LKNT+1
58634 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
58635 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
58636 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
58637 XLAM(LKNT) = XLAM(LKNT-1)
58638C...KINEMATICS CHECK
58639 IF (XLAM(LKNT).EQ.0D0) THEN
58640 LKNT=LKNT-2
58641 ENDIF
58642
58643C * GLUINO -> LEPTON+_I + UBAR_J + D_K
58644 LKNT = LKNT+1
58645 IDLAM(LKNT,1) =-11 -2*MOD(ISC/9,3)
58646 IDLAM(LKNT,2) = -2 -2*MOD(ISC/3,3)
58647 IDLAM(LKNT,3) = 1 +2*MOD(ISC,3)
58648 XLAM(LKNT)=0D0
58649C...Set coupling, and decay product masses on/off
58650 RVLAMC = RVLAMP(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
58651 & **2* 5D-1 * GSTR2
58652 DCMASS = .FALSE.
58653 IF (IDLAM(LKNT,1).EQ.-15.OR.IDLAM(LKNT,2).EQ.-6
58654 & .OR.IDLAM(LKNT,3).EQ.5) DCMASS = .TRUE.
58655C...Resonance KF codes (1=I,2=J,3=K)
58656 KFR(1) = 0
58657 KFR(2) = -IDLAM(LKNT,2)
58658 KFR(3) = -IDLAM(LKNT,3)
58659C...Calculate width.
58660 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58661 & ,XLAM(LKNT))
58662 XLAM(LKNT)=XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58663C...Charge conjugate mode.
58664 LKNT=LKNT+1
58665 IDLAM(LKNT,1) = -IDLAM(LKNT-1,1)
58666 IDLAM(LKNT,2) = -IDLAM(LKNT-1,2)
58667 IDLAM(LKNT,3) = -IDLAM(LKNT-1,3)
58668 XLAM(LKNT) = XLAM(LKNT-1)
58669C...KINEMATICS CHECK
58670 IF (XLAM(LKNT).EQ.0D0) THEN
58671 LKNT=LKNT-2
58672 ENDIF
58673
58674 120 CONTINUE
58675 ENDIF
58676
58677C...UDD DECAYS.
58678 IF (IMSS(53).GE.1) THEN
58679C...STEP IN I,J,K USING SINGLE COUNTER
58680 DO 130 ISC=0,26
58681C * GLUINO -> UBAR_I + DBAR_J + DBAR_K.
58682 IF (MOD(ISC/3,3).LT.MOD(ISC,3)) THEN
58683 LKNT = LKNT+1
58684 IDLAM(LKNT,1) = -2 -2*MOD(ISC/9,3)
58685 IDLAM(LKNT,2) = -1 -2*MOD(ISC/3,3)
58686 IDLAM(LKNT,3) = -1 -2*MOD(ISC,3)
58687 XLAM(LKNT)=0D0
58688C...Set coupling, and decay product masses on/off. A factor of 2 for
58689C...(N_C-1) has been used to cancel a factor 0.5.
58690 RVLAMC=RVLAMB(MOD(ISC/9,3)+1,MOD(ISC/3,3)+1,MOD(ISC,3)+1)
58691 & **2 * GSTR2
58692 DCMASS = .FALSE.
58693 IF (IDLAM(LKNT,1).EQ.-6.OR.IDLAM(LKNT,2).EQ.-5
58694 & .OR.IDLAM(LKNT,3).EQ.-5) DCMASS=.TRUE.
58695C...Resonance KF codes (1=I,2=J,3=K)
58696 KFR(1) = IDLAM(LKNT,1)
58697 KFR(2) = 0
58698 KFR(3) = 0
58699C...Calculate width.
58700 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58701 & ,XRESI)
58702C...Resonance KF codes (1=I,2=J,3=K)
58703 KFR(1) = 0
58704 KFR(2) = IDLAM(LKNT,2)
58705 KFR(3) = 0
58706C...Calculate width.
58707 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58708 & ,XRESJ)
58709C...Resonance KF codes (1=I,2=J,3=K)
58710 KFR(1) = 0
58711 KFR(2) = 0
58712 KFR(3) = IDLAM(LKNT,3)
58713C...Calculate width.
58714 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58715 & ,XRESK)
58716C...Resonance KF codes (1=I,2=J,3=K)
58717 KFR(1) = IDLAM(LKNT,1)
58718 KFR(2) = IDLAM(LKNT,2)
58719 KFR(3) = 0
58720C...Calculate width.
58721 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58722 & ,XRESIJ)
58723C...Calculate interference function. (Factor -1/2 to make up for factor
58724C...-2 in PYRVGW.
58725 IF (ABS(XRESI+XRESJ-XRESIJ).GT.1D-4*XRESIJ) THEN
58726 XRESIJ = 5D-1 * (XRESI+XRESJ-XRESIJ)
58727 ELSE
58728 XRESIJ = 0D0
58729 ENDIF
58730C...Resonance KF codes (1=I,2=J,3=K)
58731 KFR(1) = 0
58732 KFR(2) = IDLAM(LKNT,2)
58733 KFR(3) = IDLAM(LKNT,3)
58734C...Calculate width.
58735 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58736 & ,XRESJK)
58737 IF (ABS(XRESJ+XRESK-XRESJK).GT.1D-4*XRESJK) THEN
58738 XRESJK = 5D-1 * (XRESJ+XRESK-XRESJK)
58739 ELSE
58740 XRESJK = 0D0
58741 ENDIF
58742C...Resonance KF codes (1=I,2=J,3=K)
58743 KFR(1) = IDLAM(LKNT,1)
58744 KFR(2) = 0
58745 KFR(3) = IDLAM(LKNT,3)
58746C...Calculate width.
58747 CALL PYRVGW(KFIN,IDLAM(LKNT,1),IDLAM(LKNT,2),IDLAM(LKNT,3)
58748 & ,XRESIK)
58749 IF (ABS(XRESI+XRESK-XRESIK).GT.1D-4*XRESIK) THEN
58750 XRESIK = 5D-1 * (XRESI+XRESK-XRESIK)
58751 ELSE
58752 XRESIK = 0D0
58753 ENDIF
58754C...Calculate total width (factor 1/2 from 1/(N_C-1))
58755 XLAM(LKNT) = XRESI + XRESJ + XRESK
58756 & + 5D-1 * (XRESIJ + XRESIK + XRESJK)
58757C...Normalize
58758 XLAM(LKNT) = XLAM(LKNT)*RVLAMC/((2*PARU(1)*RMS(0))**3*32)
58759C...Charge conjugate mode.
58760 LKNT = LKNT+1
58761 IDLAM(LKNT,1) =-IDLAM(LKNT-1,1)
58762 IDLAM(LKNT,2) =-IDLAM(LKNT-1,2)
58763 IDLAM(LKNT,3) =-IDLAM(LKNT-1,3)
58764 XLAM(LKNT) = XLAM(LKNT-1)
58765C...KINEMATICS CHECK
58766 IF (XLAM(LKNT).EQ.0D0) THEN
58767 LKNT=LKNT-2
58768 ENDIF
58769 ENDIF
58770 130 CONTINUE
58771 ENDIF
58772 ENDIF
58773 RETURN
58774 END
58775
58776C*********************************************************************
58777
58778C...PYRVSB
58779C...Auxiliary function to PYRVSF for calculating R-Violating
58780C...sfermion widths. Though the decay products are most often treated
58781C...as massless in the calculation, the kinematical boundary of phase
58782C...space is tested using the true masses.
58783C...MODE = 1: All decay products massive
58784C...MODE = 2: Decay product 1 massless
58785C...MODE = 3: Decay product 2 massless
58786C...MODE = 4: All decay products massless
58787
58788 FUNCTION PYRVSB(KFIN,ID1,ID2,RM2,MODE)
58789
58790 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
58791 IMPLICIT INTEGER (I-N)
58792 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
58793 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58794 SAVE /PYDAT1/,/PYDAT2/
58795 DOUBLE PRECISION SM(3)
58796 INTEGER PYCOMP, KC(3)
58797 KC(1)=PYCOMP(KFIN)
58798 KC(2)=PYCOMP(ID1)
58799 KC(3)=PYCOMP(ID2)
58800 SM(1)=PMAS(KC(1),1)**2
58801 SM(2)=PMAS(KC(2),1)**2
58802 SM(3)=PMAS(KC(3),1)**2
58803C...Kinematics check
58804 IF ((SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2).LE.0D0) THEN
58805 PYRVSB=0D0
58806 RETURN
58807 ENDIF
58808C...CM momenta squared
58809 IF (MODE.EQ.1) THEN
58810 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1)+PMAS(KC(3),1))**2)
58811 & * (SM(1)-(PMAS(KC(2),1)-PMAS(KC(3),1))**2)
58812 ELSE IF (MODE.EQ.2) THEN
58813 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(3),1))**2)**2
58814 ELSE IF (MODE.EQ.3) THEN
58815 P2CM=1./(4*SM(1))*(SM(1)-(PMAS(KC(2),1))**2)**2
58816 ELSE
58817 P2CM=SM(1)/4.
58818 ENDIF
58819C...Calculate Width
58820 PYRVSB=RM2*SQRT(MAX(0D0,P2CM))/(8*PARU(1)*SM(1))
58821 RETURN
58822 END
58823
58824C*********************************************************************
58825
58826C...PYRVGW
58827C...Generalized Matrix Element for R-Violating 3-body widths.
58828C...P. Z. Skands
58829 SUBROUTINE PYRVGW(KFIN,ID1,ID2,ID3,XLAM)
58830
58831 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
58832 IMPLICIT INTEGER (I-N)
58833 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
58834 &KEXCIT=4000000,KDIMEN=5000000)
58835 PARAMETER (EPS=1D-4)
58836 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
58837 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
58838 & ,DCMASS,KFR(3)
58839 COMMON/PYSSMT/ZMIX(4,4),UMIX(2,2),VMIX(2,2),SMZ(4),SMW(2),
58840 & SFMIX(16,4),ZMIXI(4,4),UMIXI(2,2),VMIXI(2,2)
58841 DOUBLE PRECISION XLIM(3,3)
58842 INTEGER KC(0:3), PYCOMP
58843 LOGICAL DCMASS, DCHECK(6)
58844 SAVE /PYDAT2/,/PYRVNV/,/PYSSMT/
58845
58846 XLAM = 0D0
58847
58848 KC(0) = PYCOMP(KFIN)
58849 KC(1) = PYCOMP(ID1)
58850 KC(2) = PYCOMP(ID2)
58851 KC(3) = PYCOMP(ID3)
58852 RMS(0) = PMAS(KC(0),1)
58853 RMS(1) = PYMRUN(ID1,PMAS(KC(1),1)**2)
58854 RMS(2) = PYMRUN(ID2,PMAS(KC(2),1)**2)
58855 RMS(3) = PYMRUN(ID3,PMAS(KC(3),1)**2)
58856C...INITIALIZE OUTER INTEGRATION LIMITS AND KINEMATICS CHECK
58857 XLIM(1,1)=(RMS(1)+RMS(2))**2
58858 XLIM(1,2)=(RMS(0)-RMS(3))**2
58859 XLIM(1,3)=XLIM(1,2)-XLIM(1,1)
58860 XLIM(2,1)=(RMS(2)+RMS(3))**2
58861 XLIM(2,2)=(RMS(0)-RMS(1))**2
58862 XLIM(2,3)=XLIM(2,2)-XLIM(2,1)
58863 XLIM(3,1)=(RMS(1)+RMS(3))**2
58864 XLIM(3,2)=(RMS(0)-RMS(2))**2
58865 XLIM(3,3)=XLIM(3,2)-XLIM(3,1)
58866C...Check Phase Space
58867 IF (XLIM(1,3).LT.0D0.OR.XLIM(2,3).LT.0D0.OR.XLIM(3,3).LT.0D0) THEN
58868 RETURN
58869 ENDIF
58870
58871C...INITIALIZE RESONANCE INFORMATION
58872 DO 110 JRES = 1,3
58873 DO 100 IMASS = 1,2
58874 IRES = 2*(JRES-1)+IMASS
58875 INTRES(IRES,1) = 0
58876 DCHECK(IRES) =.FALSE.
58877C...NO RIGHT-HANDED NEUTRINOS
58878 IF (((IMASS.EQ.2).AND.((IABS(KFR(JRES)).EQ.12).OR
58879 & .(IABS(KFR(JRES)).EQ.14).OR.(IABS(KFR(JRES)).EQ.16))).OR
58880 & .KFR(JRES).EQ.0) GOTO 100
58881 RES(IRES,1) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),1)
58882 RES(IRES,2) = PMAS(PYCOMP(IMASS*KSUSY1+IABS(KFR(JRES))),2)
58883 INTRES(IRES,1) = IABS(KFR(JRES))
58884 INTRES(IRES,2) = IMASS
58885 IF (KFR(JRES).LT.0) INTRES(IRES,3) = 1
58886 IF (KFR(JRES).GT.0) INTRES(IRES,3) = 0
58887 100 CONTINUE
58888 110 CONTINUE
58889
58890C...SUM OVER DIAGRAMS AND INTEGRATE OVER PHASE SPACE
58891
58892C...RESONANCE CONTRIBUTIONS
58893C...(Only sum contributions where the resonance is off shell).
58894C...Store whether diagram on/off in DCHECK.
58895C...LOOP OVER MASS STATES
58896 DO 120 J=1,2
58897 IDR=J
58898 IF(INTRES(IDR,1).NE.0) THEN
58899
58900 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58901 IF ((RMS(0).LT.(RMS(1)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(2)
58902 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58903 DCHECK(IDR) =.TRUE.
58904 XLAM = XLAM + TMIX * PYRVI1(2,3,1)
58905 ENDIF
58906 ENDIF
58907
58908 IDR=J+2
58909 IF(INTRES(IDR,1).NE.0) THEN
58910 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58911 IF ((RMS(0).LT.(RMS(2)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58912 & +RMS(3)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58913 DCHECK(IDR) =.TRUE.
58914 XLAM = XLAM + TMIX * PYRVI1(1,3,2)
58915 ENDIF
58916 ENDIF
58917
58918 IDR=J+4
58919 IF(INTRES(IDR,1).NE.0) THEN
58920 TMIX = SFMIX(INTRES(IDR,1),2*J+INTRES(IDR,3)-1)**2
58921 IF ((RMS(0).LT.(RMS(3)+RES(IDR,1)).OR.(RES(IDR,1).LT.(RMS(1)
58922 & +RMS(2)))).AND.TMIX.GT.EPS.AND.INTRES(IDR,1).NE.0) THEN
58923 DCHECK(IDR) =.TRUE.
58924 XLAM = XLAM + TMIX * PYRVI1(1,2,3)
58925 ENDIF
58926 ENDIF
58927 120 CONTINUE
58928C... L-R INTERFERENCES
58929C... (Only add contributions where both contributing diagrams
58930C... are non-resonant).
58931 IDR=1
58932 IF (DCHECK(1).AND.DCHECK(2)) THEN
58933C...Bug corrected 11/12 2001. Skands.
58934 XLAM = XLAM + 2D0 * PYRVI2(2,3,1)
58935 & * SFMIX(INTRES(1,1),2+INTRES(1,3)-1)
58936 & * SFMIX(INTRES(2,1),4+INTRES(2,3)-1)
58937 ENDIF
58938
58939 IDR=3
58940 IF (DCHECK(3).AND.DCHECK(4)) THEN
58941 XLAM = XLAM + 2D0 * PYRVI2(1,3,2)
58942 & * SFMIX(INTRES(3,1),2+INTRES(3,3)-1)
58943 & * SFMIX(INTRES(4,1),4+INTRES(4,3)-1)
58944 ENDIF
58945
58946 IDR=5
58947 IF (DCHECK(5).AND.DCHECK(6)) THEN
58948 XLAM = XLAM + 2D0 * PYRVI2(1,2,3)
58949 & * SFMIX(INTRES(5,1),2+INTRES(5,3)-1)
58950 & * SFMIX(INTRES(6,1),4+INTRES(6,3)-1)
58951 ENDIF
58952C... TRUE INTERFERENCES
58953C... (Only add contributions where both contributing diagrams
58954C... are non-resonant).
58955 PREF=-2D0
58956 IF ((KFIN-KSUSY1).EQ.24.OR.(KFIN-KSUSY1).EQ.37) PREF=2D0
58957 DO 140 IKR1 = 1,2
58958 DO 130 IKR2 = 1,2
58959 IDR = IKR1+2
58960 IDR2 = IKR2
58961 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58962 XLAM = XLAM + PREF*PYRVI3(1,3,2) *
58963 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58964 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58965 ENDIF
58966
58967 IDR = IKR1+4
58968 IDR2 = IKR2
58969 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58970 XLAM = XLAM + PREF*PYRVI3(1,2,3) *
58971 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58972 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58973 ENDIF
58974
58975 IDR = IKR1+4
58976 IDR2 = IKR2+2
58977 IF (DCHECK(IDR).AND.DCHECK(IDR2)) THEN
58978 XLAM = XLAM + PREF*PYRVI3(2,1,3) *
58979 & SFMIX(INTRES(IDR,1),2*IKR1+INTRES(IDR,3)-1)
58980 & *SFMIX(INTRES(IDR2,1),2*IKR2+INTRES(IDR2,3)-1)
58981 ENDIF
58982 130 CONTINUE
58983 140 CONTINUE
58984
58985 RETURN
58986 END
58987
58988C*********************************************************************
58989
58990C...PYRVI1
58991C...Function to integrate resonance contributions
58992
58993 FUNCTION PYRVI1(ID1,ID2,ID3)
58994
58995 IMPLICIT NONE
58996 DOUBLE PRECISION LO,HI,PYRVI1,PYRVG1,PYGAUS
58997 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
58998 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
58999 LOGICAL MFLAG,DCMASS
59000 EXTERNAL PYRVG1,PYGAUS
59001 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
59002 & ,DCMASS,KFR(3)
59003 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59004 SAVE/PYRVNV/,/PYRVPM/
59005C...Initialize mass and width information
59006 PYRVI1 = 0D0
59007 RM(0) = RMS(0)
59008 RM(1) = RMS(ID1)
59009 RM(2) = RMS(ID2)
59010 RM(3) = RMS(ID3)
59011 RESM(1)= RES(IDR,1)
59012 RESW(1)= RES(IDR,2)
59013C...A->B and B->A for antisparticles
59014 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59015 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59016C...Integration boundaries and mass flag
59017 LO = (RM(1)+RM(2))**2
59018 HI = (RM(0)-RM(3))**2
59019 MFLAG = DCMASS
59020 PYRVI1 = PYGAUS(PYRVG1,LO,HI,1D-3)
59021 RETURN
59022 END
59023
59024C*********************************************************************
59025
59026C...PYRVI2
59027C...Function to integrate L-R interference contributions
59028
59029 FUNCTION PYRVI2(ID1,ID2,ID3)
59030
59031 IMPLICIT NONE
59032 DOUBLE PRECISION LO,HI,PYRVI2, PYRVG2, PYGAUS
59033 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
59034 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
59035 LOGICAL MFLAG,DCMASS
59036 EXTERNAL PYRVG2,PYGAUS
59037 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
59038 & ,DCMASS,KFR(3)
59039 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59040 SAVE/PYRVNV/,/PYRVPM/
59041C...Initialize mass and width information
59042 PYRVI2 = 0D0
59043 RM(0) = RMS(0)
59044 RM(1) = RMS(ID1)
59045 RM(2) = RMS(ID2)
59046 RM(3) = RMS(ID3)
59047 RESM(1)= RES(IDR,1)
59048 RESW(1)= RES(IDR,2)
59049 RESM(2)= RES(IDR+1,1)
59050 RESW(2)= RES(IDR+1,2)
59051C...A->B and B->A for antisparticles
59052 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59053 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59054 A(2) = AB(1+INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
59055 B(2) = AB(2-INTRES(IDR+1,3),INTRES(IDR+1,1),INTRES(IDR+1,2))
59056C...Boundaries and mass flag
59057 LO = (RM(1)+RM(2))**2
59058 HI = (RM(0)-RM(3))**2
59059 MFLAG = DCMASS
59060 PYRVI2 = PYGAUS(PYRVG2,LO,HI,1D-3)
59061 RETURN
59062 END
59063
59064C*********************************************************************
59065
59066C...PYRVI3
59067C...Function to integrate true interference contributions
59068
59069 FUNCTION PYRVI3(ID1,ID2,ID3)
59070
59071 IMPLICIT NONE
59072 DOUBLE PRECISION LO,HI,PYRVI3, PYRVG3, PYGAUS
59073 DOUBLE PRECISION RES, AB, RM, RESM, RESW, A, B, RMS
59074 INTEGER ID1,ID2,ID3, IDR, IDR2, KFR, INTRES
59075 LOGICAL MFLAG,DCMASS
59076 EXTERNAL PYRVG3,PYGAUS
59077 COMMON/PYRVNV/AB(2,16,2),RMS(0:3),RES(6,2),INTRES(6,3),IDR,IDR2
59078 & ,DCMASS,KFR(3)
59079 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59080 SAVE/PYRVNV/,/PYRVPM/
59081C...Initialize mass and width information
59082 PYRVI3 = 0D0
59083 RM(0) = RMS(0)
59084 RM(1) = RMS(ID1)
59085 RM(2) = RMS(ID2)
59086 RM(3) = RMS(ID3)
59087 RESM(1)= RES(IDR,1)
59088 RESW(1)= RES(IDR,2)
59089 RESM(2)= RES(IDR2,1)
59090 RESW(2)= RES(IDR2,2)
59091C...A -> B and B -> A for antisparticles
59092 A(1) = AB(1+INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59093 B(1) = AB(2-INTRES(IDR,3),INTRES(IDR,1),INTRES(IDR,2))
59094 A(2) = AB(1+INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
59095 B(2) = AB(2-INTRES(IDR2,3),INTRES(IDR2,1),INTRES(IDR2,2))
59096C...Boundaries and mass flag
59097 LO = (RM(1)+RM(2))**2
59098 HI = (RM(0)-RM(3))**2
59099 MFLAG = DCMASS
59100 PYRVI3 = PYGAUS(PYRVG3,LO,HI,1D-3)
59101 RETURN
59102 END
59103
59104C*********************************************************************
59105
59106C...PYRVG1
59107C...Integrand for resonance contributions
59108
59109 FUNCTION PYRVG1(X)
59110
59111 IMPLICIT NONE
59112 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59113 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY,PYRVR
59114 DOUBLE PRECISION RVR,PYRVG1,E2,E3,C1,SR1,SR2,A1,A2
59115 LOGICAL MFLAG
59116 SAVE/PYRVPM/
59117 RVR = PYRVR(X,RESM(1),RESW(1))
59118 C1 = 2D0*SQRT(MAX(0D0,X))
59119 IF (.NOT.MFLAG) THEN
59120 E2 = X/C1
59121 E3 = (RM(0)**2-X)/C1
59122 DELTAY = 4D0*E2*E3
59123 PYRVG1 = DELTAY*RVR*X*(A(1)**2+B(1)**2)*(RM(0)**2-X)
59124 ELSE
59125 E2 = (X-RM(1)**2+RM(2)**2)/C1
59126 E3 = (RM(0)**2-X-RM(3)**2)/C1
59127 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
59128 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
59129 DELTAY = 4D0*SR1*SR2
59130 A1 = 4.*A(1)*B(1)*RM(3)*RM(0)
59131 A2 = (A(1)**2+B(1)**2)*(RM(0)**2+RM(3)**2-X)
59132 PYRVG1 = DELTAY*RVR*(X-RM(1)**2-RM(2)**2)*(A1+A2)
59133 ENDIF
59134 RETURN
59135 END
59136
59137C*********************************************************************
59138
59139C...PYRVG2
59140C...Integrand for L-R interference contributions
59141
59142 FUNCTION PYRVG2(X)
59143
59144 IMPLICIT NONE
59145 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59146 DOUBLE PRECISION X, RM, A, B, RESM, RESW, DELTAY, PYRVS
59147 DOUBLE PRECISION RVS,PYRVG2,E2,E3,C1,SR1,SR2
59148 LOGICAL MFLAG
59149 SAVE/PYRVPM/
59150 C1 = 2D0*SQRT(MAX(0D0,X))
59151 RVS = PYRVS(X,X,RESM(1),RESW(1),RESM(2),RESW(2))
59152 IF (.NOT.MFLAG) THEN
59153 E2 = X/C1
59154 E3 = (RM(0)**2-X)/C1
59155 DELTAY = 4D0*E2*E3
59156 PYRVG2 = DELTAY*RVS*X*(A(1)*A(2)+B(1)*B(2))*(RM(0)**2-X)
59157 ELSE
59158 E2 = (X-RM(1)**2+RM(2)**2)/C1
59159 E3 = (RM(0)**2-X-RM(3)**2)/C1
59160 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
59161 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
59162 DELTAY = 4D0*SR1*SR2
59163 PYRVG2 = DELTAY*RVS*(X-RM(1)**2-RM(2)**2)*((A(1)*A(2)
59164 & + B(1)*B(2))*(RM(0)**2+RM(3)**2-X)
59165 & + 2D0*(A(1)*B(2)+A(2)*B(1))*RM(3)*RM(0))
59166 ENDIF
59167 RETURN
59168 END
59169
59170C*********************************************************************
59171
59172C...PYRVG3
59173C...Function to do Y integration over true interference contributions
59174
59175 FUNCTION PYRVG3(X)
59176
59177 IMPLICIT NONE
59178 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59179C...Second Dalitz variable for PYRVG4
59180 COMMON/PYG2DX/X1
59181 DOUBLE PRECISION RM, A, B, RESM, RESW, X, X1
59182 DOUBLE PRECISION E2, E3, C1, SQ1, SR1, SR2, YMIN, YMAX
59183 DOUBLE PRECISION PYRVG3, PYRVG4, PYGAU2
59184 LOGICAL MFLAG
59185 EXTERNAL PYGAU2,PYRVG4
59186 SAVE/PYRVPM/,/PYG2DX/
59187 PYRVG3=0D0
59188 C1=2D0*SQRT(MAX(1D-9,X))
59189 X1=X
59190 IF (.NOT.MFLAG) THEN
59191 E2 = X/C1
59192 E3 = (RM(0)**2-X)/C1
59193 YMIN = 0D0
59194 YMAX = 4D0*E2*E3
59195 ELSE
59196 E2 = (X-RM(1)**2+RM(2)**2)/C1
59197 E3 = (RM(0)**2-X-RM(3)**2)/C1
59198 SQ1 = (E2+E3)**2
59199 SR1 = SQRT(MAX(0D0,E2**2-RM(2)**2))
59200 SR2 = SQRT(MAX(0D0,E3**2-RM(3)**2))
59201 YMIN = SQ1-(SR1+SR2)**2
59202 YMAX = SQ1-(SR1-SR2)**2
59203 ENDIF
59204 PYRVG3 = PYGAU2(PYRVG4,YMIN,YMAX,1D-3)
59205 RETURN
59206 END
59207
59208C*********************************************************************
59209
59210C...PYRVG4
59211C...Integrand for true intereference contributions
59212
59213 FUNCTION PYRVG4(Y)
59214
59215 IMPLICIT NONE
59216 COMMON/PYRVPM/RM(0:3),A(2),B(2),RESM(2),RESW(2),MFLAG
59217 COMMON/PYG2DX/X
59218 DOUBLE PRECISION X, Y, PYRVG4, RM, A, B, RESM, RESW, RVS, PYRVS
59219 LOGICAL MFLAG
59220 SAVE /PYRVPM/,/PYG2DX/
59221 PYRVG4=0D0
59222 RVS=PYRVS(X,Y,RESM(1),RESW(1),RESM(2),RESW(2))
59223 IF (.NOT.MFLAG) THEN
59224 PYRVG4 = RVS*B(1)*B(2)*X*Y
59225 ELSE
59226 PYRVG4 = RVS*(RM(1)*RM(3)*A(1)*A(2)*(X+Y-RM(1)**2-RM(3)**2)
59227 & + RM(1)*RM(0)*B(1)*A(2)*(Y-RM(2)**2-RM(3)**2)
59228 & + RM(3)*RM(0)*A(1)*B(2)*(X-RM(1)**2-RM(2)**2)
59229 & + B(1)*B(2)*(X*Y-(RM(1)*RM(3))**2-(RM(0)*RM(2))**2))
59230 ENDIF
59231 RETURN
59232 END
59233
59234C*********************************************************************
59235
59236C...PYRVR
59237C...Breit-Wigner for resonance contributions
59238
59239 FUNCTION PYRVR(Mab2,RM,RW)
59240
59241 IMPLICIT NONE
59242 DOUBLE PRECISION Mab2,RM,RW,PYRVR
59243 PYRVR = 1D0/((Mab2-RM**2)**2+RM**2*RW**2)
59244 RETURN
59245 END
59246
59247C*********************************************************************
59248
59249C...PYRVS
59250C...Interference function
59251
59252 FUNCTION PYRVS(X,Y,M1,W1,M2,W2)
59253
59254 IMPLICIT NONE
59255 DOUBLE PRECISION X, Y, PYRVS, PYRVR, M1, M2, W1, W2
59256 PYRVS = PYRVR(X,M1,W1)*PYRVR(Y,M2,W2)*((X-M1**2)*(Y-M2**2)
59257 & +W1*W2*M1*M2)
59258 RETURN
59259 END
59260
59261C*********************************************************************
59262
59263C...PY1ENT
59264C...Stores one parton/particle in commonblock PYJETS.
59265
59266 SUBROUTINE PY1ENT(IP,KF,PE,THE,PHI)
59267
59268C...Double precision and integer declarations.
59269 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59270 IMPLICIT INTEGER(I-N)
59271 INTEGER PYK,PYCHGE,PYCOMP
59272C...Commonblocks.
59273 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59274 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59275 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59276 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59277
59278C...Standard checks.
59279 MSTU(28)=0
59280 IF(MSTU(12).NE.12345) CALL PYLIST(0)
59281 IPA=MAX(1,IABS(IP))
59282 IF(IPA.GT.MSTU(4)) CALL PYERRM(21,
59283 &'(PY1ENT:) writing outside PYJETS memory')
59284 KC=PYCOMP(KF)
59285 IF(KC.EQ.0) CALL PYERRM(12,'(PY1ENT:) unknown flavour code')
59286
59287C...Find mass. Reset K, P and V vectors.
59288 PM=0D0
59289 IF(MSTU(10).EQ.1) PM=P(IPA,5)
59290 IF(MSTU(10).GE.2) PM=PYMASS(KF)
59291 DO 100 J=1,5
59292 K(IPA,J)=0
59293 P(IPA,J)=0D0
59294 V(IPA,J)=0D0
59295 100 CONTINUE
59296
59297C...Store parton/particle in K and P vectors.
59298 K(IPA,1)=1
59299 IF(IP.LT.0) K(IPA,1)=2
59300 K(IPA,2)=KF
59301 P(IPA,5)=PM
59302 P(IPA,4)=MAX(PE,PM)
59303 PA=SQRT(P(IPA,4)**2-P(IPA,5)**2)
59304 P(IPA,1)=PA*SIN(THE)*COS(PHI)
59305 P(IPA,2)=PA*SIN(THE)*SIN(PHI)
59306 P(IPA,3)=PA*COS(THE)
59307
59308C...Set N. Optionally fragment/decay.
59309 N=IPA
59310 IF(IP.EQ.0) CALL PYEXEC
59311
59312 RETURN
59313 END
59314
59315C*********************************************************************
59316
59317C...PY2ENT
59318C...Stores two partons/particles in their CM frame,
59319C...with the first along the +z axis.
59320
59321 SUBROUTINE PY2ENT(IP,KF1,KF2,PECM)
59322
59323C...Double precision and integer declarations.
59324 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59325 IMPLICIT INTEGER(I-N)
59326 INTEGER PYK,PYCHGE,PYCOMP
59327C...Commonblocks.
59328 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59329 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59330 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59331 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59332
59333C...Standard checks.
59334 MSTU(28)=0
59335 IF(MSTU(12).NE.12345) CALL PYLIST(0)
59336 IPA=MAX(1,IABS(IP))
59337 IF(IPA.GT.MSTU(4)-1) CALL PYERRM(21,
59338 &'(PY2ENT:) writing outside PYJETS memory')
59339 KC1=PYCOMP(KF1)
59340 KC2=PYCOMP(KF2)
59341 IF(KC1.EQ.0.OR.KC2.EQ.0) CALL PYERRM(12,
59342 &'(PY2ENT:) unknown flavour code')
59343
59344C...Find masses. Reset K, P and V vectors.
59345 PM1=0D0
59346 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
59347 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
59348 PM2=0D0
59349 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
59350 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
59351 DO 110 I=IPA,IPA+1
59352 DO 100 J=1,5
59353 K(I,J)=0
59354 P(I,J)=0D0
59355 V(I,J)=0D0
59356 100 CONTINUE
59357 110 CONTINUE
59358
59359C...Check flavours.
59360 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
59361 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
59362 IF(MSTU(19).EQ.1) THEN
59363 MSTU(19)=0
59364 ELSE
59365 IF(KQ1+KQ2.NE.0.AND.KQ1+KQ2.NE.4) CALL PYERRM(2,
59366 & '(PY2ENT:) unphysical flavour combination')
59367 ENDIF
59368 K(IPA,2)=KF1
59369 K(IPA+1,2)=KF2
59370
59371C...Store partons/particles in K vectors for normal case.
59372 IF(IP.GE.0) THEN
59373 K(IPA,1)=1
59374 IF(KQ1.NE.0.AND.KQ2.NE.0) K(IPA,1)=2
59375 K(IPA+1,1)=1
59376
59377C...Store partons in K vectors for parton shower evolution.
59378 ELSE
59379 K(IPA,1)=3
59380 K(IPA+1,1)=3
59381 K(IPA,4)=MSTU(5)*(IPA+1)
59382 K(IPA,5)=K(IPA,4)
59383 K(IPA+1,4)=MSTU(5)*IPA
59384 K(IPA+1,5)=K(IPA+1,4)
59385 ENDIF
59386
59387C...Check kinematics and store partons/particles in P vectors.
59388 IF(PECM.LE.PM1+PM2) CALL PYERRM(13,
59389 &'(PY2ENT:) energy smaller than sum of masses')
59390 PA=SQRT(MAX(0D0,(PECM**2-PM1**2-PM2**2)**2-(2D0*PM1*PM2)**2))/
59391 &(2D0*PECM)
59392 P(IPA,3)=PA
59393 P(IPA,4)=SQRT(PM1**2+PA**2)
59394 P(IPA,5)=PM1
59395 P(IPA+1,3)=-PA
59396 P(IPA+1,4)=SQRT(PM2**2+PA**2)
59397 P(IPA+1,5)=PM2
59398
59399C...Set N. Optionally fragment/decay.
59400 N=IPA+1
59401 IF(IP.EQ.0) CALL PYEXEC
59402
59403 RETURN
59404 END
59405
59406C*********************************************************************
59407
59408C...PY3ENT
59409C...Stores three partons or particles in their CM frame,
59410C...with the first along the +z axis and the third in the (x,z)
59411C...plane with x > 0.
59412
59413 SUBROUTINE PY3ENT(IP,KF1,KF2,KF3,PECM,X1,X3)
59414
59415C...Double precision and integer declarations.
59416 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59417 IMPLICIT INTEGER(I-N)
59418 INTEGER PYK,PYCHGE,PYCOMP
59419C...Commonblocks.
59420 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59421 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59422 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59423 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59424
59425C...Standard checks.
59426 MSTU(28)=0
59427 IF(MSTU(12).NE.12345) CALL PYLIST(0)
59428 IPA=MAX(1,IABS(IP))
59429 IF(IPA.GT.MSTU(4)-2) CALL PYERRM(21,
59430 &'(PY3ENT:) writing outside PYJETS memory')
59431 KC1=PYCOMP(KF1)
59432 KC2=PYCOMP(KF2)
59433 KC3=PYCOMP(KF3)
59434 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0) CALL PYERRM(12,
59435 &'(PY3ENT:) unknown flavour code')
59436
59437C...Find masses. Reset K, P and V vectors.
59438 PM1=0D0
59439 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
59440 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
59441 PM2=0D0
59442 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
59443 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
59444 PM3=0D0
59445 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
59446 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
59447 DO 110 I=IPA,IPA+2
59448 DO 100 J=1,5
59449 K(I,J)=0
59450 P(I,J)=0D0
59451 V(I,J)=0D0
59452 100 CONTINUE
59453 110 CONTINUE
59454
59455C...Check flavours.
59456 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
59457 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
59458 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
59459 IF(MSTU(19).EQ.1) THEN
59460 MSTU(19)=0
59461 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0) THEN
59462 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.(KQ1+KQ3.EQ.0.OR.
59463 & KQ1+KQ3.EQ.4)) THEN
59464 ELSE
59465 CALL PYERRM(2,'(PY3ENT:) unphysical flavour combination')
59466 ENDIF
59467 K(IPA,2)=KF1
59468 K(IPA+1,2)=KF2
59469 K(IPA+2,2)=KF3
59470
59471C...Store partons/particles in K vectors for normal case.
59472 IF(IP.GE.0) THEN
59473 K(IPA,1)=1
59474 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0)) K(IPA,1)=2
59475 K(IPA+1,1)=1
59476 IF(KQ2.NE.0.AND.KQ3.NE.0) K(IPA+1,1)=2
59477 K(IPA+2,1)=1
59478
59479C...Store partons in K vectors for parton shower evolution.
59480 ELSE
59481 K(IPA,1)=3
59482 K(IPA+1,1)=3
59483 K(IPA+2,1)=3
59484 KCS=4
59485 IF(KQ1.EQ.-1) KCS=5
59486 K(IPA,KCS)=MSTU(5)*(IPA+1)
59487 K(IPA,9-KCS)=MSTU(5)*(IPA+2)
59488 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
59489 K(IPA+1,9-KCS)=MSTU(5)*IPA
59490 K(IPA+2,KCS)=MSTU(5)*IPA
59491 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
59492 ENDIF
59493
59494C...Check kinematics.
59495 MKERR=0
59496 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*(2D0-X1-X3)*PECM.LE.PM2.OR.
59497 &0.5D0*X3*PECM.LE.PM3) MKERR=1
59498 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
59499 PA2=SQRT(MAX(1D-10,(0.5D0*(2D0-X1-X3)*PECM)**2-PM2**2))
59500 PA3=SQRT(MAX(1D-10,(0.5D0*X3*PECM)**2-PM3**2))
59501 CTHE2=(PA3**2-PA1**2-PA2**2)/(2D0*PA1*PA2)
59502 CTHE3=(PA2**2-PA1**2-PA3**2)/(2D0*PA1*PA3)
59503 IF(ABS(CTHE2).GE.1.001D0.OR.ABS(CTHE3).GE.1.001D0) MKERR=1
59504 CTHE3=MAX(-1D0,MIN(1D0,CTHE3))
59505 IF(MKERR.NE.0) CALL PYERRM(13,
59506 &'(PY3ENT:) unphysical kinematical variable setup')
59507
59508C...Store partons/particles in P vectors.
59509 P(IPA,3)=PA1
59510 P(IPA,4)=SQRT(PA1**2+PM1**2)
59511 P(IPA,5)=PM1
59512 P(IPA+2,1)=PA3*SQRT(1D0-CTHE3**2)
59513 P(IPA+2,3)=PA3*CTHE3
59514 P(IPA+2,4)=SQRT(PA3**2+PM3**2)
59515 P(IPA+2,5)=PM3
59516 P(IPA+1,1)=-P(IPA+2,1)
59517 P(IPA+1,3)=-P(IPA,3)-P(IPA+2,3)
59518 P(IPA+1,4)=SQRT(P(IPA+1,1)**2+P(IPA+1,3)**2+PM2**2)
59519 P(IPA+1,5)=PM2
59520
59521C...Set N. Optionally fragment/decay.
59522 N=IPA+2
59523 IF(IP.EQ.0) CALL PYEXEC
59524
59525 RETURN
59526 END
59527
59528C*********************************************************************
59529
59530C...PY4ENT
59531C...Stores four partons or particles in their CM frame, with
59532C...the first along the +z axis, the last in the xz plane with x > 0
59533C...and the second having y < 0 and y > 0 with equal probability.
59534
59535 SUBROUTINE PY4ENT(IP,KF1,KF2,KF3,KF4,PECM,X1,X2,X4,X12,X14)
59536
59537C...Double precision and integer declarations.
59538 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59539 IMPLICIT INTEGER(I-N)
59540 INTEGER PYK,PYCHGE,PYCOMP
59541C...Commonblocks.
59542 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59543 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59544 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
59545 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
59546
59547C...Standard checks.
59548 MSTU(28)=0
59549 IF(MSTU(12).NE.12345) CALL PYLIST(0)
59550 IPA=MAX(1,IABS(IP))
59551 IF(IPA.GT.MSTU(4)-3) CALL PYERRM(21,
59552 &'(PY4ENT:) writing outside PYJETS momory')
59553 KC1=PYCOMP(KF1)
59554 KC2=PYCOMP(KF2)
59555 KC3=PYCOMP(KF3)
59556 KC4=PYCOMP(KF4)
59557 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) CALL PYERRM(12,
59558 &'(PY4ENT:) unknown flavour code')
59559
59560C...Find masses. Reset K, P and V vectors.
59561 PM1=0D0
59562 IF(MSTU(10).EQ.1) PM1=P(IPA,5)
59563 IF(MSTU(10).GE.2) PM1=PYMASS(KF1)
59564 PM2=0D0
59565 IF(MSTU(10).EQ.1) PM2=P(IPA+1,5)
59566 IF(MSTU(10).GE.2) PM2=PYMASS(KF2)
59567 PM3=0D0
59568 IF(MSTU(10).EQ.1) PM3=P(IPA+2,5)
59569 IF(MSTU(10).GE.2) PM3=PYMASS(KF3)
59570 PM4=0D0
59571 IF(MSTU(10).EQ.1) PM4=P(IPA+3,5)
59572 IF(MSTU(10).GE.2) PM4=PYMASS(KF4)
59573 DO 110 I=IPA,IPA+3
59574 DO 100 J=1,5
59575 K(I,J)=0
59576 P(I,J)=0D0
59577 V(I,J)=0D0
59578 100 CONTINUE
59579 110 CONTINUE
59580
59581C...Check flavours.
59582 KQ1=KCHG(KC1,2)*ISIGN(1,KF1)
59583 KQ2=KCHG(KC2,2)*ISIGN(1,KF2)
59584 KQ3=KCHG(KC3,2)*ISIGN(1,KF3)
59585 KQ4=KCHG(KC4,2)*ISIGN(1,KF4)
59586 IF(MSTU(19).EQ.1) THEN
59587 MSTU(19)=0
59588 ELSEIF(KQ1.EQ.0.AND.KQ2.EQ.0.AND.KQ3.EQ.0.AND.KQ4.EQ.0) THEN
59589 ELSEIF(KQ1.NE.0.AND.KQ2.EQ.2.AND.KQ3.EQ.2.AND.(KQ1+KQ4.EQ.0.OR.
59590 & KQ1+KQ4.EQ.4)) THEN
59591 ELSEIF(KQ1.NE.0.AND.KQ1+KQ2.EQ.0.AND.KQ3.NE.0.AND.KQ3+KQ4.EQ.0D0)
59592 & THEN
59593 ELSE
59594 CALL PYERRM(2,'(PY4ENT:) unphysical flavour combination')
59595 ENDIF
59596 K(IPA,2)=KF1
59597 K(IPA+1,2)=KF2
59598 K(IPA+2,2)=KF3
59599 K(IPA+3,2)=KF4
59600
59601C...Store partons/particles in K vectors for normal case.
59602 IF(IP.GE.0) THEN
59603 K(IPA,1)=1
59604 IF(KQ1.NE.0.AND.(KQ2.NE.0.OR.KQ3.NE.0.OR.KQ4.NE.0)) K(IPA,1)=2
59605 K(IPA+1,1)=1
59606 IF(KQ2.NE.0.AND.KQ1+KQ2.NE.0.AND.(KQ3.NE.0.OR.KQ4.NE.0))
59607 & K(IPA+1,1)=2
59608 K(IPA+2,1)=1
59609 IF(KQ3.NE.0.AND.KQ4.NE.0) K(IPA+2,1)=2
59610 K(IPA+3,1)=1
59611
59612C...Store partons for parton shower evolution from q-g-g-qbar or
59613C...g-g-g-g event.
59614 ELSEIF(KQ1+KQ2.NE.0) THEN
59615 K(IPA,1)=3
59616 K(IPA+1,1)=3
59617 K(IPA+2,1)=3
59618 K(IPA+3,1)=3
59619 KCS=4
59620 IF(KQ1.EQ.-1) KCS=5
59621 K(IPA,KCS)=MSTU(5)*(IPA+1)
59622 K(IPA,9-KCS)=MSTU(5)*(IPA+3)
59623 K(IPA+1,KCS)=MSTU(5)*(IPA+2)
59624 K(IPA+1,9-KCS)=MSTU(5)*IPA
59625 K(IPA+2,KCS)=MSTU(5)*(IPA+3)
59626 K(IPA+2,9-KCS)=MSTU(5)*(IPA+1)
59627 K(IPA+3,KCS)=MSTU(5)*IPA
59628 K(IPA+3,9-KCS)=MSTU(5)*(IPA+2)
59629
59630C...Store partons for parton shower evolution from q-qbar-q-qbar event.
59631 ELSE
59632 K(IPA,1)=3
59633 K(IPA+1,1)=3
59634 K(IPA+2,1)=3
59635 K(IPA+3,1)=3
59636 K(IPA,4)=MSTU(5)*(IPA+1)
59637 K(IPA,5)=K(IPA,4)
59638 K(IPA+1,4)=MSTU(5)*IPA
59639 K(IPA+1,5)=K(IPA+1,4)
59640 K(IPA+2,4)=MSTU(5)*(IPA+3)
59641 K(IPA+2,5)=K(IPA+2,4)
59642 K(IPA+3,4)=MSTU(5)*(IPA+2)
59643 K(IPA+3,5)=K(IPA+3,4)
59644 ENDIF
59645
59646C...Check kinematics.
59647 MKERR=0
59648 IF(0.5D0*X1*PECM.LE.PM1.OR.0.5D0*X2*PECM.LE.PM2.OR.
59649 &0.5D0*(2D0-X1-X2-X4)*PECM.LE.PM3.OR.0.5D0*X4*PECM.LE.PM4)
59650 &MKERR=1
59651 PA1=SQRT(MAX(1D-10,(0.5D0*X1*PECM)**2-PM1**2))
59652 PA2=SQRT(MAX(1D-10,(0.5D0*X2*PECM)**2-PM2**2))
59653 PA4=SQRT(MAX(1D-10,(0.5D0*X4*PECM)**2-PM4**2))
59654 X24=X1+X2+X4-1D0-X12-X14+(PM3**2-PM1**2-PM2**2-PM4**2)/PECM**2
59655 CTHE4=(X1*X4-2D0*X14)*PECM**2/(4D0*PA1*PA4)
59656 IF(ABS(CTHE4).GE.1.002D0) MKERR=1
59657 CTHE4=MAX(-1D0,MIN(1D0,CTHE4))
59658 STHE4=SQRT(1D0-CTHE4**2)
59659 CTHE2=(X1*X2-2D0*X12)*PECM**2/(4D0*PA1*PA2)
59660 IF(ABS(CTHE2).GE.1.002D0) MKERR=1
59661 CTHE2=MAX(-1D0,MIN(1D0,CTHE2))
59662 STHE2=SQRT(1D0-CTHE2**2)
59663 CPHI2=((X2*X4-2D0*X24)*PECM**2-4D0*PA2*CTHE2*PA4*CTHE4)/
59664 &MAX(1D-8*PECM**2,4D0*PA2*STHE2*PA4*STHE4)
59665 IF(ABS(CPHI2).GE.1.05D0) MKERR=1
59666 CPHI2=MAX(-1D0,MIN(1D0,CPHI2))
59667 IF(MKERR.EQ.1) CALL PYERRM(13,
59668 &'(PY4ENT:) unphysical kinematical variable setup')
59669
59670C...Store partons/particles in P vectors.
59671 P(IPA,3)=PA1
59672 P(IPA,4)=SQRT(PA1**2+PM1**2)
59673 P(IPA,5)=PM1
59674 P(IPA+3,1)=PA4*STHE4
59675 P(IPA+3,3)=PA4*CTHE4
59676 P(IPA+3,4)=SQRT(PA4**2+PM4**2)
59677 P(IPA+3,5)=PM4
59678 P(IPA+1,1)=PA2*STHE2*CPHI2
59679 P(IPA+1,2)=PA2*STHE2*SQRT(1D0-CPHI2**2)*(-1D0)**INT(PYR(0)+0.5D0)
59680 P(IPA+1,3)=PA2*CTHE2
59681 P(IPA+1,4)=SQRT(PA2**2+PM2**2)
59682 P(IPA+1,5)=PM2
59683 P(IPA+2,1)=-P(IPA+1,1)-P(IPA+3,1)
59684 P(IPA+2,2)=-P(IPA+1,2)
59685 P(IPA+2,3)=-P(IPA,3)-P(IPA+1,3)-P(IPA+3,3)
59686 P(IPA+2,4)=SQRT(P(IPA+2,1)**2+P(IPA+2,2)**2+P(IPA+2,3)**2+PM3**2)
59687 P(IPA+2,5)=PM3
59688
59689C...Set N. Optionally fragment/decay.
59690 N=IPA+3
59691 IF(IP.EQ.0) CALL PYEXEC
59692
59693 RETURN
59694 END
59695
59696C*********************************************************************
59697
59698C...PY2FRM
59699C...An interface from a two-fermion generator to include
59700C...parton showers and hadronization.
59701
59702 SUBROUTINE PY2FRM(IRAD,ITAU,ICOM)
59703
59704C...Double precision and integer declarations.
59705 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59706 IMPLICIT INTEGER(I-N)
59707 INTEGER PYK,PYCHGE,PYCOMP
59708C...Commonblocks.
59709 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59710 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59711 SAVE /PYJETS/,/PYDAT1/
59712C...Local arrays.
59713 DIMENSION IJOIN(2),INTAU(2)
59714
59715C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59716 IF(ICOM.EQ.0) THEN
59717 MSTU(28)=0
59718 CALL PYHEPC(2)
59719 ENDIF
59720
59721C...Loop through entries and pick up all final fermions/antifermions.
59722 I1=0
59723 I2=0
59724 DO 100 I=1,N
59725 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59726 KFA=IABS(K(I,2))
59727 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59728 IF(K(I,2).GT.0) THEN
59729 IF(I1.EQ.0) THEN
59730 I1=I
59731 ELSE
59732 CALL PYERRM(16,'(PY2FRM:) more than one fermion')
59733 ENDIF
59734 ELSE
59735 IF(I2.EQ.0) THEN
59736 I2=I
59737 ELSE
59738 CALL PYERRM(16,'(PY2FRM:) more than one antifermion')
59739 ENDIF
59740 ENDIF
59741 ENDIF
59742 100 CONTINUE
59743
59744C...Check that event is arranged according to conventions.
59745 IF(I1.EQ.0.OR.I2.EQ.0) THEN
59746 CALL PYERRM(16,'(PY2FRM:) event contains too few fermions')
59747 ENDIF
59748 IF(I2.LT.I1) THEN
59749 CALL PYERRM(6,'(PY2FRM:) fermions arranged in wrong order')
59750 ENDIF
59751
59752C...Check whether fermion pair is quarks or leptons.
59753 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59754 IQL12=1
59755 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59756 IQL12=2
59757 ELSE
59758 CALL PYERRM(16,'(PY2FRM:) fermion pair inconsistent')
59759 ENDIF
59760
59761C...Decide whether to allow or not photon radiation in showers.
59762 MSTJ(41)=2
59763 IF(IRAD.EQ.0) MSTJ(41)=1
59764
59765C...Do colour joining and parton showers.
59766 IP1=I1
59767 IP2=I2
59768 IF(IQL12.EQ.1) THEN
59769 IJOIN(1)=IP1
59770 IJOIN(2)=IP2
59771 CALL PYJOIN(2,IJOIN)
59772 ENDIF
59773 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59774 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59775 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59776 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59777 ENDIF
59778
59779C...Do fragmentation and decays. Possibly except tau decay.
59780 IF(ITAU.EQ.0) THEN
59781 NTAU=0
59782 DO 110 I=1,N
59783 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
59784 NTAU=NTAU+1
59785 INTAU(NTAU)=I
59786 K(I,1)=11
59787 ENDIF
59788 110 CONTINUE
59789 ENDIF
59790 CALL PYEXEC
59791 IF(ITAU.EQ.0) THEN
59792 DO 120 I=1,NTAU
59793 K(INTAU(I),1)=1
59794 120 CONTINUE
59795 ENDIF
59796
59797C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
59798 IF(ICOM.EQ.0) THEN
59799 MSTU(28)=0
59800 CALL PYHEPC(1)
59801 ENDIF
59802
59803 END
59804
59805C*********************************************************************
59806
59807C...PY4FRM
59808C...An interface from a four-fermion generator to include
59809C...parton showers and hadronization.
59810
59811 SUBROUTINE PY4FRM(ATOTSQ,A1SQ,A2SQ,ISTRAT,IRAD,ITAU,ICOM)
59812
59813C...Double precision and integer declarations.
59814 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
59815 IMPLICIT INTEGER(I-N)
59816 INTEGER PYK,PYCHGE,PYCOMP
59817C...Commonblocks.
59818 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
59819 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
59820 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
59821 COMMON/PYINT1/MINT(400),VINT(400)
59822 SAVE /PYJETS/,/PYDAT1/,/PYPARS/,/PYINT1/
59823C...Local arrays.
59824 DIMENSION IJOIN(2),INTAU(4)
59825
59826C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
59827 IF(ICOM.EQ.0) THEN
59828 MSTU(28)=0
59829 CALL PYHEPC(2)
59830 ENDIF
59831
59832C...Loop through entries and pick up all final fermions/antifermions.
59833 I1=0
59834 I2=0
59835 I3=0
59836 I4=0
59837 DO 100 I=1,N
59838 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
59839 KFA=IABS(K(I,2))
59840 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
59841 IF(K(I,2).GT.0) THEN
59842 IF(I1.EQ.0) THEN
59843 I1=I
59844 ELSEIF(I3.EQ.0) THEN
59845 I3=I
59846 ELSE
59847 CALL PYERRM(16,'(PY4FRM:) more than two fermions')
59848 ENDIF
59849 ELSE
59850 IF(I2.EQ.0) THEN
59851 I2=I
59852 ELSEIF(I4.EQ.0) THEN
59853 I4=I
59854 ELSE
59855 CALL PYERRM(16,'(PY4FRM:) more than two antifermions')
59856 ENDIF
59857 ENDIF
59858 ENDIF
59859 100 CONTINUE
59860
59861C...Check that event is arranged according to conventions.
59862 IF(I3.EQ.0.OR.I4.EQ.0) THEN
59863 CALL PYERRM(16,'(PY4FRM:) event contains too few fermions')
59864 ENDIF
59865 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
59866 CALL PYERRM(6,'(PY4FRM:) fermions arranged in wrong order')
59867 ENDIF
59868
59869C...Check which fermion pairs are quarks and which leptons.
59870 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
59871 IQL12=1
59872 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
59873 IQL12=2
59874 ELSE
59875 CALL PYERRM(16,'(PY4FRM:) first fermion pair inconsistent')
59876 ENDIF
59877 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
59878 IQL34=1
59879 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
59880 IQL34=2
59881 ELSE
59882 CALL PYERRM(16,'(PY4FRM:) second fermion pair inconsistent')
59883 ENDIF
59884
59885C...Decide whether to allow or not photon radiation in showers.
59886 MSTJ(41)=2
59887 IF(IRAD.EQ.0) MSTJ(41)=1
59888
59889C...Decide on dipole pairing.
59890 IP1=I1
59891 IP2=I2
59892 IP3=I3
59893 IP4=I4
59894 IF(IQL12.EQ.IQL34) THEN
59895 R1SQ=A1SQ
59896 R2SQ=A2SQ
59897 DELTA=ATOTSQ-A1SQ-A2SQ
59898 IF(ISTRAT.EQ.1) THEN
59899 IF(DELTA.GT.0D0) R1SQ=R1SQ+DELTA
59900 IF(DELTA.LT.0D0) R2SQ=MAX(0D0,R2SQ+DELTA)
59901 ELSEIF(ISTRAT.EQ.2) THEN
59902 IF(DELTA.GT.0D0) R2SQ=R2SQ+DELTA
59903 IF(DELTA.LT.0D0) R1SQ=MAX(0D0,R1SQ+DELTA)
59904 ENDIF
59905 IF(R2SQ.GT.PYR(0)*(R1SQ+R2SQ)) THEN
59906 IP2=I4
59907 IP4=I2
59908 ENDIF
59909 ENDIF
59910
59911C...If colour reconnection then bookkeep W+W- or Z0Z0
59912C...and copy q qbar q qbar consecutively.
59913 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
59914 K(N+1,1)=11
59915 K(N+1,3)=IP1
59916 K(N+1,4)=N+3
59917 K(N+1,5)=N+4
59918 K(N+2,1)=11
59919 K(N+2,3)=IP3
59920 K(N+2,4)=N+5
59921 K(N+2,5)=N+6
59922 IF(K(IP1,2)+K(IP2,2).EQ.0) THEN
59923 K(N+1,2)=23
59924 K(N+2,2)=23
59925 MINT(1)=22
59926 ELSEIF(PYCHGE(K(IP1,2)).GT.0) THEN
59927 K(N+1,2)=24
59928 K(N+2,2)=-24
59929 MINT(1)=25
59930 ELSE
59931 K(N+1,2)=-24
59932 K(N+2,2)=24
59933 MINT(1)=25
59934 ENDIF
59935 DO 110 J=1,5
59936 K(N+3,J)=K(IP1,J)
59937 K(N+4,J)=K(IP2,J)
59938 K(N+5,J)=K(IP3,J)
59939 K(N+6,J)=K(IP4,J)
59940 P(N+1,J)=P(IP1,J)+P(IP2,J)
59941 P(N+2,J)=P(IP3,J)+P(IP4,J)
59942 P(N+3,J)=P(IP1,J)
59943 P(N+4,J)=P(IP2,J)
59944 P(N+5,J)=P(IP3,J)
59945 P(N+6,J)=P(IP4,J)
59946 V(N+1,J)=V(IP1,J)
59947 V(N+2,J)=V(IP3,J)
59948 V(N+3,J)=V(IP1,J)
59949 V(N+4,J)=V(IP2,J)
59950 V(N+5,J)=V(IP3,J)
59951 V(N+6,J)=V(IP4,J)
59952 110 CONTINUE
59953 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
59954 & P(N+1,3)**2))
59955 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
59956 & P(N+2,3)**2))
59957 K(N+3,3)=N+1
59958 K(N+4,3)=N+1
59959 K(N+5,3)=N+2
59960 K(N+6,3)=N+2
59961C...Remove original q qbar q qbar and update counters.
59962 K(IP1,1)=K(IP1,1)+10
59963 K(IP2,1)=K(IP2,1)+10
59964 K(IP3,1)=K(IP3,1)+10
59965 K(IP4,1)=K(IP4,1)+10
59966 IW1=N+1
59967 IW2=N+2
59968 NSD1=N+2
59969 IP1=N+3
59970 IP2=N+4
59971 IP3=N+5
59972 IP4=N+6
59973 N=N+6
59974 ENDIF
59975
59976C...Do colour joinings and parton showers.
59977 IF(IQL12.EQ.1) THEN
59978 IJOIN(1)=IP1
59979 IJOIN(2)=IP2
59980 CALL PYJOIN(2,IJOIN)
59981 ENDIF
59982 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
59983 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
59984 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
59985 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
59986 ENDIF
59987 NAFT1=N
59988 IF(IQL34.EQ.1) THEN
59989 IJOIN(1)=IP3
59990 IJOIN(2)=IP4
59991 CALL PYJOIN(2,IJOIN)
59992 ENDIF
59993 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
59994 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
59995 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
59996 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
59997 ENDIF
59998
59999C...Optionally do colour reconnection.
60000 MINT(32)=0
60001 MSTI(32)=0
60002 IF(MSTP(115).GE.1.AND.IQL12.EQ.1.AND.IQL34.EQ.1) THEN
60003 CALL PYRECO(IW1,IW2,NSD1,NAFT1)
60004 MSTI(32)=MINT(32)
60005 ENDIF
60006
60007C...Do fragmentation and decays. Possibly except tau decay.
60008 IF(ITAU.EQ.0) THEN
60009 NTAU=0
60010 DO 120 I=1,N
60011 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
60012 NTAU=NTAU+1
60013 INTAU(NTAU)=I
60014 K(I,1)=11
60015 ENDIF
60016 120 CONTINUE
60017 ENDIF
60018 CALL PYEXEC
60019 IF(ITAU.EQ.0) THEN
60020 DO 130 I=1,NTAU
60021 K(INTAU(I),1)=1
60022 130 CONTINUE
60023 ENDIF
60024
60025C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
60026 IF(ICOM.EQ.0) THEN
60027 MSTU(28)=0
60028 CALL PYHEPC(1)
60029 ENDIF
60030
60031 END
60032
60033C*********************************************************************
60034
60035C...PY6FRM
60036C...An interface from a six-fermion generator to include
60037C...parton showers and hadronization.
60038
60039 SUBROUTINE PY6FRM(P12,P13,P21,P23,P31,P32,PTOP,IRAD,ITAU,ICOM)
60040
60041C...Double precision and integer declarations.
60042 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60043 IMPLICIT INTEGER(I-N)
60044 INTEGER PYK,PYCHGE,PYCOMP
60045C...Commonblocks.
60046 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60047 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60048 SAVE /PYJETS/,/PYDAT1/
60049C...Local arrays.
60050 DIMENSION IJOIN(2),INTAU(6),BETA(3),BETAO(3),BETAN(3)
60051
60052C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
60053 IF(ICOM.EQ.0) THEN
60054 MSTU(28)=0
60055 CALL PYHEPC(2)
60056 ENDIF
60057
60058C...Loop through entries and pick up all final fermions/antifermions.
60059 I1=0
60060 I2=0
60061 I3=0
60062 I4=0
60063 I5=0
60064 I6=0
60065 DO 100 I=1,N
60066 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
60067 KFA=IABS(K(I,2))
60068 IF((KFA.GE.1.AND.KFA.LE.6).OR.(KFA.GE.11.AND.KFA.LE.16)) THEN
60069 IF(K(I,2).GT.0) THEN
60070 IF(I1.EQ.0) THEN
60071 I1=I
60072 ELSEIF(I3.EQ.0) THEN
60073 I3=I
60074 ELSEIF(I5.EQ.0) THEN
60075 I5=I
60076 ELSE
60077 CALL PYERRM(16,'(PY6FRM:) more than three fermions')
60078 ENDIF
60079 ELSE
60080 IF(I2.EQ.0) THEN
60081 I2=I
60082 ELSEIF(I4.EQ.0) THEN
60083 I4=I
60084 ELSEIF(I6.EQ.0) THEN
60085 I6=I
60086 ELSE
60087 CALL PYERRM(16,'(PY6FRM:) more than three antifermions')
60088 ENDIF
60089 ENDIF
60090 ENDIF
60091 100 CONTINUE
60092
60093C...Check that event is arranged according to conventions.
60094 IF(I5.EQ.0.OR.I6.EQ.0) THEN
60095 CALL PYERRM(16,'(PY6FRM:) event contains too few fermions')
60096 ENDIF
60097 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3.OR.I5.LT.I4.OR.I6.LT.I5) THEN
60098 CALL PYERRM(6,'(PY6FRM:) fermions arranged in wrong order')
60099 ENDIF
60100
60101C...Check which fermion pairs are quarks and which leptons.
60102 IF(IABS(K(I1,2)).LT.10.AND.IABS(K(I2,2)).LT.10) THEN
60103 IQL12=1
60104 ELSEIF(IABS(K(I1,2)).GT.10.AND.IABS(K(I2,2)).GT.10) THEN
60105 IQL12=2
60106 ELSE
60107 CALL PYERRM(16,'(PY6FRM:) first fermion pair inconsistent')
60108 ENDIF
60109 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
60110 IQL34=1
60111 ELSEIF(IABS(K(I3,2)).GT.10.AND.IABS(K(I4,2)).GT.10) THEN
60112 IQL34=2
60113 ELSE
60114 CALL PYERRM(16,'(PY6FRM:) second fermion pair inconsistent')
60115 ENDIF
60116 IF(IABS(K(I5,2)).LT.10.AND.IABS(K(I6,2)).LT.10) THEN
60117 IQL56=1
60118 ELSEIF(IABS(K(I5,2)).GT.10.AND.IABS(K(I6,2)).GT.10) THEN
60119 IQL56=2
60120 ELSE
60121 CALL PYERRM(16,'(PY6FRM:) third fermion pair inconsistent')
60122 ENDIF
60123
60124C...Decide whether to allow or not photon radiation in showers.
60125 MSTJ(41)=2
60126 IF(IRAD.EQ.0) MSTJ(41)=1
60127
60128C...Allow dipole pairings only among leptons and quarks separately.
60129 P12D=P12
60130 P13D=0D0
60131 IF(IQL34.EQ.IQL56) P13D=P13
60132 P21D=0D0
60133 IF(IQL12.EQ.IQL34) P21D=P21
60134 P23D=0D0
60135 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P23D=P23
60136 P31D=0D0
60137 IF(IQL12.EQ.IQL34.AND.IQL12.EQ.IQL56) P31D=P31
60138 P32D=0D0
60139 IF(IQL12.EQ.IQL56) P32D=P32
60140
60141C...Decide whether t+tbar.
60142 ITOP=0
60143 IF(PYR(0).LT.PTOP) THEN
60144 ITOP=1
60145
60146C...If t+tbar: reconstruct t's.
60147 IT=N+1
60148 ITB=N+2
60149 DO 110 J=1,5
60150 K(IT,J)=0
60151 K(ITB,J)=0
60152 P(IT,J)=P(I1,J)+P(I3,J)+P(I4,J)
60153 P(ITB,J)=P(I2,J)+P(I5,J)+P(I6,J)
60154 V(IT,J)=0D0
60155 V(ITB,J)=0D0
60156 110 CONTINUE
60157 K(IT,1)=1
60158 K(ITB,1)=1
60159 K(IT,2)=6
60160 K(ITB,2)=-6
60161 P(IT,5)=SQRT(MAX(0D0,P(IT,4)**2-P(IT,1)**2-P(IT,2)**2-
60162 & P(IT,3)**2))
60163 P(ITB,5)=SQRT(MAX(0D0,P(ITB,4)**2-P(ITB,1)**2-P(ITB,2)**2-
60164 & P(ITB,3)**2))
60165 N=N+2
60166
60167C...If t+tbar: colour join t's and let them shower.
60168 IJOIN(1)=IT
60169 IJOIN(2)=ITB
60170 CALL PYJOIN(2,IJOIN)
60171 PMTTS=(P(IT,4)+P(ITB,4))**2-(P(IT,1)+P(ITB,1))**2-
60172 & (P(IT,2)+P(ITB,2))**2-(P(IT,3)+P(ITB,3))**2
60173 CALL PYSHOW(IT,ITB,SQRT(MAX(0D0,PMTTS)))
60174
60175C...If t+tbar: pick up the t's after shower.
60176 ITNEW=IT
60177 ITBNEW=ITB
60178 DO 120 I=ITB+1,N
60179 IF(K(I,2).EQ.6) ITNEW=I
60180 IF(K(I,2).EQ.-6) ITBNEW=I
60181 120 CONTINUE
60182
60183C...If t+tbar: loop over two top systems.
60184 DO 200 IT1=1,2
60185 IF(IT1.EQ.1) THEN
60186 ITO=IT
60187 ITN=ITNEW
60188 IBO=I1
60189 IW1=I3
60190 IW2=I4
60191 ELSE
60192 ITO=ITB
60193 ITN=ITBNEW
60194 IBO=I2
60195 IW1=I5
60196 IW2=I6
60197 ENDIF
60198 IF(IABS(K(IBO,2)).NE.5) CALL PYERRM(6,
60199 & '(PY6FRM:) not b in t decay')
60200
60201C...If t+tbar: find boost from original to new top frame.
60202 DO 130 J=1,3
60203 BETAO(J)=P(ITO,J)/P(ITO,4)
60204 BETAN(J)=P(ITN,J)/P(ITN,4)
60205 130 CONTINUE
60206
60207C...If t+tbar: boost copy of b by t shower and connect it in colour.
60208 N=N+1
60209 IB=N
60210 K(IB,1)=3
60211 K(IB,2)=K(IBO,2)
60212 K(IB,3)=ITN
60213 DO 140 J=1,5
60214 P(IB,J)=P(IBO,J)
60215 V(IB,J)=0D0
60216 140 CONTINUE
60217 CALL PYROBO(IB,IB,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
60218 CALL PYROBO(IB,IB,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
60219 K(IB,4)=MSTU(5)*ITN
60220 K(IB,5)=MSTU(5)*ITN
60221 K(ITN,4)=K(ITN,4)+IB
60222 K(ITN,5)=K(ITN,5)+IB
60223 K(ITN,1)=K(ITN,1)+10
60224 K(IBO,1)=K(IBO,1)+10
60225
60226C...If t+tbar: construct W recoiling against b.
60227 N=N+1
60228 IW=N
60229 DO 150 J=1,5
60230 K(IW,J)=0
60231 V(IW,J)=0D0
60232 150 CONTINUE
60233 K(IW,1)=1
60234 KCHW=PYCHGE(K(IW1,2))+PYCHGE(K(IW2,2))
60235 IF(IABS(KCHW).EQ.3) THEN
60236 K(IW,2)=ISIGN(24,KCHW)
60237 ELSE
60238 CALL PYERRM(16,'(PY6FRM:) fermion pair inconsistent with W')
60239 ENDIF
60240 K(IW,3)=IW1
60241
60242C...If t+tbar: construct W momentum, including boost by t shower.
60243 DO 160 J=1,4
60244 P(IW,J)=P(IW1,J)+P(IW2,J)
60245 160 CONTINUE
60246 P(IW,5)=SQRT(MAX(0D0,P(IW,4)**2-P(IW,1)**2-P(IW,2)**2-
60247 & P(IW,3)**2))
60248 CALL PYROBO(IW,IW,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
60249 CALL PYROBO(IW,IW,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
60250
60251C...If t+tbar: boost b and W to top rest frame.
60252 DO 170 J=1,3
60253 BETA(J)=(P(IB,J)+P(IW,J))/(P(IB,4)+P(IW,4))
60254 170 CONTINUE
60255 CALL PYROBO(IB,IB,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60256 CALL PYROBO(IW,IW,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60257
60258C...If t+tbar: let b shower and pick up modified W.
60259 PMTS=(P(IB,4)+P(IW,4))**2-(P(IB,1)+P(IW,1))**2-
60260 & (P(IB,2)+P(IW,2))**2-(P(IB,3)+P(IW,3))**2
60261 CALL PYSHOW(IB,IW,SQRT(MAX(0D0,PMTS)))
60262 DO 180 I=IW,N
60263 IF(IABS(K(I,2)).EQ.24) IWM=I
60264 180 CONTINUE
60265
60266C...If t+tbar: take copy of W decay products.
60267 DO 190 J=1,5
60268 K(N+1,J)=K(IW1,J)
60269 P(N+1,J)=P(IW1,J)
60270 V(N+1,J)=V(IW1,J)
60271 K(N+2,J)=K(IW2,J)
60272 P(N+2,J)=P(IW2,J)
60273 V(N+2,J)=V(IW2,J)
60274 190 CONTINUE
60275 K(IW1,1)=K(IW1,1)+10
60276 K(IW2,1)=K(IW2,1)+10
60277 K(IWM,1)=K(IWM,1)+10
60278 K(IWM,4)=N+1
60279 K(IWM,5)=N+2
60280 K(N+1,3)=IWM
60281 K(N+2,3)=IWM
60282 IF(IT1.EQ.1) THEN
60283 I3=N+1
60284 I4=N+2
60285 ELSE
60286 I5=N+1
60287 I6=N+2
60288 ENDIF
60289 N=N+2
60290
60291C...If t+tbar: boost W decay products, first by effects of t shower,
60292C...then by those of b shower. b and its shower simple boost back.
60293 CALL PYROBO(N-1,N,0D0,0D0,-BETAO(1),-BETAO(2),-BETAO(3))
60294 CALL PYROBO(N-1,N,0D0,0D0,BETAN(1),BETAN(2),BETAN(3))
60295 CALL PYROBO(N-1,N,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60296 CALL PYROBO(N-1,N,0D0,0D0,-P(IW,1)/P(IW,4),
60297 & -P(IW,2)/P(IW,4),-P(IW,3)/P(IW,4))
60298 CALL PYROBO(N-1,N,0D0,0D0,P(IWM,1)/P(IWM,4),
60299 & P(IWM,2)/P(IWM,4),P(IWM,3)/P(IWM,4))
60300 CALL PYROBO(IB,IB,0D0,0D0,BETA(1),BETA(2),BETA(3))
60301 CALL PYROBO(IW,N,0D0,0D0,BETA(1),BETA(2),BETA(3))
60302 200 CONTINUE
60303 ENDIF
60304
60305C...Decide on dipole pairing.
60306 IP1=I1
60307 IP3=I3
60308 IP5=I5
60309 PRN=PYR(0)*(P12D+P13D+P21D+P23D+P31D+P32D)
60310 IF(ITOP.EQ.1.OR.PRN.LT.P12D) THEN
60311 IP2=I2
60312 IP4=I4
60313 IP6=I6
60314 ELSEIF(PRN.LT.P12D+P13D) THEN
60315 IP2=I2
60316 IP4=I6
60317 IP6=I4
60318 ELSEIF(PRN.LT.P12D+P13D+P21D) THEN
60319 IP2=I4
60320 IP4=I2
60321 IP6=I6
60322 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D) THEN
60323 IP2=I4
60324 IP4=I6
60325 IP6=I2
60326 ELSEIF(PRN.LT.P12D+P13D+P21D+P23D+P31D) THEN
60327 IP2=I6
60328 IP4=I2
60329 IP6=I4
60330 ELSE
60331 IP2=I6
60332 IP4=I4
60333 IP6=I2
60334 ENDIF
60335
60336C...Do colour joinings and parton showers
60337C...(except ones already made for t+tbar).
60338 IF(ITOP.EQ.0) THEN
60339 IF(IQL12.EQ.1) THEN
60340 IJOIN(1)=IP1
60341 IJOIN(2)=IP2
60342 CALL PYJOIN(2,IJOIN)
60343 ENDIF
60344 IF(IQL12.EQ.1.OR.IRAD.EQ.1) THEN
60345 PM12S=(P(IP1,4)+P(IP2,4))**2-(P(IP1,1)+P(IP2,1))**2-
60346 & (P(IP1,2)+P(IP2,2))**2-(P(IP1,3)+P(IP2,3))**2
60347 CALL PYSHOW(IP1,IP2,SQRT(MAX(0D0,PM12S)))
60348 ENDIF
60349 ENDIF
60350 IF(IQL34.EQ.1) THEN
60351 IJOIN(1)=IP3
60352 IJOIN(2)=IP4
60353 CALL PYJOIN(2,IJOIN)
60354 ENDIF
60355 IF(IQL34.EQ.1.OR.IRAD.EQ.1) THEN
60356 PM34S=(P(IP3,4)+P(IP4,4))**2-(P(IP3,1)+P(IP4,1))**2-
60357 & (P(IP3,2)+P(IP4,2))**2-(P(IP3,3)+P(IP4,3))**2
60358 CALL PYSHOW(IP3,IP4,SQRT(MAX(0D0,PM34S)))
60359 ENDIF
60360 IF(IQL56.EQ.1) THEN
60361 IJOIN(1)=IP5
60362 IJOIN(2)=IP6
60363 CALL PYJOIN(2,IJOIN)
60364 ENDIF
60365 IF(IQL56.EQ.1.OR.IRAD.EQ.1) THEN
60366 PM56S=(P(IP5,4)+P(IP6,4))**2-(P(IP5,1)+P(IP6,1))**2-
60367 & (P(IP5,2)+P(IP6,2))**2-(P(IP5,3)+P(IP6,3))**2
60368 CALL PYSHOW(IP5,IP6,SQRT(MAX(0D0,PM56S)))
60369 ENDIF
60370
60371C...Do fragmentation and decays. Possibly except tau decay.
60372 IF(ITAU.EQ.0) THEN
60373 NTAU=0
60374 DO 210 I=1,N
60375 IF(IABS(K(I,2)).EQ.15.AND.K(I,1).EQ.1) THEN
60376 NTAU=NTAU+1
60377 INTAU(NTAU)=I
60378 K(I,1)=11
60379 ENDIF
60380 210 CONTINUE
60381 ENDIF
60382 CALL PYEXEC
60383 IF(ITAU.EQ.0) THEN
60384 DO 220 I=1,NTAU
60385 K(INTAU(I),1)=1
60386 220 CONTINUE
60387 ENDIF
60388
60389C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
60390 IF(ICOM.EQ.0) THEN
60391 MSTU(28)=0
60392 CALL PYHEPC(1)
60393 ENDIF
60394
60395 END
60396
60397C*********************************************************************
60398
60399C...PY4JET
60400C...An interface from a four-parton generator to include
60401C...parton showers and hadronization.
60402
60403 SUBROUTINE PY4JET(PMAX,IRAD,ICOM)
60404
60405C...Double precision and integer declarations.
60406 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60407 IMPLICIT INTEGER(I-N)
60408 INTEGER PYK,PYCHGE,PYCOMP
60409C...Commonblocks.
60410 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60411 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60412 SAVE /PYJETS/,/PYDAT1/
60413C...Local arrays.
60414 DIMENSION IJOIN(2),PTOT(4),BETA(3)
60415
60416C...Call PYHEPC to convert input from HEPEVT to PYJETS common.
60417 IF(ICOM.EQ.0) THEN
60418 MSTU(28)=0
60419 CALL PYHEPC(2)
60420 ENDIF
60421
60422C...Loop through entries and pick up all final partons.
60423 I1=0
60424 I2=0
60425 I3=0
60426 I4=0
60427 DO 100 I=1,N
60428 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
60429 KFA=IABS(K(I,2))
60430 IF((KFA.GE.1.AND.KFA.LE.6).OR.KFA.EQ.21) THEN
60431 IF(K(I,2).GT.0.AND.K(I,2).LE.6) THEN
60432 IF(I1.EQ.0) THEN
60433 I1=I
60434 ELSEIF(I3.EQ.0) THEN
60435 I3=I
60436 ELSE
60437 CALL PYERRM(16,'(PY4JET:) more than two quarks')
60438 ENDIF
60439 ELSEIF(K(I,2).LT.0) THEN
60440 IF(I2.EQ.0) THEN
60441 I2=I
60442 ELSEIF(I4.EQ.0) THEN
60443 I4=I
60444 ELSE
60445 CALL PYERRM(16,'(PY4JET:) more than two antiquarks')
60446 ENDIF
60447 ELSE
60448 IF(I3.EQ.0) THEN
60449 I3=I
60450 ELSEIF(I4.EQ.0) THEN
60451 I4=I
60452 ELSE
60453 CALL PYERRM(16,'(PY4JET:) more than two gluons')
60454 ENDIF
60455 ENDIF
60456 ENDIF
60457 100 CONTINUE
60458
60459C...Check that event is arranged according to conventions.
60460 IF(I1.EQ.0.OR.I2.EQ.0.OR.I3.EQ.0.OR.I4.EQ.0) THEN
60461 CALL PYERRM(16,'(PY4JET:) event contains too few partons')
60462 ENDIF
60463 IF(I2.LT.I1.OR.I3.LT.I2.OR.I4.LT.I3) THEN
60464 CALL PYERRM(6,'(PY4JET:) partons arranged in wrong order')
60465 ENDIF
60466
60467C...Check whether second pair are quarks or gluons.
60468 IF(IABS(K(I3,2)).LT.10.AND.IABS(K(I4,2)).LT.10) THEN
60469 IQG34=1
60470 ELSEIF(K(I3,2).EQ.21.AND.K(I4,2).EQ.21) THEN
60471 IQG34=2
60472 ELSE
60473 CALL PYERRM(16,'(PY4JET:) second parton pair inconsistent')
60474 ENDIF
60475
60476C...Boost partons to their cm frame.
60477 DO 110 J=1,4
60478 PTOT(J)=P(I1,J)+P(I2,J)+P(I3,J)+P(I4,J)
60479 110 CONTINUE
60480 ECM=SQRT(MAX(0D0,PTOT(4)**2-PTOT(1)**2-PTOT(2)**2-PTOT(3)**2))
60481 DO 120 J=1,3
60482 BETA(J)=PTOT(J)/PTOT(4)
60483 120 CONTINUE
60484 CALL PYROBO(I1,I1,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60485 CALL PYROBO(I2,I2,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60486 CALL PYROBO(I3,I3,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60487 CALL PYROBO(I4,I4,0D0,0D0,-BETA(1),-BETA(2),-BETA(3))
60488 NSAV=N
60489
60490C...Decide and set up shower history for q qbar q' qbar' events.
60491 IF(IQG34.EQ.1) THEN
60492 W1=PY4JTW(0,I1,I3,I4)
60493 W2=PY4JTW(0,I2,I3,I4)
60494 IF(W1.GT.PYR(0)*(W1+W2)) THEN
60495 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
60496 ELSE
60497 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
60498 ENDIF
60499
60500C...Decide and set up shower history for q qbar g g events.
60501 ELSE
60502 W1=PY4JTW(I1,I3,I2,I4)
60503 W2=PY4JTW(I1,I4,I2,I3)
60504 W3=PY4JTW(0,I3,I1,I4)
60505 W4=PY4JTW(0,I4,I1,I3)
60506 W5=PY4JTW(0,I3,I2,I4)
60507 W6=PY4JTW(0,I4,I2,I3)
60508 W7=PY4JTW(0,I1,I3,I4)
60509 W8=PY4JTW(0,I2,I3,I4)
60510 WR=(W1+W2+W3+W4+W5+W6+W7+W8)*PYR(0)
60511 IF(W1.GT.WR) THEN
60512 CALL PY4JTS(I1,I3,I2,I4,0,QMAX)
60513 ELSEIF(W1+W2.GT.WR) THEN
60514 CALL PY4JTS(I1,I4,I2,I3,0,QMAX)
60515 ELSEIF(W1+W2+W3.GT.WR) THEN
60516 CALL PY4JTS(0,I3,I1,I4,I2,QMAX)
60517 ELSEIF(W1+W2+W3+W4.GT.WR) THEN
60518 CALL PY4JTS(0,I4,I1,I3,I2,QMAX)
60519 ELSEIF(W1+W2+W3+W4+W5.GT.WR) THEN
60520 CALL PY4JTS(0,I3,I2,I4,I1,QMAX)
60521 ELSEIF(W1+W2+W3+W4+W5+W6.GT.WR) THEN
60522 CALL PY4JTS(0,I4,I2,I3,I1,QMAX)
60523 ELSEIF(W1+W2+W3+W4+W5+W6+W7.GT.WR) THEN
60524 CALL PY4JTS(0,I1,I3,I4,I2,QMAX)
60525 ELSE
60526 CALL PY4JTS(0,I2,I3,I4,I1,QMAX)
60527 ENDIF
60528 ENDIF
60529
60530C...Boost back original partons and mark them as deleted.
60531 CALL PYROBO(I1,I1,0D0,0D0,BETA(1),BETA(2),BETA(3))
60532 CALL PYROBO(I2,I2,0D0,0D0,BETA(1),BETA(2),BETA(3))
60533 CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
60534 CALL PYROBO(I4,I4,0D0,0D0,BETA(1),BETA(2),BETA(3))
60535 K(I1,1)=K(I1,1)+10
60536 K(I2,1)=K(I2,1)+10
60537 K(I3,1)=K(I3,1)+10
60538 K(I4,1)=K(I4,1)+10
60539
60540C...Rotate shower initiating partons to be along z axis.
60541 PHI=PYANGL(P(NSAV+1,1),P(NSAV+1,2))
60542 CALL PYROBO(NSAV+1,NSAV+6,0D0,-PHI,0D0,0D0,0D0)
60543 THE=PYANGL(P(NSAV+1,3),P(NSAV+1,1))
60544 CALL PYROBO(NSAV+1,NSAV+6,-THE,0D0,0D0,0D0,0D0)
60545
60546C...Set up copy of shower initiating partons as on mass shell.
60547 DO 140 I=N+1,N+2
60548 DO 130 J=1,5
60549 K(I,J)=0
60550 P(I,J)=0D0
60551 V(I,J)=V(I1,J)
60552 130 CONTINUE
60553 K(I,1)=1
60554 K(I,2)=K(I-6,2)
60555 140 CONTINUE
60556 IF(K(NSAV+1,2).EQ.K(I1,2)) THEN
60557 K(N+1,3)=I1
60558 P(N+1,5)=P(I1,5)
60559 K(N+2,3)=I2
60560 P(N+2,5)=P(I2,5)
60561 ELSE
60562 K(N+1,3)=I2
60563 P(N+1,5)=P(I2,5)
60564 K(N+2,3)=I1
60565 P(N+2,5)=P(I1,5)
60566 ENDIF
60567 PABS=SQRT(MAX(0D0,(ECM**2-P(N+1,5)**2-P(N+2,5)**2)**2-
60568 &(2D0*P(N+1,5)*P(N+2,5))**2))/(2D0*ECM)
60569 P(N+1,3)=PABS
60570 P(N+1,4)=SQRT(PABS**2+P(N+1,5)**2)
60571 P(N+2,3)=-PABS
60572 P(N+2,4)=SQRT(PABS**2+P(N+2,5)**2)
60573 N=N+2
60574
60575C...Decide whether to allow or not photon radiation in showers.
60576C...Connect up colours.
60577 MSTJ(41)=2
60578 IF(IRAD.EQ.0) MSTJ(41)=1
60579 IJOIN(1)=N-1
60580 IJOIN(2)=N
60581 CALL PYJOIN(2,IJOIN)
60582
60583C...Decide on maximum virtuality and do parton shower.
60584 IF(PMAX.LT.PARJ(82)) THEN
60585 PQMAX=QMAX
60586 ELSE
60587 PQMAX=PMAX
60588 ENDIF
60589 CALL PYSHOW(NSAV+1,-100,PQMAX)
60590
60591C...Rotate and boost back system.
60592 CALL PYROBO(NSAV+1,N,THE,PHI,BETA(1),BETA(2),BETA(3))
60593
60594C...Do fragmentation and decays.
60595 CALL PYEXEC
60596
60597C...Call PYHEPC to convert output from PYJETS to HEPEVT common.
60598 IF(ICOM.EQ.0) THEN
60599 MSTU(28)=0
60600 CALL PYHEPC(1)
60601 ENDIF
60602
60603 RETURN
60604 END
60605
60606C*********************************************************************
60607
60608C...PY4JTW
60609C...Auxiliary to PY4JET, to evaluate weight of configuration.
60610
60611 FUNCTION PY4JTW(IA1,IA2,IA3,IA4)
60612
60613C...Double precision and integer declarations.
60614 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60615 IMPLICIT INTEGER(I-N)
60616 INTEGER PYK,PYCHGE,PYCOMP
60617C...Commonblocks.
60618 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60619 SAVE /PYJETS/
60620
60621C...First case: when both original partons radiate.
60622C...IA1 /= 0: N+1 -> IA1 + IA2, N+2 -> IA3 + IA4.
60623 IF(IA1.NE.0) THEN
60624 DO 100 J=1,4
60625 P(N+1,J)=P(IA1,J)+P(IA2,J)
60626 P(N+2,J)=P(IA3,J)+P(IA4,J)
60627 100 CONTINUE
60628 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60629 & P(N+1,3)**2))
60630 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
60631 & P(N+2,3)**2))
60632 Z1=P(IA1,4)/P(N+1,4)
60633 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-P(IA1,5)**2)
60634 Z2=P(IA3,4)/P(N+2,4)
60635 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-P(IA3,5)**2)
60636
60637C...Second case: when one original parton radiates to three.
60638C...IA1 = 0: N+1 -> IA2 + N+2, N+2 -> IA3 + IA4.
60639 ELSE
60640 DO 110 J=1,4
60641 P(N+2,J)=P(IA3,J)+P(IA4,J)
60642 P(N+1,J)=P(N+2,J)+P(IA2,J)
60643 110 CONTINUE
60644 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60645 & P(N+1,3)**2))
60646 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
60647 & P(N+2,3)**2))
60648 IF(K(IA2,2).EQ.21) THEN
60649 Z1=P(N+2,4)/P(N+1,4)
60650 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
60651 & P(IA3,5)**2)
60652 ELSE
60653 Z1=P(IA2,4)/P(N+1,4)
60654 WT1=(4D0/3D0)*((1D0+Z1**2)/(1D0-Z1))/(P(N+1,5)**2-
60655 & P(IA2,5)**2)
60656 ENDIF
60657 Z2=P(IA3,4)/P(N+2,4)
60658 IF(K(IA2,2).EQ.21) THEN
60659 WT2=(4D0/3D0)*((1D0+Z2**2)/(1D0-Z2))/(P(N+2,5)**2-
60660 & P(IA3,5)**2)
60661 ELSEIF(K(IA3,2).EQ.21) THEN
60662 WT2=3D0*((1D0-Z2*(1D0-Z2))**2/(Z2*(1D0-Z2)))/P(N+2,5)**2
60663 ELSE
60664 WT2=0.5D0*(Z2**2+(1D0-Z2)**2)
60665 ENDIF
60666 ENDIF
60667
60668C...Total weight.
60669 PY4JTW=WT1*WT2
60670
60671 RETURN
60672 END
60673
60674C*********************************************************************
60675
60676C...PY4JTS
60677C...Auxiliary to PY4JET, to set up chosen configuration.
60678
60679 SUBROUTINE PY4JTS(IA1,IA2,IA3,IA4,IA5,QMAX)
60680
60681C...Double precision and integer declarations.
60682 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60683 IMPLICIT INTEGER(I-N)
60684 INTEGER PYK,PYCHGE,PYCOMP
60685C...Commonblocks.
60686 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60687 SAVE /PYJETS/
60688
60689C...Reset info.
60690 DO 110 I=N+1,N+6
60691 DO 100 J=1,5
60692 K(I,J)=0
60693 V(I,J)=V(IA2,J)
60694 100 CONTINUE
60695 K(I,1)=16
60696 110 CONTINUE
60697
60698C...First case: when both original partons radiate.
60699C...N+1 -> (IA1=N+3) + (IA2=N+4), N+2 -> (IA3=N+5) + (IA4=N+6).
60700 IF(IA1.NE.0) THEN
60701
60702C...Set up flavour and history pointers for new partons.
60703 K(N+1,2)=K(IA1,2)
60704 K(N+2,2)=K(IA3,2)
60705 K(N+3,2)=K(IA1,2)
60706 K(N+4,2)=K(IA2,2)
60707 K(N+5,2)=K(IA3,2)
60708 K(N+6,2)=K(IA4,2)
60709 K(N+1,3)=IA1
60710 K(N+1,4)=N+3
60711 K(N+1,5)=N+4
60712 K(N+2,3)=IA3
60713 K(N+2,4)=N+5
60714 K(N+2,5)=N+6
60715 K(N+3,3)=N+1
60716 K(N+4,3)=N+1
60717 K(N+5,3)=N+2
60718 K(N+6,3)=N+2
60719
60720C...Set up momenta for new partons.
60721 DO 120 J=1,5
60722 P(N+1,J)=P(IA1,J)+P(IA2,J)
60723 P(N+2,J)=P(IA3,J)+P(IA4,J)
60724 P(N+3,J)=P(IA1,J)
60725 P(N+4,J)=P(IA2,J)
60726 P(N+5,J)=P(IA3,J)
60727 P(N+6,J)=P(IA4,J)
60728 120 CONTINUE
60729 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60730 & P(N+1,3)**2))
60731 P(N+2,5)=SQRT(MAX(0D0,P(N+2,4)**2-P(N+2,1)**2-P(N+2,2)**2-
60732 & P(N+2,3)**2))
60733 QMAX=MIN(P(N+1,5),P(N+2,5))
60734
60735C...Second case: q radiates twice.
60736C...N+1 -> (IA2=N+4) + N+3, N+3 -> (IA3=N+5) + (IA4=N+6),
60737C...IA5=N+2 does not radiate.
60738 ELSEIF(K(IA2,2).EQ.21) THEN
60739
60740C...Set up flavour and history pointers for new partons.
60741 K(N+1,2)=K(IA3,2)
60742 K(N+2,2)=K(IA5,2)
60743 K(N+3,2)=K(IA3,2)
60744 K(N+4,2)=K(IA2,2)
60745 K(N+5,2)=K(IA3,2)
60746 K(N+6,2)=K(IA4,2)
60747 K(N+1,3)=IA3
60748 K(N+1,4)=N+3
60749 K(N+1,5)=N+4
60750 K(N+2,3)=IA5
60751 K(N+3,3)=N+1
60752 K(N+3,4)=N+5
60753 K(N+3,5)=N+6
60754 K(N+4,3)=N+1
60755 K(N+5,3)=N+3
60756 K(N+6,3)=N+3
60757
60758C...Set up momenta for new partons.
60759 DO 130 J=1,5
60760 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
60761 P(N+2,J)=P(IA5,J)
60762 P(N+3,J)=P(IA3,J)+P(IA4,J)
60763 P(N+4,J)=P(IA2,J)
60764 P(N+5,J)=P(IA3,J)
60765 P(N+6,J)=P(IA4,J)
60766 130 CONTINUE
60767 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60768 & P(N+1,3)**2))
60769 P(N+3,5)=SQRT(MAX(0D0,P(N+3,4)**2-P(N+3,1)**2-P(N+3,2)**2-
60770 & P(N+3,3)**2))
60771 QMAX=P(N+3,5)
60772
60773C...Third case: q radiates g, g branches.
60774C...N+1 -> (IA2=N+3) + N+4, N+4 -> (IA3=N+5) + (IA4=N+6),
60775C...IA5=N+2 does not radiate.
60776 ELSE
60777
60778C...Set up flavour and history pointers for new partons.
60779 K(N+1,2)=K(IA2,2)
60780 K(N+2,2)=K(IA5,2)
60781 K(N+3,2)=K(IA2,2)
60782 K(N+4,2)=21
60783 K(N+5,2)=K(IA3,2)
60784 K(N+6,2)=K(IA4,2)
60785 K(N+1,3)=IA2
60786 K(N+1,4)=N+3
60787 K(N+1,5)=N+4
60788 K(N+2,3)=IA5
60789 K(N+3,3)=N+1
60790 K(N+4,3)=N+1
60791 K(N+4,4)=N+5
60792 K(N+4,5)=N+6
60793 K(N+5,3)=N+4
60794 K(N+6,3)=N+4
60795
60796C...Set up momenta for new partons.
60797 DO 140 J=1,5
60798 P(N+1,J)=P(IA2,J)+P(IA3,J)+P(IA4,J)
60799 P(N+2,J)=P(IA5,J)
60800 P(N+3,J)=P(IA2,J)
60801 P(N+4,J)=P(IA3,J)+P(IA4,J)
60802 P(N+5,J)=P(IA3,J)
60803 P(N+6,J)=P(IA4,J)
60804 140 CONTINUE
60805 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
60806 & P(N+1,3)**2))
60807 P(N+4,5)=SQRT(MAX(0D0,P(N+4,4)**2-P(N+4,1)**2-P(N+4,2)**2-
60808 & P(N+4,3)**2))
60809 QMAX=P(N+4,5)
60810
60811 ENDIF
60812 N=N+6
60813
60814 RETURN
60815 END
60816
60817C*********************************************************************
60818
60819C...PYJOIN
60820C...Connects a sequence of partons with colour flow indices,
60821C...as required for subsequent shower evolution (or other operations).
60822
60823 SUBROUTINE PYJOIN(NJOIN,IJOIN)
60824
60825C...Double precision and integer declarations.
60826 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60827 IMPLICIT INTEGER(I-N)
60828 INTEGER PYK,PYCHGE,PYCOMP
60829C...Commonblocks.
60830 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60831 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60832 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60833 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
60834C...Local array.
60835 DIMENSION IJOIN(*)
60836
60837C...Check that partons are of right types to be connected.
60838 IF(NJOIN.LT.2) GOTO 120
60839 KQSUM=0
60840 DO 100 IJN=1,NJOIN
60841 I=IJOIN(IJN)
60842 IF(I.LE.0.OR.I.GT.N) GOTO 120
60843 IF(K(I,1).LT.1.OR.K(I,1).GT.3) GOTO 120
60844 KC=PYCOMP(K(I,2))
60845 IF(KC.EQ.0) GOTO 120
60846 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
60847 IF(KQ.EQ.0) GOTO 120
60848 IF(IJN.NE.1.AND.IJN.NE.NJOIN.AND.KQ.NE.2) GOTO 120
60849 IF(KQ.NE.2) KQSUM=KQSUM+KQ
60850 IF(IJN.EQ.1) KQS=KQ
60851 100 CONTINUE
60852 IF(KQSUM.NE.0) GOTO 120
60853
60854C...Connect the partons sequentially (closing for gluon loop).
60855 KCS=(9-KQS)/2
60856 IF(KQS.EQ.2) KCS=INT(4.5D0+PYR(0))
60857 DO 110 IJN=1,NJOIN
60858 I=IJOIN(IJN)
60859 K(I,1)=3
60860 IF(IJN.NE.1) IP=IJOIN(IJN-1)
60861 IF(IJN.EQ.1) IP=IJOIN(NJOIN)
60862 IF(IJN.NE.NJOIN) IN=IJOIN(IJN+1)
60863 IF(IJN.EQ.NJOIN) IN=IJOIN(1)
60864 K(I,KCS)=MSTU(5)*IN
60865 K(I,9-KCS)=MSTU(5)*IP
60866 IF(IJN.EQ.1.AND.KQS.NE.2) K(I,9-KCS)=0
60867 IF(IJN.EQ.NJOIN.AND.KQS.NE.2) K(I,KCS)=0
60868 110 CONTINUE
60869
60870C...Error exit: no action taken.
60871 RETURN
60872 120 CALL PYERRM(12,
60873 &'(PYJOIN:) given entries can not be joined by one string')
60874
60875 RETURN
60876 END
60877
60878C*********************************************************************
60879
60880C...PYGIVE
60881C...Sets values of commonblock variables.
60882
60883 SUBROUTINE PYGIVE(CHIN)
60884
60885C...Double precision and integer declarations.
60886 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
60887 IMPLICIT INTEGER(I-N)
60888 INTEGER PYK,PYCHGE,PYCOMP
60889C...Commonblocks.
60890 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
60891 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
60892 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
60893 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
60894 COMMON/PYDAT4/CHAF(500,2)
60895 CHARACTER CHAF*16
60896 COMMON/PYDATR/MRPY(6),RRPY(100)
60897 COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
60898 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
60899 COMMON/PYINT1/MINT(400),VINT(400)
60900 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
60901 COMMON/PYINT3/XSFX(2,-40:40),ISIG(1000,3),SIGH(1000)
60902 COMMON/PYINT4/MWID(500),WIDS(500,5)
60903 COMMON/PYINT5/NGENPD,NGEN(0:500,3),XSEC(0:500,3)
60904 COMMON/PYINT6/PROC(0:500)
60905 CHARACTER PROC*28
60906 COMMON/PYINT7/SIGT(0:6,0:6,0:5)
60907 COMMON/PYINT8/XPVMD(-6:6),XPANL(-6:6),XPANH(-6:6),XPBEH(-6:6),
60908 &XPDIR(-6:6)
60909 COMMON/PYMSSM/IMSS(0:99),RMSS(0:99)
60910 COMMON/PYMSRV/RVLAM(3,3,3), RVLAMP(3,3,3), RVLAMB(3,3,3)
60911 COMMON/PYTCSM/ITCM(0:99),RTCM(0:99)
60912 COMMON/PYPUED/IUED(0:99),RUED(0:99)
60913 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYDATR/,
60914 &/PYSUBS/,/PYPARS/,/PYINT1/,/PYINT2/,/PYINT3/,/PYINT4/,/PYINT5/,
60915 &/PYINT6/,/PYINT7/,/PYINT8/,/PYMSSM/,/PYMSRV/,/PYTCSM/,/PYPUED/
60916C...Local arrays and character variables.
60917 CHARACTER CHIN*(*),CHFIX*104,CHBIT*104,CHOLD*8,CHNEW*8,CHOLD2*28,
60918 &CHNEW2*28,CHNAM*6,CHVAR(56)*6,CHALP(2)*26,CHIND*8,CHINI*10,
60919 &CHINR*16,CHDIG*10
60920 DIMENSION MSVAR(56,8)
60921
60922C...For each variable to be translated give: name,
60923C...integer/real/character, no. of indices, lower&upper index bounds.
60924 DATA CHVAR/'N','K','P','V','MSTU','PARU','MSTJ','PARJ','KCHG',
60925 &'PMAS','PARF','VCKM','MDCY','MDME','BRAT','KFDP','CHAF','MRPY',
60926 &'RRPY','MSEL','MSUB','KFIN','CKIN','MSTP','PARP','MSTI','PARI',
60927 &'MINT','VINT','ISET','KFPR','COEF','ICOL','XSFX','ISIG','SIGH',
60928 &'MWID','WIDS','NGEN','XSEC','PROC','SIGT','XPVMD','XPANL',
60929 &'XPANH','XPBEH','XPDIR','IMSS','RMSS','RVLAM','RVLAMP','RVLAMB',
60930 &'ITCM','RTCM','IUED','RUED'/
60931 DATA ((MSVAR(I,J),J=1,8),I=1,56)/ 1,7*0, 1,2,1,4000,1,5,2*0,
60932 &2,2,1,4000,1,5,2*0, 2,2,1,4000,1,5,2*0, 1,1,1,200,4*0,
60933 &2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60934 &1,2,1,500,1,4,2*0, 2,2,1,500,1,4,2*0, 2,1,1,2000,4*0,
60935 &2,2,1,4,1,4,2*0, 1,2,1,500,1,3,2*0, 1,2,1,8000,1,2,2*0,
60936 &2,1,1,8000,4*0, 1,2,1,8000,1,5,2*0, 3,2,1,500,1,2,2*0,
60937 &1,1,1,6,4*0, 2,1,1,100,4*0,
60938 &1,7*0, 1,1,1,500,4*0, 1,2,1,2,-40,40,2*0, 2,1,1,200,4*0,
60939 &1,1,1,200,4*0, 2,1,1,200,4*0, 1,1,1,200,4*0, 2,1,1,200,4*0,
60940 &1,1,1,400,4*0, 2,1,1,400,4*0, 1,1,1,500,4*0,
60941 &1,2,1,500,1,2,2*0, 2,2,1,500,1,20,2*0, 1,3,1,40,1,4,1,2,
60942 &2,2,1,2,-40,40,2*0, 1,2,1,1000,1,3,2*0, 2,1,1,1000,4*0,
60943 &1,1,1,500,4*0, 2,2,1,500,1,5,2*0, 1,2,0,500,1,3,2*0,
60944 &2,2,0,500,1,3,2*0, 4,1,0,500,4*0, 2,3,0,6,0,6,0,5,
60945 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 2,1,-6,6,4*0,
60946 &2,1,-6,6,4*0, 2,1,-6,6,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0,
60947 &2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3, 2,3,1,3,1,3,1,3,
60948 &1,1,0,99,4*0, 2,1,0,99,4*0, 1,1,0,99,4*0, 2,1,0,99,4*0/
60949 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
60950 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/, CHDIG/'1234567890'/
60951
60952C...Length of character variable. Subdivide it into instructions.
60953 IF(MSTU(12).NE.12345.AND.CHIN.NE.'mstu(12)=12345'.AND.
60954 &CHIN.NE.'MSTU(12)=12345') CALL PYLIST(0)
60955 CHBIT=CHIN//' '
60956 LBIT=101
60957 100 LBIT=LBIT-1
60958 IF(CHBIT(LBIT:LBIT).EQ.' ') GOTO 100
60959 LTOT=0
60960 DO 110 LCOM=1,LBIT
60961 IF(CHBIT(LCOM:LCOM).EQ.' ') GOTO 110
60962 LTOT=LTOT+1
60963 CHFIX(LTOT:LTOT)=CHBIT(LCOM:LCOM)
60964 110 CONTINUE
60965 LLOW=0
60966 120 LHIG=LLOW+1
60967 130 LHIG=LHIG+1
60968 IF(LHIG.LE.LTOT.AND.CHFIX(LHIG:LHIG).NE.';') GOTO 130
60969 LBIT=LHIG-LLOW-1
60970 CHBIT(1:LBIT)=CHFIX(LLOW+1:LHIG-1)
60971
60972C...Send off decay-mode on/off commands to PYONOF.
60973 IONOF=0
60974 DO 135 LDIG=1,10
60975 IF(CHBIT(1:1).EQ.CHDIG(LDIG:LDIG)) IONOF=1
60976 135 CONTINUE
60977 IF(IONOF.EQ.1) THEN
60978 CALL PYONOF(CHIN)
60979 RETURN
60980 ENDIF
60981
60982C...Peel off any text following exclamation mark.
60983 LHIG2=LBIT
60984 DO 140 LLOW2=LHIG2,1,-1
60985 IF(CHBIT(LLOW2:LLOW2).EQ.'!') LBIT=LLOW2-1
60986 140 CONTINUE
60987 IF(LBIT.EQ.0) RETURN
60988
60989C...Identify commonblock variable.
60990 LNAM=1
60991 150 LNAM=LNAM+1
60992 IF(CHBIT(LNAM:LNAM).NE.'('.AND.CHBIT(LNAM:LNAM).NE.'='.AND.
60993 &LNAM.LE.6) GOTO 150
60994 CHNAM=CHBIT(1:LNAM-1)//' '
60995 DO 170 LCOM=1,LNAM-1
60996 DO 160 LALP=1,26
60997 IF(CHNAM(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP)) CHNAM(LCOM:LCOM)=
60998 & CHALP(2)(LALP:LALP)
60999 160 CONTINUE
61000 170 CONTINUE
61001 IVAR=0
61002 DO 180 IV=1,56
61003 IF(CHNAM.EQ.CHVAR(IV)) IVAR=IV
61004 180 CONTINUE
61005 IF(IVAR.EQ.0) THEN
61006 CALL PYERRM(18,'(PYGIVE:) do not recognize variable '//CHNAM)
61007 LLOW=LHIG
61008 IF(LLOW.LT.LTOT) GOTO 120
61009 RETURN
61010 ENDIF
61011
61012C...Identify any indices.
61013 I1=0
61014 I2=0
61015 I3=0
61016 NINDX=0
61017 IF(CHBIT(LNAM:LNAM).EQ.'(') THEN
61018 LIND=LNAM
61019 190 LIND=LIND+1
61020 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 190
61021 CHIND=' '
61022 IF((CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.'c')
61023 & .AND.(IVAR.EQ.9.OR.IVAR.EQ.10.OR.IVAR.EQ.13.OR.IVAR.EQ.17.OR.
61024 & IVAR.EQ.37)) THEN
61025 CHIND(LNAM-LIND+11:8)=CHBIT(LNAM+2:LIND-1)
61026 READ(CHIND,'(I8)') KF
61027 I1=PYCOMP(KF)
61028 ELSEIF(CHBIT(LNAM+1:LNAM+1).EQ.'C'.OR.CHBIT(LNAM+1:LNAM+1).EQ.
61029 & 'c') THEN
61030 CALL PYERRM(18,'(PYGIVE:) not allowed to use C index for '//
61031 & CHNAM)
61032 LLOW=LHIG
61033 IF(LLOW.LT.LTOT) GOTO 120
61034 RETURN
61035 ELSE
61036 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
61037 READ(CHIND,'(I8)') I1
61038 ENDIF
61039 LNAM=LIND
61040 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
61041 NINDX=1
61042 ENDIF
61043 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
61044 LIND=LNAM
61045 200 LIND=LIND+1
61046 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 200
61047 CHIND=' '
61048 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
61049 READ(CHIND,'(I8)') I2
61050 LNAM=LIND
61051 IF(CHBIT(LNAM:LNAM).EQ.')') LNAM=LNAM+1
61052 NINDX=2
61053 ENDIF
61054 IF(CHBIT(LNAM:LNAM).EQ.',') THEN
61055 LIND=LNAM
61056 210 LIND=LIND+1
61057 IF(CHBIT(LIND:LIND).NE.')'.AND.CHBIT(LIND:LIND).NE.',') GOTO 210
61058 CHIND=' '
61059 CHIND(LNAM-LIND+10:8)=CHBIT(LNAM+1:LIND-1)
61060 READ(CHIND,'(I8)') I3
61061 LNAM=LIND+1
61062 NINDX=3
61063 ENDIF
61064
61065C...Check that indices allowed.
61066 IERR=0
61067 IF(NINDX.NE.MSVAR(IVAR,2)) IERR=1
61068 IF(NINDX.GE.1.AND.(I1.LT.MSVAR(IVAR,3).OR.I1.GT.MSVAR(IVAR,4)))
61069 &IERR=2
61070 IF(NINDX.GE.2.AND.(I2.LT.MSVAR(IVAR,5).OR.I2.GT.MSVAR(IVAR,6)))
61071 &IERR=3
61072 IF(NINDX.EQ.3.AND.(I3.LT.MSVAR(IVAR,7).OR.I3.GT.MSVAR(IVAR,8)))
61073 &IERR=4
61074 IF(CHBIT(LNAM:LNAM).NE.'=') IERR=5
61075 IF(IERR.GE.1) THEN
61076 CALL PYERRM(18,'(PYGIVE:) unallowed indices for '//
61077 & CHBIT(1:LNAM-1))
61078 LLOW=LHIG
61079 IF(LLOW.LT.LTOT) GOTO 120
61080 RETURN
61081 ENDIF
61082
61083C...Save old value of variable.
61084 IF(IVAR.EQ.1) THEN
61085 IOLD=N
61086 ELSEIF(IVAR.EQ.2) THEN
61087 IOLD=K(I1,I2)
61088 ELSEIF(IVAR.EQ.3) THEN
61089 ROLD=P(I1,I2)
61090 ELSEIF(IVAR.EQ.4) THEN
61091 ROLD=V(I1,I2)
61092 ELSEIF(IVAR.EQ.5) THEN
61093 IOLD=MSTU(I1)
61094 ELSEIF(IVAR.EQ.6) THEN
61095 ROLD=PARU(I1)
61096 ELSEIF(IVAR.EQ.7) THEN
61097 IOLD=MSTJ(I1)
61098 ELSEIF(IVAR.EQ.8) THEN
61099 ROLD=PARJ(I1)
61100 ELSEIF(IVAR.EQ.9) THEN
61101 IOLD=KCHG(I1,I2)
61102 ELSEIF(IVAR.EQ.10) THEN
61103 ROLD=PMAS(I1,I2)
61104 ELSEIF(IVAR.EQ.11) THEN
61105 ROLD=PARF(I1)
61106 ELSEIF(IVAR.EQ.12) THEN
61107 ROLD=VCKM(I1,I2)
61108 ELSEIF(IVAR.EQ.13) THEN
61109 IOLD=MDCY(I1,I2)
61110 ELSEIF(IVAR.EQ.14) THEN
61111 IOLD=MDME(I1,I2)
61112 ELSEIF(IVAR.EQ.15) THEN
61113 ROLD=BRAT(I1)
61114 ELSEIF(IVAR.EQ.16) THEN
61115 IOLD=KFDP(I1,I2)
61116 ELSEIF(IVAR.EQ.17) THEN
61117 CHOLD=CHAF(I1,I2)(1:8)
61118 ELSEIF(IVAR.EQ.18) THEN
61119 IOLD=MRPY(I1)
61120 ELSEIF(IVAR.EQ.19) THEN
61121 ROLD=RRPY(I1)
61122 ELSEIF(IVAR.EQ.20) THEN
61123 IOLD=MSEL
61124 ELSEIF(IVAR.EQ.21) THEN
61125 IOLD=MSUB(I1)
61126 ELSEIF(IVAR.EQ.22) THEN
61127 IOLD=KFIN(I1,I2)
61128 ELSEIF(IVAR.EQ.23) THEN
61129 ROLD=CKIN(I1)
61130 ELSEIF(IVAR.EQ.24) THEN
61131 IOLD=MSTP(I1)
61132 ELSEIF(IVAR.EQ.25) THEN
61133 ROLD=PARP(I1)
61134 ELSEIF(IVAR.EQ.26) THEN
61135 IOLD=MSTI(I1)
61136 ELSEIF(IVAR.EQ.27) THEN
61137 ROLD=PARI(I1)
61138 ELSEIF(IVAR.EQ.28) THEN
61139 IOLD=MINT(I1)
61140 ELSEIF(IVAR.EQ.29) THEN
61141 ROLD=VINT(I1)
61142 ELSEIF(IVAR.EQ.30) THEN
61143 IOLD=ISET(I1)
61144 ELSEIF(IVAR.EQ.31) THEN
61145 IOLD=KFPR(I1,I2)
61146 ELSEIF(IVAR.EQ.32) THEN
61147 ROLD=COEF(I1,I2)
61148 ELSEIF(IVAR.EQ.33) THEN
61149 IOLD=ICOL(I1,I2,I3)
61150 ELSEIF(IVAR.EQ.34) THEN
61151 ROLD=XSFX(I1,I2)
61152 ELSEIF(IVAR.EQ.35) THEN
61153 IOLD=ISIG(I1,I2)
61154 ELSEIF(IVAR.EQ.36) THEN
61155 ROLD=SIGH(I1)
61156 ELSEIF(IVAR.EQ.37) THEN
61157 IOLD=MWID(I1)
61158 ELSEIF(IVAR.EQ.38) THEN
61159 ROLD=WIDS(I1,I2)
61160 ELSEIF(IVAR.EQ.39) THEN
61161 IOLD=NGEN(I1,I2)
61162 ELSEIF(IVAR.EQ.40) THEN
61163 ROLD=XSEC(I1,I2)
61164 ELSEIF(IVAR.EQ.41) THEN
61165 CHOLD2=PROC(I1)
61166 ELSEIF(IVAR.EQ.42) THEN
61167 ROLD=SIGT(I1,I2,I3)
61168 ELSEIF(IVAR.EQ.43) THEN
61169 ROLD=XPVMD(I1)
61170 ELSEIF(IVAR.EQ.44) THEN
61171 ROLD=XPANL(I1)
61172 ELSEIF(IVAR.EQ.45) THEN
61173 ROLD=XPANH(I1)
61174 ELSEIF(IVAR.EQ.46) THEN
61175 ROLD=XPBEH(I1)
61176 ELSEIF(IVAR.EQ.47) THEN
61177 ROLD=XPDIR(I1)
61178 ELSEIF(IVAR.EQ.48) THEN
61179 IOLD=IMSS(I1)
61180 ELSEIF(IVAR.EQ.49) THEN
61181 ROLD=RMSS(I1)
61182 ELSEIF(IVAR.EQ.50) THEN
61183 ROLD=RVLAM(I1,I2,I3)
61184 ELSEIF(IVAR.EQ.51) THEN
61185 ROLD=RVLAMP(I1,I2,I3)
61186 ELSEIF(IVAR.EQ.52) THEN
61187 ROLD=RVLAMB(I1,I2,I3)
61188 ELSEIF(IVAR.EQ.53) THEN
61189 IOLD=ITCM(I1)
61190 ELSEIF(IVAR.EQ.54) THEN
61191 ROLD=RTCM(I1)
61192 ELSEIF(IVAR.EQ.55) THEN
61193 IOLD=IUED(I1)
61194 ELSEIF(IVAR.EQ.56) THEN
61195 ROLD=RUED(I1)
61196 ENDIF
61197
61198C...Print current value of variable. Loop back.
61199 IF(LNAM.GE.LBIT) THEN
61200 CHBIT(LNAM:14)=' '
61201 CHBIT(15:60)=' has the value '
61202 IF(MSVAR(IVAR,1).EQ.1) THEN
61203 WRITE(CHBIT(51:60),'(I10)') IOLD
61204 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
61205 WRITE(CHBIT(47:60),'(F14.5)') ROLD
61206 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
61207 CHBIT(53:60)=CHOLD
61208 ELSE
61209 CHBIT(33:60)=CHOLD
61210 ENDIF
61211 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61212 LLOW=LHIG
61213 IF(LLOW.LT.LTOT) GOTO 120
61214 RETURN
61215 ENDIF
61216
61217C...Read in new variable value.
61218 IF(MSVAR(IVAR,1).EQ.1) THEN
61219 CHINI=' '
61220 CHINI(LNAM-LBIT+11:10)=CHBIT(LNAM+1:LBIT)
61221 READ(CHINI,'(I10)') INEW
61222 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
61223 CHINR=' '
61224 CHINR(LNAM-LBIT+17:16)=CHBIT(LNAM+1:LBIT)
61225 READ(CHINR,*) RNEW
61226 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
61227 CHNEW=CHBIT(LNAM+1:LBIT)//' '
61228 ELSE
61229 CHNEW2=CHBIT(LNAM+1:LBIT)//' '
61230 ENDIF
61231
61232C...Store new variable value.
61233 IF(IVAR.EQ.1) THEN
61234 N=INEW
61235 ELSEIF(IVAR.EQ.2) THEN
61236 K(I1,I2)=INEW
61237 ELSEIF(IVAR.EQ.3) THEN
61238 P(I1,I2)=RNEW
61239 ELSEIF(IVAR.EQ.4) THEN
61240 V(I1,I2)=RNEW
61241 ELSEIF(IVAR.EQ.5) THEN
61242 MSTU(I1)=INEW
61243 ELSEIF(IVAR.EQ.6) THEN
61244 PARU(I1)=RNEW
61245 ELSEIF(IVAR.EQ.7) THEN
61246 MSTJ(I1)=INEW
61247 ELSEIF(IVAR.EQ.8) THEN
61248 PARJ(I1)=RNEW
61249 ELSEIF(IVAR.EQ.9) THEN
61250 KCHG(I1,I2)=INEW
61251 ELSEIF(IVAR.EQ.10) THEN
61252 PMAS(I1,I2)=RNEW
61253 ELSEIF(IVAR.EQ.11) THEN
61254 PARF(I1)=RNEW
61255 ELSEIF(IVAR.EQ.12) THEN
61256 VCKM(I1,I2)=RNEW
61257 ELSEIF(IVAR.EQ.13) THEN
61258 MDCY(I1,I2)=INEW
61259 ELSEIF(IVAR.EQ.14) THEN
61260 MDME(I1,I2)=INEW
61261 ELSEIF(IVAR.EQ.15) THEN
61262 BRAT(I1)=RNEW
61263 ELSEIF(IVAR.EQ.16) THEN
61264 KFDP(I1,I2)=INEW
61265 ELSEIF(IVAR.EQ.17) THEN
61266 CHAF(I1,I2)=CHNEW
61267 ELSEIF(IVAR.EQ.18) THEN
61268 MRPY(I1)=INEW
61269 ELSEIF(IVAR.EQ.19) THEN
61270 RRPY(I1)=RNEW
61271 ELSEIF(IVAR.EQ.20) THEN
61272 MSEL=INEW
61273 ELSEIF(IVAR.EQ.21) THEN
61274 MSUB(I1)=INEW
61275 ELSEIF(IVAR.EQ.22) THEN
61276 KFIN(I1,I2)=INEW
61277 ELSEIF(IVAR.EQ.23) THEN
61278 CKIN(I1)=RNEW
61279 ELSEIF(IVAR.EQ.24) THEN
61280 MSTP(I1)=INEW
61281 ELSEIF(IVAR.EQ.25) THEN
61282 PARP(I1)=RNEW
61283 ELSEIF(IVAR.EQ.26) THEN
61284 MSTI(I1)=INEW
61285 ELSEIF(IVAR.EQ.27) THEN
61286 PARI(I1)=RNEW
61287 ELSEIF(IVAR.EQ.28) THEN
61288 MINT(I1)=INEW
61289 ELSEIF(IVAR.EQ.29) THEN
61290 VINT(I1)=RNEW
61291 ELSEIF(IVAR.EQ.30) THEN
61292 ISET(I1)=INEW
61293 ELSEIF(IVAR.EQ.31) THEN
61294 KFPR(I1,I2)=INEW
61295 ELSEIF(IVAR.EQ.32) THEN
61296 COEF(I1,I2)=RNEW
61297 ELSEIF(IVAR.EQ.33) THEN
61298 ICOL(I1,I2,I3)=INEW
61299 ELSEIF(IVAR.EQ.34) THEN
61300 XSFX(I1,I2)=RNEW
61301 ELSEIF(IVAR.EQ.35) THEN
61302 ISIG(I1,I2)=INEW
61303 ELSEIF(IVAR.EQ.36) THEN
61304 SIGH(I1)=RNEW
61305 ELSEIF(IVAR.EQ.37) THEN
61306 MWID(I1)=INEW
61307 ELSEIF(IVAR.EQ.38) THEN
61308 WIDS(I1,I2)=RNEW
61309 ELSEIF(IVAR.EQ.39) THEN
61310 NGEN(I1,I2)=INEW
61311 ELSEIF(IVAR.EQ.40) THEN
61312 XSEC(I1,I2)=RNEW
61313 ELSEIF(IVAR.EQ.41) THEN
61314 PROC(I1)=CHNEW2
61315 ELSEIF(IVAR.EQ.42) THEN
61316 SIGT(I1,I2,I3)=RNEW
61317 ELSEIF(IVAR.EQ.43) THEN
61318 XPVMD(I1)=RNEW
61319 ELSEIF(IVAR.EQ.44) THEN
61320 XPANL(I1)=RNEW
61321 ELSEIF(IVAR.EQ.45) THEN
61322 XPANH(I1)=RNEW
61323 ELSEIF(IVAR.EQ.46) THEN
61324 XPBEH(I1)=RNEW
61325 ELSEIF(IVAR.EQ.47) THEN
61326 XPDIR(I1)=RNEW
61327 ELSEIF(IVAR.EQ.48) THEN
61328 IMSS(I1)=INEW
61329 ELSEIF(IVAR.EQ.49) THEN
61330 RMSS(I1)=RNEW
61331 ELSEIF(IVAR.EQ.50) THEN
61332 RVLAM(I1,I2,I3)=RNEW
61333 ELSEIF(IVAR.EQ.51) THEN
61334 RVLAMP(I1,I2,I3)=RNEW
61335 ELSEIF(IVAR.EQ.52) THEN
61336 RVLAMB(I1,I2,I3)=RNEW
61337 ELSEIF(IVAR.EQ.53) THEN
61338 ITCM(I1)=INEW
61339 ELSEIF(IVAR.EQ.54) THEN
61340 RTCM(I1)=RNEW
61341 ELSEIF(IVAR.EQ.55) THEN
61342 IUED(I1)=INEW
61343 ELSEIF(IVAR.EQ.56) THEN
61344 RUED(I1)=RNEW
61345 ENDIF
61346
61347C...Write old and new value. Loop back.
61348 CHBIT(LNAM:14)=' '
61349 CHBIT(15:60)=' changed from to '
61350 IF(MSVAR(IVAR,1).EQ.1) THEN
61351 WRITE(CHBIT(33:42),'(I10)') IOLD
61352 WRITE(CHBIT(51:60),'(I10)') INEW
61353 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61354 ELSEIF(MSVAR(IVAR,1).EQ.2) THEN
61355 WRITE(CHBIT(29:42),'(F14.5)') ROLD
61356 WRITE(CHBIT(47:60),'(F14.5)') RNEW
61357 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61358 ELSEIF(MSVAR(IVAR,1).EQ.3) THEN
61359 CHBIT(35:42)=CHOLD
61360 CHBIT(53:60)=CHNEW
61361 IF(MSTU(13).GE.1) WRITE(MSTU(11),5000) CHBIT(1:60)
61362 ELSE
61363 CHBIT(15:88)=' changed from '//CHOLD2//' to '//CHNEW2
61364 IF(MSTU(13).GE.1) WRITE(MSTU(11),5100) CHBIT(1:88)
61365 ENDIF
61366 LLOW=LHIG
61367 IF(LLOW.LT.LTOT) GOTO 120
61368
61369C...Format statement for output on unit MSTU(11) (by default 6).
61370 5000 FORMAT(5X,A60)
61371 5100 FORMAT(5X,A88)
61372
61373 RETURN
61374 END
61375
61376C*********************************************************************
61377
61378C...PYONOF
61379C...Switches on and off decay channel by search for match.
61380
61381 SUBROUTINE PYONOF(CHIN)
61382
61383C...Double precision and integer declarations.
61384 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61385 IMPLICIT INTEGER(I-N)
61386 INTEGER PYK,PYCHGE,PYCOMP
61387C...Commonblocks.
61388 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61389 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
61390 SAVE /PYDAT1/,/PYDAT3/
61391C...Local arrays and character variables.
61392 INTEGER KFCMP(10),KFTMP(10)
61393 CHARACTER CHIN*(*),CHTMP*104,CHFIX*104,CHMODE*10,CHCODE*8,
61394 &CHALP(2)*26
61395 DATA CHALP/'abcdefghijklmnopqrstuvwxyz',
61396 &'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
61397
61398C...Determine length of character variable.
61399 CHTMP=CHIN//' '
61400 LBEG=0
61401 100 LBEG=LBEG+1
61402 IF(CHTMP(LBEG:LBEG).EQ.' ') GOTO 100
61403 LEND=LBEG-1
61404 105 LEND=LEND+1
61405 IF(LEND.LE.100.AND.CHTMP(LEND:LEND).NE.'!') GOTO 105
61406 110 LEND=LEND-1
61407 IF(CHTMP(LEND:LEND).EQ.' ') GOTO 110
61408 LEN=1+LEND-LBEG
61409 CHFIX(1:LEN)=CHTMP(LBEG:LEND)
61410
61411C...Find colon separator and particle code.
61412 LCOLON=0
61413 120 LCOLON=LCOLON+1
61414 IF(CHFIX(LCOLON:LCOLON).NE.':') GOTO 120
61415 CHCODE=' '
61416 CHCODE(10-LCOLON:8)=CHFIX(1:LCOLON-1)
61417 READ(CHCODE,'(I8)',ERR=300) KF
61418 KC=PYCOMP(KF)
61419
61420C...Done if unknown code or no decay channels.
61421 IF(KC.EQ.0) THEN
61422 CALL PYERRM(18,'(PYONOF:) unrecognized particle '//CHCODE)
61423 RETURN
61424 ENDIF
61425 IDCBEG=MDCY(KC,2)
61426 IDCLEN=MDCY(KC,3)
61427 IF(IDCBEG.EQ.0.OR.IDCLEN.EQ.0) THEN
61428 CALL PYERRM(18,'(PYONOF:) no decay channels for '//CHCODE)
61429 RETURN
61430 ENDIF
61431
61432C...Find command name up to blank or equal sign.
61433 LSEP=LCOLON
61434 130 LSEP=LSEP+1
61435 IF(LSEP.LE.LEN.AND.CHFIX(LSEP:LSEP).NE.' '.AND.
61436 &CHFIX(LSEP:LSEP).NE.'=') GOTO 130
61437 CHMODE=' '
61438 LMODE=LSEP-LCOLON-1
61439 CHMODE(1:LMODE)=CHFIX(LCOLON+1:LSEP-1)
61440
61441C...Convert to uppercase.
61442 DO 150 LCOM=1,LMODE
61443 DO 140 LALP=1,26
61444 IF(CHMODE(LCOM:LCOM).EQ.CHALP(1)(LALP:LALP))
61445 & CHMODE(LCOM:LCOM)=CHALP(2)(LALP:LALP)
61446 140 CONTINUE
61447 150 CONTINUE
61448
61449C...Identify command. Failed if not identified.
61450 MODE=0
61451 IF(CHMODE.EQ.'ALLOFF') MODE=1
61452 IF(CHMODE.EQ.'ALLON') MODE=2
61453 IF(CHMODE.EQ.'OFFIFANY') MODE=3
61454 IF(CHMODE.EQ.'ONIFANY') MODE=4
61455 IF(CHMODE.EQ.'OFFIFALL') MODE=5
61456 IF(CHMODE.EQ.'ONIFALL') MODE=6
61457 IF(CHMODE.EQ.'OFFIFMATCH') MODE=7
61458 IF(CHMODE.EQ.'ONIFMATCH') MODE=8
61459 IF(MODE.EQ.0) THEN
61460 CALL PYERRM(18,'(PYONOF:) unknown command '//CHMODE)
61461 RETURN
61462 ENDIF
61463
61464C...Simple cases when all on or all off.
61465 IF(MODE.EQ.1.OR.MODE.EQ.2) THEN
61466 WRITE(MSTU(11),1000) KF,CHMODE
61467 DO 160 IDC=IDCBEG,IDCBEG+IDCLEN-1
61468 IF(MDME(IDC,1).LT.0) GOTO 160
61469 MDME(IDC,1)=MODE-1
61470 160 CONTINUE
61471 RETURN
61472 ENDIF
61473
61474C...Identify matching list.
61475 NCMP=0
61476 LBEG=LSEP
61477 170 LBEG=LBEG+1
61478 IF(LBEG.GT.LEN) GOTO 190
61479 IF(LBEG.LT.LEN.AND.(CHFIX(LBEG:LBEG).EQ.' '.OR.
61480 &CHFIX(LBEG:LBEG).EQ.'='.OR.CHFIX(LBEG:LBEG).EQ.',')) GOTO 170
61481 LEND=LBEG-1
61482 180 LEND=LEND+1
61483 IF(LEND.LT.LEN.AND.CHFIX(LEND:LEND).NE.' '.AND.
61484 &CHFIX(LEND:LEND).NE.'='.AND.CHFIX(LEND:LEND).NE.',') GOTO 180
61485 IF(LEND.LT.LEN) LEND=LEND-1
61486 CHCODE=' '
61487 CHCODE(8-LEND+LBEG:8)=CHFIX(LBEG:LEND)
61488 READ(CHCODE,'(I8)',ERR=300) KFREAD
61489 NCMP=NCMP+1
61490 KFCMP(NCMP)=IABS(KFREAD)
61491 LBEG=LEND
61492 IF(NCMP.LT.10) GOTO 170
61493 190 CONTINUE
61494 WRITE(MSTU(11),1100) KF,CHMODE,(KFCMP(ICMP),ICMP=1,NCMP)
61495
61496C...Only one matching required.
61497 IF(MODE.EQ.3.OR.MODE.EQ.4) THEN
61498 DO 220 IDC=IDCBEG,IDCBEG+IDCLEN-1
61499 IF(MDME(IDC,1).LT.0) GOTO 220
61500 DO 210 IKF=1,5
61501 KFNOW=IABS(KFDP(IDC,IKF))
61502 IF(KFNOW.EQ.0) GOTO 210
61503 DO 200 ICMP=1,NCMP
61504 IF(KFCMP(ICMP).EQ.KFNOW) THEN
61505 MDME(IDC,1)=MODE-3
61506 GOTO 220
61507 ENDIF
61508 200 CONTINUE
61509 210 CONTINUE
61510 220 CONTINUE
61511 RETURN
61512 ENDIF
61513
61514C...Multiple matchings required.
61515 DO 260 IDC=IDCBEG,IDCBEG+IDCLEN-1
61516 IF(MDME(IDC,1).LT.0) GOTO 260
61517 NTMP=NCMP
61518 DO 230 ITMP=1,NTMP
61519 KFTMP(ITMP)=KFCMP(ITMP)
61520 230 CONTINUE
61521 NFIN=0
61522 DO 250 IKF=1,5
61523 KFNOW=IABS(KFDP(IDC,IKF))
61524 IF(KFNOW.EQ.0) GOTO 250
61525 NFIN=NFIN+1
61526 DO 240 ITMP=1,NTMP
61527 IF(KFTMP(ITMP).EQ.KFNOW) THEN
61528 KFTMP(ITMP)=KFTMP(NTMP)
61529 NTMP=NTMP-1
61530 GOTO 250
61531 ENDIF
61532 240 CONTINUE
61533 250 CONTINUE
61534 IF(NTMP.EQ.0.AND.MODE.LE.6) MDME(IDC,1)=MODE-5
61535 IF(NTMP.EQ.0.AND.NFIN.EQ.NCMP.AND.MODE.GE.7)
61536 & MDME(IDC,1)=MODE-7
61537 260 CONTINUE
61538 RETURN
61539
61540C...Error exit for impossible read of particle code.
61541 300 CALL PYERRM(18,'(PYONOF:) could not interpret particle code '
61542 &//CHCODE)
61543
61544C...Formats for output.
61545 1000 FORMAT(' Decays for',I8,' set ',A10)
61546 1100 FORMAT(' Decays for',I8,' set ',A10,' if match',10I8)
61547
61548 RETURN
61549 END
61550C*********************************************************************
61551
61552C...PYTUNE
61553C...Presets for a few specific underlying-event and min-bias tunes
61554C...Note some tunes require external pdfs to be linked (e.g. 105:QW),
61555C...others require particular versions of pythia (e.g. the SCI and GAL
61556C...models). See below for details.
61557 SUBROUTINE PYTUNE(ITUNE)
61558C
61559C ITUNE NAME (detailed descriptions below)
61560C 0 Default : No settings changed => defaults.
61561C
61562C ====== Old UE, Q2-ordered showers ====================================
61563C 100 A : Rick Field's CDF Tune A (Oct 2002)
61564C 101 AW : Rick Field's CDF Tune AW (Apr 2006)
61565C 102 BW : Rick Field's CDF Tune BW (Apr 2006)
61566C 103 DW : Rick Field's CDF Tune DW (Apr 2006)
61567C 104 DWT : As DW but with slower UE ECM-scaling (Apr 2006)
61568C 105 QW : Rick Field's CDF Tune QW using CTEQ6.1M (?)
61569C 106 ATLAS-DC2: Arthur Moraes' (old) ATLAS tune ("Rome") (?)
61570C 107 ACR : Tune A modified with new CR model (Mar 2007)
61571C 108 D6 : Rick Field's CDF Tune D6 using CTEQ6L1 (?)
61572C 109 D6T : Rick Field's CDF Tune D6T using CTEQ6L1 (?)
61573C ---- Professor Tunes : 110+ (= 100+ with Professor's tune to LEP) ----
61574C 110 A-Pro : Tune A, with LEP tune from Professor (Oct 2008)
61575C 111 AW-Pro : Tune AW, -"- (Oct 2008)
61576C 112 BW-Pro : Tune BW, -"- (Oct 2008)
61577C 113 DW-Pro : Tune DW, -"- (Oct 2008)
61578C 114 DWT-Pro : Tune DWT, -"- (Oct 2008)
61579C 115 QW-Pro : Tune QW, -"- (Oct 2008)
61580C 116 ATLAS-DC2-Pro: ATLAS-DC2 / Rome, -"- (Oct 2008)
61581C 117 ACR-Pro : Tune ACR, -"- (Oct 2008)
61582C 118 D6-Pro : Tune D6, -"- (Oct 2008)
61583C 119 D6T-Pro : Tune D6T, -"- (Oct 2008)
61584C ---- Professor's Q2-ordered Perugia Tune : 129 -----------------------
61585C 129 Pro-Q2O : Professor Q2-ordered tune (Feb 2009)
61586C
61587C ====== Intermediate and Hybrid Models ================================
61588C 200 IM 1 : Intermediate model: new UE, Q2-ord. showers, new CR
61589C 201 APT : Tune A w. pT-ordered FSR (Mar 2007)
61590C 211 APT-Pro : Tune APT, with LEP tune from Professor (Oct 2008)
61591C 221 Perugia APT : "Perugia" update of APT-Pro (Feb 2009)
61592C 226 Perugia APT6 : "Perugia" update of APT-Pro w. CTEQ6L1 (Feb 2009)
61593C
61594C ====== New UE, interleaved pT-ordered showers, annealing CR ==========
61595C 300 S0 : Sandhoff-Skands Tune using the S0 CR model (Apr 2006)
61596C 301 S1 : Sandhoff-Skands Tune using the S1 CR model (Apr 2006)
61597C 302 S2 : Sandhoff-Skands Tune using the S2 CR model (Apr 2006)
61598C 303 S0A : S0 with "Tune A" UE energy scaling (Apr 2006)
61599C 304 NOCR : New UE "best try" without col. rec. (Apr 2006)
61600C 305 Old : New UE, original (primitive) col. rec. (Aug 2004)
61601C 306 ATLAS-CSC: Arthur Moraes' (new) ATLAS tune w. CTEQ6L1 (?)
61602C ---- Professor Tunes : 310+ (= 300+ with Professor's tune to LEP)
61603C 310 S0-Pro : S0 with updated LEP pars from Professor (Oct 2008)
61604C 311 S1-Pro : S1 -"- (Oct 2008)
61605C 312 S2-Pro : S2 -"- (Oct 2008)
61606C 313 S0A-Pro : S0A -"- (Oct 2008)
61607C 314 NOCR-Pro : NOCR -"- (Oct 2008)
61608C 315 Old-Pro : Old -"- (Oct 2008)
61609C 316 ATLAS MC08 : pT-ordered showers, CTEQ6L1 (2008)
61610C ---- Peter's Perugia Tunes : 320+ ------------------------------------
61611C 320 Perugia 0 : "Perugia" update of S0-Pro (Feb 2009)
61612C 321 Perugia HARD : More ISR, More FSR, Less MPI, Less BR, Less HAD
61613C 322 Perugia SOFT : Less ISR, Less FSR, More MPI, More BR, More HAD
61614C 323 Perugia 3 : Alternative to Perugia 0, with different ISR/MPI
61615C balance & different scaling to LHC & RHIC (Feb 2009)
61616C 324 Perugia NOCR : "Perugia" update of NOCR-Pro (Feb 2009)
61617C 325 Perugia * : "Perugia" Tune w. (external) MRSTLO* PDFs (Feb 2009)
61618C 326 Perugia 6 : "Perugia" Tune w. (external) CTEQ6L1 PDFs (Feb 2009)
61619C 327 Perugia 10: Alternative to Perugia 0, with more FSR (May 2010)
61620C off ISR, more BR breakup, more strangeness
61621C 328 Perugia K : Alternative to Perugia 2010, with a (May 2010)
61622C K-factor applied to MPI cross sections
61623C ---- Professor's pT-ordered Perugia Tune : 329 -----------------------
61624C 329 Pro-pTO : Professor pT-ordered tune w. S0 CR model (Feb 2009)
61625C ---- Tunes introduced in 6.4.23:
61626C 330 ATLAS MC09 : pT-ordered showers, LO* PDFs (2009)
61627C 331 ATLAS MC09c : pT-ordered showers, LO* PDFs, better CR (2009)
61628C 334 Perugia 10 NOCR : Perugia 2010 with no CR, less MPI (Oct 2010)
61629C 335 Pro-pT* : Professor Tune with LO* (Mar 2009)
61630C 336 Pro-pT6 : Professor Tune with CTEQ6LL (Mar 2009)
61631C 339 Pro-pT** : Professor Tune with LO** (Mar 2009)
61632C 340 AMBT1 : First ATLAS tune including 7 TeV data (May 2010)
61633C 341 Z1 : First CMS tune including 7 TeV data (Aug 2010)
61634C 342 Z1-LEP : CMS tune Z1, with improved LEP parameters (Oct 2010)
61635C 343 Z2 : Retune of Z1 by Field w CTEQ6L1 PDFs (2010)
61636C 344 Z2-LEP : Retune of Z1 by Skands w CTEQ6L1 PDFs (Feb 2011)
61637C 350 Perugia 2011 : Retune of Perugia 2010 incl 7-TeV data (Mar 2011)
61638C 351 P2011 radHi : Variation with alphaS(pT/2)
61639C 352 P2011 radLo : Variation with alphaS(2pT)
61640C 353 P2011 mpiHi : Variation with more semi-hard MPI
61641C 354 P2011 noCR : Variation without color reconnections
61642C 355 P2011 LO** : Perugia 2011 using MSTW LO** PDFs (Mar 2011)
61643C 356 P2011 C6 : Perugia 2011 using CTEQ6L1 PDFs (Mar 2011)
61644C 357 P2011 T16 : Variation with PARP(90)=0.32 away from 7 TeV
61645C 358 P2011 T32 : Variation with PARP(90)=0.16 awat from 7 TeV
61646C 359 P2011 TeV : Perugia 2011 optimized for Tevatron (Mar 2011)
61647C 360 S Global : Schulz-Skands Global fit (Mar 2011)
61648C 361 S 7000 : Schulz-Skands at 7000 GeV (Mar 2011)
61649C 362 S 1960 : Schulz-Skands at 1960 GeV (Mar 2011)
61650C 363 S 1800 : Schulz-Skands at 1800 GeV (Mar 2011)
61651C 364 S 900 : Schulz-Skands at 900 GeV (Mar 2011)
61652C 365 S 630 : Schulz-Skands at 630 GeV (Mar 2011)
61653C
61654C ======= The Uppsala models ===========================================
61655C ( NB! must be run with special modified Pythia 6.215 version )
61656C ( available from http://www.isv.uu.se/thep/MC/scigal/ )
61657C 400 GAL 0 : Generalized area-law model. Org pars (Dec 1998)
61658C 401 SCI 0 : Soft-Colour-Interaction model. Org pars (Dec 1998)
61659C 402 GAL 1 : GAL 0. Tevatron MB retuned (Skands) (Oct 2006)
61660C 403 SCI 1 : SCI 0. Tevatron MB retuned (Skands) (Oct 2006)
61661C
61662C More details;
61663C
61664C Quick Dictionary:
61665C BE : Bose-Einstein
61666C BR : Beam Remnants
61667C CR : Colour Reconnections
61668C HAD: Hadronization
61669C ISR/FSR: Initial-State Radiation / Final-State Radiation
61670C FSI: Final-State Interactions (=CR+BE)
61671C MB : Minimum-bias
61672C MI : Multiple Interactions
61673C UE : Underlying Event
61674C
61675C=======================================================================
61676C TUNES OF OLD FRAMEWORK (Q2-ORDERED ISR AND FSR, NON-INTERLEAVED UE)
61677C=======================================================================
61678C
61679C A (100) and AW (101). CTEQ5L parton distributions
61680C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61681C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61682C...Key feature: extensively compared to CDF data (R.D. Field).
61683C...* Large starting scale for ISR (PARP(67)=4)
61684C...* AW has even more radiation due to smaller mu_R choice in alpha_s.
61685C...* See: http://www.phys.ufl.edu/~rfield/cdf/
61686C
61687C BW (102). CTEQ5L parton distributions
61688C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61689C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61690C...Key feature: extensively compared to CDF data (R.D. Field).
61691C...NB: Can also be run with Pythia 6.2 or 6.312+
61692C...* Small starting scale for ISR (PARP(67)=1)
61693C...* BW has more radiation due to smaller mu_R choice in alpha_s.
61694C...* See: http://www.phys.ufl.edu/~rfield/cdf/
61695C
61696C DW (103) and DWT (104). 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...* Intermediate starting scale for ISR (PARP(67)=2.5)
61702C...* DWT has a different reference energy, the same as the "S" models
61703C... below, leading to more UE activity at the LHC, but less at RHIC.
61704C...* See: http://www.phys.ufl.edu/~rfield/cdf/
61705C
61706C QW (105). CTEQ61 parton distributions
61707C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61708C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61709C...Key feature: uses CTEQ61 (external pdf library must be linked)
61710C
61711C ATLAS-DC2 (106). CTEQ5L parton distributions
61712C...*** NB : SHOULD BE RUN WITH PYTHIA 6.2 (e.g. 6.228) ***
61713C...*** CAN ALSO BE RUN WITH PYTHIA 6.406+
61714C...Key feature: tune used by the ATLAS collaboration.
61715C
61716C ACR (107). CTEQ5L parton distributions
61717C...*** NB : SHOULD BE RUN WITH PYTHIA 6.412+ ***
61718C...Key feature: Tune A modified to use annealing CR.
61719C...NB: PARP(85)=0D0 and amount of CR is regulated by PARP(78).
61720C
61721C D6 (108) and D6T (109). CTEQ6L parton distributions
61722C...Key feature: Like DW and DWT but retuned to use CTEQ6L PDFs.
61723C
61724C A-Pro, BW-Pro, etc (111, 112, etc). CTEQ5L parton distributions
61725C Old UE model, Q2-ordered showers.
61726C...Key feature: Rick Field's family of tunes revamped with the
61727C...Professor Q2-ordered final-state shower and fragmentation tunes
61728C...presented by Hendrik Hoeth at the Perugia MPI workshop in Oct 2008.
61729C...Key feature: improved descriptions of LEP data.
61730C
61731C Pro-Q2O (129). CTEQ5L parton distributions
61732C Old UE model, Q2-ordered showers.
61733C...Key feature: Complete retune of old model by Professor, including
61734C...large amounts of both LEP and Tevatron data.
61735C...Note that PARP(64) (ISR renormalization scale pre-factor) is quite
61736C...extreme in this tune, corresponding to using mu_R = pT/3 .
61737C
61738C=======================================================================
61739C INTERMEDIATE/HYBRID TUNES (MIX OF NEW AND OLD SHOWER AND UE MODELS)
61740C=======================================================================
61741C
61742C IM1 (200). Intermediate model, Q2-ordered showers,
61743C CTEQ5L parton distributions
61744C...Key feature: new UE model w Q2-ordered showers and no interleaving.
61745C...* "Rap" tune of hep-ph/0402078, modified with new annealing CR.
61746C...* See: Sjostrand & Skands: JHEP 03(2004)053, hep-ph/0402078.
61747C
61748C APT (201). Old UE model, pT-ordered final-state showers,
61749C CTEQ5L parton distributions
61750C...Key feature: Rick Field's Tune A, but with new final-state showers
61751C
61752C APT-Pro (211). Old UE model, pT-ordered final-state showers,
61753C CTEQ5L parton distributions
61754C...Key feature: APT revamped with the Professor pT-ordered final-state
61755C...shower and fragmentation tunes presented by Hendrik Hoeth at the
61756C...Perugia MPI workshop in October 2008.
61757C
61758C Perugia-APT (221). Old UE model, pT-ordered final-state showers,
61759C CTEQ5L parton distributions
61760C...Key feature: APT-Pro with final-state showers off the MPI,
61761C...lower ISR renormalization scale to improve agreement with the
61762C...Tevatron Drell-Yan pT measurements and with improved energy scaling
61763C...to min-bias at 630 GeV.
61764C
61765C Perugia-APT6 (226). Old UE model, pT-ordered final-state showers,
61766C CTEQ6L1 parton distributions.
61767C...Key feature: uses CTEQ6L1 (external pdf library must be linked),
61768C...with a slightly lower pT0 (2.0 instead of 2.05) due to the smaller
61769C...UE activity obtained with CTEQ6L1 relative to CTEQ5L.
61770C
61771C=======================================================================
61772C TUNES OF NEW FRAMEWORK (PT-ORDERED ISR AND FSR, INTERLEAVED UE)
61773C=======================================================================
61774C
61775C S0 (300) and S0A (303). CTEQ5L parton distributions
61776C...Key feature: large amount of multiple interactions
61777C...* Somewhat faster than the other colour annealing scenarios.
61778C...* S0A has a faster energy scaling of the UE IR cutoff, borrowed
61779C... from Tune A, leading to less UE at the LHC, but more at RHIC.
61780C...* Small amount of radiation.
61781C...* Large amount of low-pT MI
61782C...* Low degree of proton lumpiness (broad matter dist.)
61783C...* CR Type S (driven by free triplets), of medium strength.
61784C...* See: Pythia6402 update notes or later.
61785C
61786C S1 (301). CTEQ5L parton distributions
61787C...Key feature: large amount of radiation.
61788C...* Large amount of low-pT perturbative ISR
61789C...* Large amount of FSR off ISR partons
61790C...* Small amount of low-pT multiple interactions
61791C...* Moderate degree of proton lumpiness
61792C...* Least aggressive CR type (S+S Type I), but with large strength
61793C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
61794C
61795C S2 (302). CTEQ5L parton distributions
61796C...Key feature: very lumpy proton + gg string cluster formation allowed
61797C...* Small amount of radiation
61798C...* Moderate amount of low-pT MI
61799C...* High degree of proton lumpiness (more spiky matter distribution)
61800C...* Most aggressive CR type (S+S Type II), but with small strength
61801C...* See: Sandhoff & Skands: FERMILAB-CONF-05-518-T, in hep-ph/0604120.
61802C
61803C NOCR (304). CTEQ5L parton distributions
61804C...Key feature: no colour reconnections (NB: "Best fit" only).
61805C...* NB: <pT>(Nch) problematic in this tune.
61806C...* Small amount of radiation
61807C...* Small amount of low-pT MI
61808C...* Low degree of proton lumpiness
61809C...* Large BR composite x enhancement factor
61810C...* Most clever colour flow without CR ("Lambda ordering")
61811C
61812C ATLAS-CSC (306). CTEQ6L parton distributions
61813C...Key feature: 11-parameter ATLAS tune of the new framework.
61814C...* Old (pre-annealing) colour reconnections a la 305.
61815C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
61816C
61817C S0-Pro, S1-Pro, etc (310, 311, etc). CTEQ5L parton distributions.
61818C...Key feature: the S0 family of tunes revamped with the Professor
61819C...pT-ordered final-state shower and fragmentation tunes presented by
61820C...Hendrik Hoeth at the Perugia MPI workshop in October 2008.
61821C...Key feature: improved descriptions of LEP data.
61822C
61823C ATLAS MC08 (316). CTEQ6L1 parton distributions
61824C...Key feature: ATLAS tune of the new framework using CTEQ6L1 PDFs
61825C...* Warning: uses Peterson fragmentation function for heavy quarks
61826C...* Uses CTEQ6 Leading Order PDFs (must be interfaced externally)
61827C
61828C Perugia-0 (320). CTEQ5L parton distributions.
61829C...Key feature: S0-Pro retuned to more Tevatron data. Better Drell-Yan
61830C...pT spectrum, better <pT>(Nch) in min-bias, and better scaling to
61831C...630 GeV than S0-Pro. Also has a slightly smoother mass profile, more
61832C...beam-remnant breakup (more baryon number transport), and suppression
61833C...of CR in high-pT string pieces.
61834C
61835C Perugia-HARD (321). CTEQ5L parton distributions.
61836C...Key feature: More ISR, More FSR, Less MPI, Less BR
61837C...Uses pT/2 as argument of alpha_s for ISR, and a higher Lambda_FSR.
61838C...Has higher pT0, less intrinsic kT, less beam remnant breakup (less
61839C...baryon number transport), and more fragmentation pT.
61840C...Multiplicity in min-bias is LOW, <pT>(Nch) is HIGH,
61841C...DY pT spectrum is HARD.
61842C
61843C Perugia-SOFT (322). CTEQ5L parton distributions.
61844C...Key feature: Less ISR, Less FSR, More MPI, More BR
61845C...Uses sqrt(2)*pT as argument of alpha_s for ISR, and a lower
61846C...Lambda_FSR. Has lower pT0, more beam remnant breakup (more baryon
61847C...number transport), and less fragmentation pT.
61848C...Multiplicity in min-bias is HIGH, <pT>(Nch) is LOW,
61849C...DY pT spectrum is SOFT
61850C
61851C Perugia-3 (323). CTEQ5L parton distributions.
61852C...Key feature: variant of Perugia-0 with more extreme energy scaling
61853C...properties while still agreeing with Tevatron data from 630 to 1960.
61854C...More ISR and less MPI than Perugia-0 at the Tevatron and above and
61855C...allows FSR off the active end of dipoles stretched to the remnant.
61856C
61857C Perugia-NOCR (324). CTEQ5L parton distributions.
61858C...Key feature: Retune of NOCR-Pro with better scaling properties to
61859C...lower energies and somewhat better agreement with Tevatron data
61860C...at 1800/1960.
61861C
61862C Perugia-* (325). MRST LO* parton distributions for generators
61863C...Key feature: first attempt at using the LO* distributions
61864C...(external pdf library must be linked).
61865C
61866C Perugia-6 (326). CTEQ6L1 parton distributions
61867C...Key feature: uses CTEQ6L1 (external pdf library must be linked).
61868C
61869C Perugia-2010 (327). CTEQ5L parton distributions
61870C...Key feature: Retune of Perugia 0 to attempt to better describe
61871C...strangeness yields at RHIC and at LEP. Also increased the amount
61872C...of FSR off ISR following the conclusions in arXiv:1001.4082.
61873C...Increased the amount of beam blowup, causing more baryon transport
61874C...into the detector, to further explore this possibility. Using
61875C...a new color-reconnection model that relies on determining a thrust
61876C...axis for the events and then computing reconnection probabilities for
61877C...the individual string pieces based on the actual string densities
61878C...per rapidity interval along that thrust direction.
61879C
61880C Perugia-K (328). CTEQ5L parton distributions
61881C...Key feature: uses a ``K'' factor on the MPI cross sections
61882C...This gives a larger rate of minijets and pushes the underlying-event
61883C...activity towards higher pT. To compensate for the increased activity
61884C...at higher pT, the infared regularization scale is larger for this tune.
61885C
61886C Pro-pTO (329). CTEQ5L parton distributions
61887C...Key feature: Complete retune of new model by Professor, including
61888C...large amounts of both LEP and Tevatron data. Similar to S0A-Pro.
61889C
61890C ATLAS MC09 (330). LO* parton distributions
61891C...Key feature: Good overall agreement with Tevatron and early LHC data.
61892C...Similar to Perugia *.
61893C
61894C ATLAS MC09c (331). LO* parton distributions
61895C...Key feature: Good overall agreement with Tevatron and 900-GeV LHC data.
61896C...Similar to Perugia *. Retuned CR model with respect to MC09.
61897C
61898C Pro-pT* (335) LO* parton distributions
61899C...Key feature: Retune of Pro-PTO with MRST LO* PDFs.
61900C
61901C Pro-pT6 (336). CTEQ6L1 parton distributions
61902C...Key feature: Retune of Pro-PTO with CTEQ6L1 PDFs.
61903C
61904C Pro-pT** (339). LO** parton distributions
61905C...Key feature: Retune of Pro-PTO with MRST LO** PDFs.
61906C
61907C AMBT1 (340). LO* parton distributions
61908C...Key feature: First ATLAS tune including 7-TeV LHC data.
61909C...Mainly retuned CR and mass distribution with respect to MC09c.
61910C...Note: cannot be run standalone since it uses external PDFs.
61911C
61912C CMSZ1 (341). CTEQ5L parton distributions
61913C...Key feature: First CMS tune including 7-TeV LHC data.
61914C...Uses many of the features of AMBT1, but uses CTEQ5L PDFs,
61915C...has a lower pT0 at the Tevatron, which scales faster with energy.
61916C
61917C Z1-LEP (342). CTEQ5L parton distributions
61918C...Key feature: CMS tune Z1 with improved LEP parameters, mostly
61919C...taken from the Professor/Perugia tunes, with a few minor updates.
61920C
61921C=======================================================================
61922C OTHER TUNES
61923C=======================================================================
61924C
61925C...The GAL and SCI models (400+) are special and *SHOULD NOT* be run
61926C...with an unmodified Pythia distribution.
61927C...See http://www.isv.uu.se/thep/MC/scigal/ for more information.
61928C
61929C ::: + Future improvements?
61930C Include also QCD K-factor a la M. Heinz / ATLAS TDR ? RDF's QK?
61931C (problem: K-factor affects everything so only works as
61932C intended for min-bias, not for UE ... probably need a
61933C better long-term solution to handle UE as well. Anyway,
61934C Mark uses MSTP(33) and PARP(31)-PARP(33).)
61935
61936C...Global statements
61937 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
61938 INTEGER PYK,PYCHGE,PYCOMP
61939
61940C...Commonblocks.
61941 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
61942 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
61943
61944C...SCI and GAL Commonblocks
61945 COMMON /SCIPAR/MSWI(2),PARSCI(2)
61946
61947C...SAVE statements
61948 SAVE /PYDAT1/,/PYPARS/
61949 SAVE /SCIPAR/
61950
61951C...Internal parameters
61952 PARAMETER(MXTUNS=500)
61953 CHARACTER*8 CHDOC
61954 PARAMETER (CHDOC='Mar 2011')
61955 CHARACTER*16 CHNAMS(0:MXTUNS), CHNAME
61956 CHARACTER*42 CHMSTJ(50), CHMSTP(100), CHPARP(100),
61957 & CHPARJ(100), CHMSTU(101:121), CHPARU(101:121), CH40
61958 CHARACTER*60 CH60
61959 CHARACTER*70 CH70
61960 DATA (CHNAMS(I),I=0,1)/'Default',' '/
61961 DATA (CHNAMS(I),I=100,119)/
61962 & 'Tune A','Tune AW','Tune BW','Tune DW','Tune DWT','Tune QW',
61963 & 'ATLAS DC2','Tune ACR','Tune D6','Tune D6T',
61964 1 'Tune A-Pro','Tune AW-Pro','Tune BW-Pro','Tune DW-Pro',
61965 1 'Tune DWT-Pro','Tune QW-Pro','ATLAS DC2-Pro','Tune ACR-Pro',
61966 1 'Tune D6-Pro','Tune D6T-Pro'/
61967 DATA (CHNAMS(I),I=120,129)/
61968 & 9*' ','Pro-Q2O'/
61969 DATA (CHNAMS(I),I=300,309)/
61970 & 'Tune S0','Tune S1','Tune S2','Tune S0A','NOCR','Old',
61971 5 'ATLAS-CSC Tune','Yale Tune','Yale-K Tune',' '/
61972 DATA (CHNAMS(I),I=310,316)/
61973 & 'Tune S0-Pro','Tune S1-Pro','Tune S2-Pro','Tune S0A-Pro',
61974 & 'NOCR-Pro','Old-Pro','ATLAS MC08'/
61975 DATA (CHNAMS(I),I=320,329)/
61976 & 'Perugia 0','Perugia HARD','Perugia SOFT',
61977 & 'Perugia 3','Perugia NOCR','Perugia LO*',
61978 & 'Perugia 6','Perugia 10','Perugia K','Pro-pTO'/
61979 DATA (CHNAMS(I),I=330,349)/
61980 & 'ATLAS MC09','ATLAS MC09c',2*' ','Perugia 10 NOCR','Pro-PT*',
61981 & 'Pro-PT6',' ',' ','Pro-PT**',
61982 4 'Tune AMBT1','Tune Z1','Tune Z1-LEP','Tune Z2','Tune Z2-LEP',
61983 4 5*' '/
61984 DATA (CHNAMS(I),I=350,359)/
61985 & 'Perugia 2011','P2011 radHi','P2011 radLo','P2011 mpiHi',
61986 & 'P2011 noCR','P2011 M(LO**)', 'P2011 CTEQ6L1',
61987 & 'P2011 T16','P2011 T32','P2011 Tevatron'/
61988 DATA (CHNAMS(I),I=360,369)/
61989 & 'S Global','S 7000','S 1960','S 1800',
61990 & 'S 900','S 630', 4*' '/
61991 DATA (CHNAMS(I),I=200,229)/
61992 & 'IM Tune 1','Tune APT',8*' ',
61993 & ' ','Tune APT-Pro',8*' ',
61994 & ' ','Perugia APT',4*' ','Perugia APT6',3*' '/
61995 DATA (CHNAMS(I),I=400,409)/
61996 & 'GAL Tune 0','SCI Tune 0','GAL Tune 1','SCI Tune 1',6*' '/
61997 DATA (CHMSTJ(I),I=11,20)/
61998 & 'HAD choice of fragmentation function(s)',4*' ',
61999 & 'HAD treatment of small-mass systems',4*' '/
62000 DATA (CHMSTJ(I),I=41,50)/
62001 & 'FSR type (Q2 or pT) for old framework',9*' '/
62002 DATA (CHMSTP(I),I=1,10)/
62003 & 2*' ','INT switch for choice of LambdaQCD',7*' '/
62004 DATA (CHMSTP(I),I=31,40)/
62005 & 2*' ','"K" switch for K-factor on/off & type',7*' '/
62006 DATA (CHMSTP(I),I=51,100)/
62007 5 'PDF set','PDF set internal (=1) or pdflib (=2)',8*' ',
62008 6 'ISR master switch',2*' ','ISR alphaS type',2*' ',
62009 6 'ISR coherence option for 1st emission',
62010 6 'ISR phase space choice & ME corrections',' ',
62011 7 'ISR IR regularization scheme',' ',
62012 7 'IFSR scheme for non-decay FSR',8*' ',
62013 8 'UE model',
62014 8 'UE hadron transverse mass distribution',5*' ',
62015 8 'BR composite scheme','BR color scheme',
62016 9 'BR primordial kT compensation',
62017 9 'BR primordial kT distribution',
62018 9 'BR energy partitioning scheme',2*' ',
62019 9 'FSI color (re-)connection model',5*' '/
62020 DATA (CHPARP(I),I=1,10)/
62021 & 'ME/UE LambdaQCD',9*' '/
62022 DATA (CHPARP(I),I=31,40)/
62023 & ' ','"K" K-factor',8*' '/
62024 DATA (CHPARP(I),I=61,100)/
62025 6 'ISR LambdaQCD','ISR IR cutoff',' ',
62026 6 'ISR renormalization scale prefactor',
62027 6 2*' ','ISR Q2max factor',3*' ',
62028 7 'IFSR Q2max factor in non-s-channel procs',
62029 7 'IFSR LambdaQCD (outside resonance decays)',4*' ',
62030 7 'FSI color reco high-pT damping strength',
62031 7 'FSI color reconnection strength',
62032 7 'BR composite x enhancement','BR breakup suppression',
62033 8 2*'UE IR cutoff at reference ecm',
62034 8 2*'UE mass distribution parameter',
62035 8 'UE gg color correlated fraction','UE total gg fraction',
62036 8 2*' ',
62037 8 'UE IR cutoff reference ecm',
62038 8 'UE IR cutoff ecm scaling power',
62039 9 'BR primordial kT width <|kT|>',' ',
62040 9 'BR primordial kT UV cutoff',7*' '/
62041 DATA (CHPARJ(I),I=1,30)/
62042 & 'HAD diquark suppression','HAD strangeness suppression',
62043 & 'HAD strange diquark suppression',
62044 & 'HAD vector diquark suppression','HAD P(popcorn)',
62045 & 'HAD extra popcorn B(s)-M-B(s) supp',
62046 & 'HAD extra popcorn B-M(s)-B supp',
62047 & 3*' ',
62048 1 'HAD P(vector meson), u and d only',
62049 1 'HAD P(vector meson), contains s',
62050 1 'HAD P(vector meson), heavy quarks',7*' ',
62051 2 'HAD fragmentation pT',' ',' ',' ',
62052 2 'HAD eta0 suppression',"HAD eta0' suppression",4*' '/
62053 DATA (CHPARJ(I),I=41,90)/
62054 4 'HAD string parameter a(Meson)','HAD string parameter b',
62055 4 2*' ','HAD string a(Baryon)-a(Meson)',
62056 4 'HAD Lund(=0)-Bowler(=1) rQ (rc)',
62057 4 'HAD Lund(=0)-Bowler(=1) rb',3*' ',
62058 5 3*' ', 'HAD charm parameter','HAD bottom parameter',5*' ',
62059 6 10*' ',10*' ',
62060 8 'FSR LambdaQCD (inside resonance decays)',
62061 & 'FSR IR cutoff',8*' '/
62062 DATA (CHMSTU(I),I=111,120)/
62063 1 ' ','INT n(flavors) for LambdaQCD',8*' '/
62064 DATA (CHPARU(I),I=111,120)/
62065 1 ' ','INT LambdaQCD',8*' '/
62066
62067C...1) Shorthand notation
62068 M13=MSTU(13)
62069 M11=MSTU(11)
62070 IF (ITUNE.LE.MXTUNS.AND.ITUNE.GE.0) THEN
62071 CHNAME=CHNAMS(ITUNE)
62072 IF (ITUNE.EQ.0) GOTO 9999
62073 ELSE
62074 CALL PYERRM(9,'(PYTUNE:) Tune number > max. Using defaults.')
62075 GOTO 9999
62076 ENDIF
62077
62078C...2) Hello World
62079 IF (M13.GE.1) WRITE(M11,5000) CHDOC
62080
62081C...Hardcode some defaults
62082C...Get Lambda from PDF
62083 MSTP(3) = 2
62084C...CTEQ5L1 PDFs
62085 MSTP(52) = 1
62086 MSTP(51) = 7
62087C... No K-factor
62088 MSTP(33) = 0
62089
62090C...3) Tune parameters
62091
62092C=======================================================================
62093C...ATLAS MC08
62094
62095 IF (ITUNE.EQ.316) THEN
62096
62097 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
62098 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62099 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62100 & ' with tune.')
62101 ENDIF
62102
62103C...First set some explicit defaults from 6.4.20
62104C...# Old defaults
62105 MSTJ(11) = 4
62106C...# Old default flavour parameters
62107 PARJ(1) = 0.1
62108 PARJ(2) = 0.3
62109 PARJ(3) = 0.40
62110 PARJ(4) = 0.05
62111 PARJ(11) = 0.5
62112 PARJ(12) = 0.6
62113 PARJ(21) = 0.36
62114 PARJ(41) = 0.30
62115 PARJ(42) = 0.58
62116 PARJ(46) = 1.0
62117 PARJ(82) = 1.0
62118
62119C...PDFs: CTEQ6L1 for 326
62120 MSTP(52)=2
62121 MSTP(51)=10042
62122
62123C...UE and ISR switches
62124 MSTP(81)=21
62125 MSTP(82)=4
62126 MSTP(70)=0
62127 MSTP(72)=1
62128
62129C...CR:
62130 MSTP(95)=2
62131 PARP(78)=0.3
62132 PARP(77)=0.0
62133 PARP(80)=0.1
62134
62135C...Primordial kT
62136 PARP(91)=2.0D0
62137 PARP(93)=5.0D0
62138
62139C...MPI:
62140 PARP(82)=2.1
62141 PARP(83)=0.8
62142 PARP(84)=0.7
62143 PARP(89)=1800.0
62144 PARP(90)=0.16
62145
62146C...FSR inside resonance decays
62147 PARJ(81)=0.29
62148
62149C...Fragmentation (warning: uses Peterson)
62150 MSTJ(11)=3
62151 PARJ(54)=-0.07
62152 PARJ(55)=-0.006
62153 MSTJ(22)=2
62154
62155 IF (M13.GE.1) THEN
62156 CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002'
62157 WRITE(M11,5030) CH60
62158 CH60='Physics model: '//
62159 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
62160 WRITE(M11,5030) CH60
62161 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
62162 WRITE(M11,5030) CH60
62163
62164C...Output
62165 WRITE(M11,5030) ' '
62166 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62167 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62168 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
62169 IF (MSTP(70).EQ.0) THEN
62170 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62171 ENDIF
62172 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
62173 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62174 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
62175 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62176 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62177 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62178 WRITE(M11,5030) CH60
62179 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
62180 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
62181 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62182 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62183 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62184 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
62185 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62186 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62187 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62188 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62189 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62190 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62191 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62192 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
62193 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
62194 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
62195 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
62196 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62197 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62198 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62199 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62200 IF (MSTP(95).GE.1) THEN
62201 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62202 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
62203 ENDIF
62204
62205 ENDIF
62206
62207C=======================================================================
62208C...ATLAS MC09, MC09c, AMBT1
62209C...CMS Z1 (R. Field), Z1-LEP
62210
62211 ELSEIF (ITUNE.EQ.330.OR.ITUNE.EQ.331.OR.ITUNE.EQ.340.OR.
62212 & ITUNE.GE.341.AND.ITUNE.LE.344) THEN
62213
62214 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
62215 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62216 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62217 & ' with tune.')
62218 ENDIF
62219
62220C...First set some explicit defaults from 6.4.20
62221 IF (ITUNE.LE.341.OR.ITUNE.EQ.343) THEN
62222C... # Old defaults
62223 MSTJ(11) = 4
62224C...# Old default flavour parameters
62225 PARJ(1) = 0.1
62226 PARJ(2) = 0.3
62227 PARJ(3) = 0.40
62228 PARJ(4) = 0.05
62229 PARJ(11) = 0.5
62230 PARJ(12) = 0.6
62231 PARJ(21) = 0.36
62232 PARJ(41) = 0.30
62233 PARJ(42) = 0.58
62234 PARJ(46) = 1.0
62235 PARJ(82) = 1.0
62236 ELSE
62237C...# For Zn-LEP tunes, use tuned flavour parameters from Professor/Perugia
62238 PARJ( 1) = 0.08D0
62239 PARJ( 2) = 0.21D0
62240 PARJ(3) = 0.94
62241 PARJ( 4) = 0.04D0
62242 PARJ(11) = 0.35D0
62243 PARJ(12) = 0.35D0
62244 PARJ(13) = 0.54
62245 PARJ(25) = 0.63
62246 PARJ(26) = 0.12
62247C...# Switch on Bowler:
62248 MSTJ(11) = 5
62249C...# Fragmentation
62250 PARJ(21) = 0.34D0
62251 PARJ(41) = 0.35D0
62252 PARJ(42) = 0.80D0
62253 PARJ(47) = 1.0
62254 PARJ(81) = 0.26D0
62255 PARJ(82) = 1.0D0
62256 ENDIF
62257
62258C...PDFs: MRST LO*
62259 MSTP(52)=2
62260 MSTP(51)=20650
62261 IF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN
62262C...Z1 uses CTEQ5L
62263 MSTP(52)=1
62264 MSTP(51)=7
62265 ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN
62266C...Z2 uses CTEQ6L
62267 MSTP(52)=2
62268 MSTP(51)=10042
62269 ENDIF
62270
62271C...UE and ISR switches
62272 MSTP(81)=21
62273 MSTP(82)=4
62274 MSTP(70)=0
62275 MSTP(72)=1
62276
62277C...CR:
62278 MSTP(95)=6
62279 PARP(78)=0.3
62280 PARP(77)=0.0
62281 PARP(80)=0.1
62282 IF (ITUNE.EQ.331) THEN
62283 PARP(78)=0.224
62284 ELSEIF (ITUNE.EQ.340) THEN
62285C...AMBT1
62286 PARP(77)=1.016D0
62287 PARP(78)=0.538D0
62288 ELSEIF (ITUNE.GE.341.AND.ITUNE.LE.344) THEN
62289C...Z1 and Z2 use the AMBT1 CR values
62290 PARP(77)=1.016D0
62291 PARP(78)=0.538D0
62292 ENDIF
62293
62294C...MPI:
62295 PARP(82)=2.3
62296 PARP(83)=0.8
62297 PARP(84)=0.7
62298 PARP(89)=1800.0
62299 PARP(90)=0.25
62300 IF (ITUNE.EQ.331) THEN
62301 PARP(82)=2.315
62302 PARP(90)=0.2487
62303 ELSEIF (ITUNE.EQ.340) THEN
62304 PARP(82)=2.292D0
62305 PARP(83)=0.356D0
62306 PARP(84)=0.651
62307 PARP(90)=0.25D0
62308 ELSEIF (ITUNE.EQ.341.OR.ITUNE.EQ.342) THEN
62309 PARP(82)=1.932D0
62310 PARP(83)=0.356D0
62311 PARP(84)=0.651
62312 PARP(90)=0.275D0
62313 ELSEIF (ITUNE.EQ.343.OR.ITUNE.EQ.344) THEN
62314 PARP(82)=1.832D0
62315 PARP(83)=0.356D0
62316 PARP(84)=0.651
62317 PARP(90)=0.275D0
62318 ENDIF
62319
62320C...Primordial kT
62321 PARP(91)=2.0D0
62322 PARP(93)=5D0
62323 IF (ITUNE.GE.340) THEN
62324 PARP(93)=10D0
62325 ENDIF
62326
62327C...ISR
62328 IF (ITUNE.GE.340) THEN
62329 PARP(62)=1.025
62330 ENDIF
62331
62332C...FSR inside resonance decays
62333 PARJ(81)=0.29
62334
62335C...Fragmentation (org 6.4 defs hardcoded)
62336 MSTJ(11)=4
62337 PARJ(41)=0.3
62338 PARJ(42)=0.58
62339 MSTJ(22)=2
62340C...AMBT1 mentions 46 explicitly, but Z1 doesn't ...
62341 PARJ(46)=0.75
62342 IF (ITUNE.GE.341.AND.ITUNE.LE.344) THEN
62343C...Reset PARJ(46) to org def value for Z1 and Z2
62344 PARJ(46)=1.0
62345 ENDIF
62346
62347 IF (M13.GE.1) THEN
62348 IF (ITUNE.LT.340) THEN
62349 CH60='Tuned by ATLAS, ATL-PHYS-PUB-2010-002'
62350 ELSEIF (ITUNE.EQ.340) THEN
62351 CH60='Tuned by ATLAS, ATLAS-CONF-2010-031'
62352 ELSEIF (ITUNE.EQ.341) THEN
62353 CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62354 WRITE(M11,5030) CH60
62355 CH60='Z1 variation tuned by R. D. Field (CMS)'
62356 ELSEIF (ITUNE.EQ.342) THEN
62357 CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62358 WRITE(M11,5030) CH60
62359 CH60='Z1 variation retuned by R. D. Field (CMS)'
62360 WRITE(M11,5030) CH60
62361 CH60='Z1-LEP variation retuned by Professor / P. Skands'
62362 ELSEIF (ITUNE.EQ.343) THEN
62363 CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62364 WRITE(M11,5030) CH60
62365 CH60='Z2 variation retuned by R. D. Field (CMS)'
62366 ELSEIF (ITUNE.EQ.344) THEN
62367 CH60='AMBT1 Tuned by ATLAS, ATLAS-CONF-2010-031'
62368 WRITE(M11,5030) CH60
62369 CH60='Z2 variation retuned by R. D. Field (CMS)'
62370 WRITE(M11,5030) CH60
62371 CH60='Z2-LEP variation retuned by Professor / P. Skands'
62372 ENDIF
62373 WRITE(M11,5030) CH60
62374 CH60='Physics Model: '//
62375 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
62376 WRITE(M11,5030) CH60
62377 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
62378 WRITE(M11,5030) CH60
62379
62380C...Output
62381 WRITE(M11,5030) ' '
62382 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
62383 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
62384 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
62385 IF (MSTP(70).EQ.0) THEN
62386 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
62387 ENDIF
62388 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
62389 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
62390 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
62391 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
62392 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
62393 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
62394 WRITE(M11,5030) CH60
62395 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
62396 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
62397 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
62398 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
62399 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
62400 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
62401 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
62402 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
62403 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
62404 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
62405 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
62406 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
62407 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
62408 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
62409 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
62410 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
62411 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
62412 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
62413 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
62414 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
62415 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
62416 IF (MSTP(95).GE.1) THEN
62417 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
62418 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
62419 ENDIF
62420
62421 ENDIF
62422
62423C=======================================================================
62424C...S0, S1, S2, S0A, NOCR, Rap,
62425C...S0-Pro, S1-Pro, S2-Pro, S0A-Pro, NOCR-Pro, Rap-Pro
62426C...Perugia 0, HARD, SOFT, 3, LO*, 6, 2010, K
62427C...Pro-pTO, Pro-PT*, Pro-PT6, Pro-PT**
62428C...Perugia 2011 (incl variations)
62429C...Schulz-Skands tunes
62430 ELSEIF ((ITUNE.GE.300.AND.ITUNE.LE.305)
62431 & .OR.(ITUNE.GE.310.AND.ITUNE.LE.315)
62432 & .OR.(ITUNE.GE.320.AND.ITUNE.LE.329)
62433 & .OR.(ITUNE.GE.334.AND.ITUNE.LE.336).OR.ITUNE.EQ.339
62434 & .OR.(ITUNE.GE.350.AND.ITUNE.LE.365)) THEN
62435 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
62436 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
62437 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62438 & ' with tune.')
62439 ELSEIF(ITUNE.GE.320.AND.ITUNE.LE.339.AND.ITUNE.NE.324.AND.
62440 & ITUNE.NE.334.AND.
62441 & (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.419)))
62442 & THEN
62443 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62444 & ' with tune.')
62445 ELSEIF((ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.GE.350).AND.
62446 & (MSTP(181).LE.5.OR.
62447 & (MSTP(181).EQ.6.AND.MSTP(182).LE.422)))
62448 & THEN
62449 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
62450 & ' with tune.')
62451 ENDIF
62452
62453C...Use 327 as base tune for 350-359 (Perugia 2011)
62454 ITUNSV = ITUNE
62455 IF (ITUNE.GE.350.AND.ITUNE.LE.359) ITUNE = 327
62456C...Use 320 as base tune for 360+ (Schulz-Skands)
62457 IF (ITUNE.GE.360) ITUNE = 320
62458
62459C...HAD: Use Professor's LEP pars if ITUNE >= 310
62460C...(i.e., for S0-Pro, S1-Pro etc, and for Perugia tunes)
62461 IF (ITUNE.LT.310) THEN
62462C...# Old defaults
62463 MSTJ(11) = 4
62464C...# Old default flavour parameters
62465 PARJ(1) = 0.1
62466 PARJ(2) = 0.3
62467 PARJ(3) = 0.40
62468 PARJ(4) = 0.05
62469 PARJ(11) = 0.5
62470 PARJ(12) = 0.6
62471 PARJ(21) = 0.36
62472 PARJ(41) = 0.30
62473 PARJ(42) = 0.58
62474 PARJ(46) = 1.0
62475 PARJ(82) = 1.0
62476
62477 ELSEIF (ITUNE.GE.310) THEN
62478C...# Tuned flavour parameters:
62479 PARJ(1) = 0.073
62480 PARJ(2) = 0.2
62481 PARJ(3) = 0.94
62482 PARJ(4) = 0.032
62483 PARJ(11) = 0.31
62484 PARJ(12) = 0.4
62485 PARJ(13) = 0.54
62486 PARJ(25) = 0.63
62487 PARJ(26) = 0.12
62488C...# Always use pT-ordered shower:
62489 MSTJ(41) = 12
62490C...# Switch on Bowler:
62491 MSTJ(11) = 5
62492C...# Fragmentation
62493 PARJ(21) = 0.313
62494 PARJ(41) = 0.49
62495 PARJ(42) = 1.2
62496 PARJ(47) = 1.0
62497 PARJ(81) = 0.257
62498 PARJ(82) = 0.8
62499
62500C...HAD: fragmentation pT (only if not using professor) - HARD and SOFT
62501 IF (ITUNE.EQ.321) PARJ(21)=0.34D0
62502 IF (ITUNE.EQ.322) PARJ(21)=0.28D0
62503
62504C...HAD: P-2010 and P-K use different strangeness parameters
62505C... indicated by LEP and RHIC yields.
62506C...(only 5% different from Professor values, so should be within acceptable
62507C...theoretical uncertainty range)
62508C...(No attempt made to retune other flavor parameters post facto)
62509 IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
62510 PARJ( 1) = 0.08D0
62511 PARJ( 2) = 0.21D0
62512 PARJ( 4) = 0.04D0
62513 PARJ(11) = 0.35D0
62514 PARJ(12) = 0.35D0
62515 PARJ(21) = 0.36D0
62516 PARJ(41) = 0.35D0
62517 PARJ(42) = 0.90D0
62518 PARJ(81) = 0.26D0
62519 PARJ(82) = 1.0D0
62520 ENDIF
62521 ENDIF
62522
62523C...Remove middle digit now for Professor variants, since identical pars
62524 ITUNEB=ITUNE
62525 IF (ITUNE.GE.310.AND.ITUNE.LE.319) THEN
62526 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
62527 ENDIF
62528
62529C...PDFs: all use CTEQ5L as starting point
62530 MSTP(52)=1
62531 MSTP(51)=7
62532 IF (ITUNE.EQ.325.OR.ITUNE.EQ.335) THEN
62533C...MRST LO* for 325 and 335
62534 MSTP(52)=2
62535 MSTP(51)=20650
62536 ELSEIF (ITUNE.EQ.326.OR.ITUNE.EQ.336) THEN
62537C...CTEQ6L1 for 326 and 336
62538 MSTP(52)=2
62539 MSTP(51)=10042
62540 ELSEIF (ITUNE.EQ.339) THEN
62541C...MRST LO** for 339
62542 MSTP(52)=2
62543 MSTP(51)=20651
62544 ENDIF
62545
62546C...LambdaQCD choice: 327 and 328 use hardcoded, others get from PDF
62547 MSTP(3)=2
62548 IF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
62549 MSTP(3) = 1
62550C...Hardcode CTEQ5L values for ME and ISR
62551 MSTU(112) = 4
62552 PARU(112) = 0.192D0
62553 PARP(61) = 0.192D0
62554 PARP( 1) = 0.192D0
62555C...but use LEP value also for non-res FSR
62556 PARP(72) = 0.260D0
62557 ENDIF
62558
62559C...ISR: use Lambda_MSbar with default scale for S0(A)
62560 MSTP(64)=2
62561 PARP(64)=1D0
62562 IF (ITUNE.EQ.320.OR.ITUNE.EQ.323.OR.ITUNE.EQ.324.OR.ITUNE.EQ.334
62563 & .OR.ITUNE.EQ.326.OR.ITUNE.EQ.327.OR.ITUNE.EQ.328) THEN
62564C...Use Lambda_MC with muR^2=pT^2 for most central Perugia tunes
62565 MSTP(64)=3
62566 PARP(64)=1D0
62567 ELSEIF (ITUNE.EQ.321) THEN
62568C...Use Lambda_MC with muR^2=(1/2pT)^2 for Perugia HARD
62569 MSTP(64)=3
62570 PARP(64)=0.25D0
62571 ELSEIF (ITUNE.EQ.322) THEN
62572C...Use Lambda_MSbar with muR^2=2pT^2 for Perugia SOFT
62573 MSTP(64)=2
62574 PARP(64)=2D0
62575 ELSEIF (ITUNE.EQ.325) THEN
62576C...Use Lambda_MC with muR^2=2pT^2 for Perugia LO*
62577 MSTP(64)=3
62578 PARP(64)=2D0
62579 ELSEIF (ITUNE.EQ.329.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR.
62580 & ITUNE.EQ.339) THEN
62581C...Use Lambda_MSbar with P64=1.3 for Pro-pT0
62582 MSTP(64)=2
62583 PARP(64)=1.3D0
62584 IF (ITUNE.EQ.335) PARP(64)=0.92D0
62585 IF (ITUNE.EQ.336) PARP(64)=0.89D0
62586 IF (ITUNE.EQ.339) PARP(64)=0.97D0
62587 ENDIF
62588
62589C...ISR : power-suppressed power showers above s_color (since 6.4.19)
62590 MSTP(67)=2
62591 PARP(67)=4D0
62592C...Perugia tunes have stronger suppression, except HARD
62593 IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62594 PARP(67)=1D0
62595 IF (ITUNE.EQ.321) PARP(67)=4D0
62596 IF (ITUNE.EQ.322) PARP(67)=0.25D0
62597 ENDIF
62598
62599C...ISR IR cutoff type and FSR off ISR setting:
62600C...Smooth ISR, low FSR-off-ISR
62601 MSTP(70)=2
62602 MSTP(72)=0
62603 IF (ITUNEB.EQ.301) THEN
62604C...S1, S1-Pro: sharp ISR, high FSR
62605 MSTP(70)=0
62606 MSTP(72)=1
62607 ELSEIF (ITUNE.EQ.320.OR.ITUNE.EQ.324.OR.ITUNE.EQ.326
62608 & .OR.ITUNE.EQ.325) THEN
62609C...Perugia default is smooth ISR, high FSR-off-ISR
62610 MSTP(70)=2
62611 MSTP(72)=1
62612 ELSEIF (ITUNE.EQ.321) THEN
62613C...Perugia HARD: sharp ISR, high FSR-off-ISR (but no dip-to-BR rad)
62614 MSTP(70)=0
62615 PARP(62)=1.25D0
62616 MSTP(72)=1
62617 ELSEIF (ITUNE.EQ.322) THEN
62618C...Perugia SOFT: scaling sharp ISR, low FSR-off-ISR
62619 MSTP(70)=1
62620 PARP(81)=1.5D0
62621 MSTP(72)=0
62622 ELSEIF (ITUNE.EQ.323) THEN
62623C...Perugia 3: sharp ISR, high FSR-off-ISR (with dipole-to-BR radiating)
62624 MSTP(70)=0
62625 PARP(62)=1.25D0
62626 MSTP(72)=2
62627 ELSEIF (ITUNE.EQ.327.OR.ITUNE.EQ.328.OR.ITUNE.EQ.334) THEN
62628C...Perugia 2010/K: smooth ISR, high FSR-off-ISR (with dipole-to-BR radiating)
62629 MSTP(70)=2
62630 MSTP(72)=2
62631 ENDIF
62632
62633C...FSR activity: Perugia tunes use a lower PARP(71) as indicated
62634C...by Professor tunes (with HARD and SOFT variations)
62635 PARP(71)=4D0
62636 IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62637 PARP(71)=2D0
62638 IF (ITUNE.EQ.321) PARP(71)=4D0
62639 IF (ITUNE.EQ.322) PARP(71)=1D0
62640 ENDIF
62641 IF (ITUNE.EQ.329) PARP(71)=2D0
62642 IF (ITUNE.EQ.335) PARP(71)=1.29D0
62643 IF (ITUNE.EQ.336) PARP(71)=1.72D0
62644 IF (ITUNE.EQ.339) PARP(71)=1.20D0
62645
62646C...FSR: Lambda_FSR scale (only if not using professor)
62647 IF (ITUNE.LT.310) PARJ(81)=0.23D0
62648 IF (ITUNE.EQ.321) PARJ(81)=0.30D0
62649 IF (ITUNE.EQ.322) PARJ(81)=0.20D0
62650
62651C...K-factor : only 328 uses a K-factor on the UE cross sections
62652 MSTP(33)=0
62653 IF (ITUNE.EQ.328) THEN
62654 MSTP(33)=10
62655 PARP(32)=1.5
62656 ENDIF
62657C...UE on, new model
62658 MSTP(81)=21
62659
62660C...UE: hadron-hadron overlap profile (expOfPow for all)
62661 MSTP(82)=5
62662C...UE: Overlap smoothness (1.0 = exponential; 2.0 = gaussian)
62663 PARP(83)=1.6D0
62664 IF (ITUNEB.EQ.301) PARP(83)=1.4D0
62665 IF (ITUNEB.EQ.302) PARP(83)=1.2D0
62666C...NOCR variants have very smooth distributions
62667 IF (ITUNEB.EQ.304) PARP(83)=1.8D0
62668 IF (ITUNEB.EQ.305) PARP(83)=2.0D0
62669 IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62670C...Perugia variants have slightly smoother profiles by default
62671C...(to compensate for more tail by added radiation)
62672C...Perugia-SOFT has more peaked distribution, NOCR less peaked
62673 PARP(83)=1.7D0
62674 IF (ITUNE.EQ.322) PARP(83)=1.5D0
62675 IF (ITUNE.EQ.327) PARP(83)=1.5D0
62676 IF (ITUNE.EQ.328) PARP(83)=1.5D0
62677C...NOCR variants have smoother mass profiles
62678 IF (ITUNE.EQ.324) PARP(83)=1.8D0
62679 IF (ITUNE.EQ.334) PARP(83)=1.8D0
62680 ENDIF
62681C...Professor-pT0 also has very smooth distribution
62682 IF (ITUNE.EQ.329) PARP(83)=1.8
62683 IF (ITUNE.EQ.335) PARP(83)=1.68
62684 IF (ITUNE.EQ.336) PARP(83)=1.72
62685 IF (ITUNE.EQ.339) PARP(83)=1.67
62686
62687C...UE: pT0 = 1.85 for S0, S0A, 2.0 for Perugia version
62688 PARP(82)=1.85D0
62689 IF (ITUNEB.EQ.301) PARP(82)=2.1D0
62690 IF (ITUNEB.EQ.302) PARP(82)=1.9D0
62691 IF (ITUNEB.EQ.304) PARP(82)=2.05D0
62692 IF (ITUNEB.EQ.305) PARP(82)=1.9D0
62693 IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62694C...Perugia tunes (def is 2.0 GeV, HARD has higher, SOFT has lower,
62695C...Perugia-3 has more ISR, so higher pT0, NOCR can be slightly lower,
62696C...CTEQ6L1 slightly lower, due to less activity, and LO* needs to be
62697C...slightly higher, due to increased activity.
62698 PARP(82)=2.0D0
62699 IF (ITUNE.EQ.321) PARP(82)=2.3D0
62700 IF (ITUNE.EQ.322) PARP(82)=1.9D0
62701 IF (ITUNE.EQ.323) PARP(82)=2.2D0
62702 IF (ITUNE.EQ.324) PARP(82)=1.95D0
62703 IF (ITUNE.EQ.325) PARP(82)=2.2D0
62704 IF (ITUNE.EQ.326) PARP(82)=1.95D0
62705 IF (ITUNE.EQ.327) PARP(82)=2.05D0
62706 IF (ITUNE.EQ.328) PARP(82)=2.45D0
62707 IF (ITUNE.EQ.334) PARP(82)=2.15D0
62708 ENDIF
62709C...Professor-pT0 maintains low pT0 vaue
62710 IF (ITUNE.EQ.329) PARP(82)=1.85D0
62711 IF (ITUNE.EQ.335) PARP(82)=2.10D0
62712 IF (ITUNE.EQ.336) PARP(82)=1.83D0
62713 IF (ITUNE.EQ.339) PARP(82)=2.28D0
62714
62715C...UE: IR cutoff reference energy and default energy scaling pace
62716 PARP(89)=1800D0
62717 PARP(90)=0.16D0
62718C...S0A, S0A-Pro have tune A energy scaling
62719 IF (ITUNEB.EQ.303) PARP(90)=0.25D0
62720 IF ((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
62721C...Perugia tunes explicitly include MB at 630 to fix energy scaling
62722 PARP(90)=0.26
62723 IF (ITUNE.EQ.321) PARP(90)=0.30D0
62724 IF (ITUNE.EQ.322) PARP(90)=0.24D0
62725 IF (ITUNE.EQ.323) PARP(90)=0.32D0
62726 IF (ITUNE.EQ.324) PARP(90)=0.24D0
62727C...LO* and CTEQ6L1 tunes have slower energy scaling
62728 IF (ITUNE.EQ.325) PARP(90)=0.23D0
62729 IF (ITUNE.EQ.326) PARP(90)=0.22D0
62730 ENDIF
62731C...Professor-pT0 has intermediate scaling
62732 IF (ITUNE.EQ.329) PARP(90)=0.22D0
62733 IF (ITUNE.EQ.335) PARP(90)=0.20D0
62734 IF (ITUNE.EQ.336) PARP(90)=0.20D0
62735 IF (ITUNE.EQ.339) PARP(90)=0.21D0
62736
62737C...BR: MPI initiator color connections rap-ordered by default
62738C...NOCR variants are Lambda-ordered, Perugia SOFT & 2010 random-ordered
62739 MSTP(89)=1
62740 IF (ITUNEB.EQ.304.OR.ITUNE.EQ.324) MSTP(89)=2
62741 IF (ITUNE.EQ.322) MSTP(89)=0
62742 IF (ITUNE.EQ.327) MSTP(89)=0
62743 IF (ITUNE.EQ.328) MSTP(89)=0
62744
62745C...BR: BR-g-BR suppression factor (higher values -> more beam blowup)
62746 PARP(80)=0.01D0
62747 IF (ITUNE.GE.320.AND.ITUNE.LE.328) THEN
62748C...Perugia tunes have more beam blowup by default
62749 PARP(80)=0.05D0
62750 IF (ITUNE.EQ.321) PARP(80)=0.01
62751 IF (ITUNE.EQ.323) PARP(80)=0.03
62752 IF (ITUNE.EQ.324) PARP(80)=0.01
62753 IF (ITUNE.EQ.327) PARP(80)=0.1
62754 IF (ITUNE.EQ.328) PARP(80)=0.1
62755 ENDIF
62756
62757C...BR: diquarks (def = valence qq and moderate diquark x enhancement)
62758 MSTP(88)=0
62759 PARP(79)=2D0
62760 IF (ITUNEB.EQ.304) PARP(79)=3D0
62761 IF (ITUNE.EQ.329) PARP(79)=1.18
62762 IF (ITUNE.EQ.335) PARP(79)=1.11
62763 IF (ITUNE.EQ.336) PARP(79)=1.10
62764 IF (ITUNE.EQ.339) PARP(79)=3.69
62765
62766C...BR: Primordial kT, parametrization and cutoff, default is 2 GeV
62767 MSTP(91)=1
62768 PARP(91)=2D0
62769 PARP(93)=10D0
62770C...Perugia-HARD only uses 1.0 GeV
62771 IF (ITUNE.EQ.321) PARP(91)=1.0D0
62772C...Perugia-3 only uses 1.5 GeV
62773 IF (ITUNE.EQ.323) PARP(91)=1.5D0
62774C...Professor-pT0 uses 7-GeV cutoff
62775 IF (ITUNE.EQ.329) PARP(93)=7.0
62776 IF (ITUNE.EQ.335) THEN
62777 PARP(91)=2.15
62778 PARP(93)=6.79
62779 ELSEIF (ITUNE.EQ.336) THEN
62780 PARP(91)=1.85
62781 PARP(93)=6.86
62782 ELSEIF (ITUNE.EQ.339) THEN
62783 PARP(91)=2.11
62784 PARP(93)=5.08
62785 ENDIF
62786
62787C...FSI: Colour Reconnections - Seattle algorithm is default (S0)
62788 MSTP(95)=6
62789C...S1, S1-Pro: use S1
62790 IF (ITUNEB.EQ.301) MSTP(95)=2
62791C...S2, S2-Pro: use S2
62792 IF (ITUNEB.EQ.302) MSTP(95)=4
62793C...NOCR, NOCR-Pro, Perugia-NOCR: use no CR
62794 IF (ITUNE.EQ.304.OR.ITUNE.EQ.314.OR.ITUNE.EQ.324.OR.
62795 & ITUNE.EQ.334) MSTP(95)=0
62796C..."Old" and "Old"-Pro: use old CR
62797 IF (ITUNEB.EQ.305) MSTP(95)=1
62798C...Perugia 2010 and K use Paquis model
62799 IF (ITUNE.EQ.327.OR.ITUNE.EQ.328) MSTP(95)=8
62800
62801C...FSI: CR strength and high-pT dampening, default is S0
62802 PARP(77)=0D0
62803 IF (ITUNE.LT.320.OR.ITUNE.EQ.329.OR.ITUNE.GE.335) THEN
62804 PARP(78)=0.2D0
62805 IF (ITUNEB.EQ.301) PARP(78)=0.35D0
62806 IF (ITUNEB.EQ.302) PARP(78)=0.15D0
62807 IF (ITUNEB.EQ.304) PARP(78)=0.0D0
62808 IF (ITUNEB.EQ.305) PARP(78)=1.0D0
62809 IF (ITUNE.EQ.329) PARP(78)=0.17D0
62810 IF (ITUNE.EQ.335) PARP(78)=0.14D0
62811 IF (ITUNE.EQ.336) PARP(78)=0.17D0
62812 IF (ITUNE.EQ.339) PARP(78)=0.13D0
62813 ELSE
62814C...Perugia tunes also use high-pT dampening : default is Perugia 0,*,6
62815 PARP(78)=0.33
62816 PARP(77)=0.9D0
62817 IF (ITUNE.EQ.321) THEN
62818C...HARD has HIGH amount of CR
62819 PARP(78)=0.37D0
62820 PARP(77)=0.4D0
62821 ELSEIF (ITUNE.EQ.322) THEN
62822C...SOFT has LOW amount of CR
62823 PARP(78)=0.15D0
62824 PARP(77)=0.5D0
62825 ELSEIF (ITUNE.EQ.323) THEN
62826C...Scaling variant appears to need slightly more than default
62827 PARP(78)=0.35D0
62828 PARP(77)=0.6D0
62829 ELSEIF (ITUNE.EQ.324.OR.ITUNE.EQ.334) THEN
62830C...NOCR has no CR
62831 PARP(78)=0D0
62832 PARP(77)=0D0
62833 ELSEIF (ITUNE.EQ.327) THEN
62834C...2010
62835 PARP(78)=0.035D0
62836 PARP(77)=1D0
62837 ELSEIF (ITUNE.EQ.328) THEN
62838C...K
62839 PARP(78)=0.033D0
62840 PARP(77)=1D0
62841 ENDIF
62842 ENDIF
62843
62844C================
62845C...Perugia 2011 tunes
62846C...(written as modifications on top of Perugia 2010)
62847C================
62848 IF (ITUNSV.GE.350.AND.ITUNSV.LE.359) THEN
62849 ITUNE = ITUNSV
62850C... Scale setting for matching applications.
62851C... Switch to 5-flavor CMW LambdaQCD = 0.26 for all shower activity
62852C... (equivalent to a 5-flavor MSbar LambdaQCD = 0.26/1.6 = 0.16)
62853 MSTP(64)=2
62854 MSTU(112)=5
62855C... This sets the Lambda scale for ISR, IFSR, and FSR
62856 PARP(61)=0.26D0
62857 PARP(72)=0.26D0
62858 PARJ(81)=0.26D0
62859C... This sets the Lambda scale for QCD hard interactions (important for the
62860C... UE dijet cross sections. Here we still use an MSbar value, rather than
62861C... a CMW one, in order not to hugely increase the UE jettiness. The CTEQ5L
62862C... value corresponds to a Lambda5 of 0.146 for comparison, so quite close.)
62863 PARP(1)=0.16D0
62864 PARU(112)=0.16D0
62865C... For matching applications, PARP(71) and PARP(67) = 1
62866 PARP(67) = 1D0
62867 PARP(71) = 1D0
62868C... Primordial kT: only use 1 GeV
62869 MSTP(91)=1
62870 PARP(91)=1D0
62871C... ADDITIONAL LESSONS WRT PERUGIA 2010
62872C... ALICE taught us: need less baryon transport than SOFT
62873 MSTP(89)=0
62874 PARP(80)=0.015
62875C... Small adjustments at LEP (slightly softer frag functions, esp for baryons)
62876 PARJ(21)=0.33
62877 PARJ(41)=0.35
62878 PARJ(42)=0.8
62879 PARJ(45)=0.55
62880C... Increase Lambda/K ratio and other strange baryon yields
62881 PARJ(1)=0.087D0
62882 PARJ(3)=0.95D0
62883 PARJ(4)=0.043D0
62884 PARJ(6)=1.0D0
62885 PARJ(7)=1.0D0
62886C... Also reduce total strangeness yield a bit, with higher K*/K
62887 PARJ(2)=0.19D0
62888 PARJ(12)=0.40D0
62889C... Perugia 2011 default is sharp ISR, dipoles to BR radiating, pTmax individual
62890 MSTP(70)=0
62891 MSTP(72)=2
62892 PARP(62)=1.5D0
62893C... Holger taught us a smoother proton is preferred at high energies
62894C... Just use a simple Gaussian
62895 MSTP(82)=3
62896C... Scaling of pt0 cutoff
62897 PARP(90)=0.265
62898C... Now retune pT0 to give right UE activity.
62899C... Low CR strength indicated by LHC tunes
62900C... (also keep low to get <pT>(Nch) a bit down for pT>100MeV samples)
62901 PARP(78)=0.036D0
62902C... Choose 7 TeV as new reference scale
62903 PARP(89)=7000.0D0
62904 PARP(82)=2.93D0
62905C================
62906C... P2011 Variations
62907C================
62908 IF (ITUNE.EQ.351) THEN
62909C... radHi: high Lambda scale for ISR, IFSR, and FSR
62910C... ( ca 10% more particles at LEP after retune )
62911 PARP(61)=0.52D0
62912 PARP(72)=0.52D0
62913 PARJ(81)=0.52D0
62914C... Retune cutoff scales to compensate partially
62915C... (though higher cutoff causes faster multiplicity drop at low energies)
62916 PARP(62)=1.75D0
62917 PARJ(82)=1.75D0
62918 PARP(82)=3.00D0
62919C... Needs faster cutoff scaling than nominal variant for same <Nch> scaling
62920C... (since more radiation otherwise generates faster mult growth)
62921 PARP(90)=0.28
62922 ELSEIF (ITUNE.EQ.352) THEN
62923C... radLo: low Lambda scale for ISR, IFSR, and FSR
62924C... ( ca 10% less particles at LEP after retune )
62925 PARP(61)=0.13D0
62926 PARP(72)=0.13D0
62927 PARJ(81)=0.13D0
62928C... Retune cutoff scales to compensate partially
62929 PARP(62)=1.00D0
62930 PARJ(82)=0.75D0
62931 PARP(82)=2.95D0
62932C... Needs slower cutoff scaling than nominal variant for same <Nch> scaling
62933C... (since less radiation otherwise generates slower mult growth)
62934 PARP(90)=0.24
62935 ELSEIF (ITUNE.EQ.353) THEN
62936C... mpiHi: high Lambda scale for MPI
62937 PARP(1)=0.26D0
62938 PARU(112)=0.26D0
62939 PARP(82)=3.35D0
62940 PARP(90)=0.26D0
62941 ELSEIF (ITUNE.EQ.354) THEN
62942 MSTP(95)=0
62943 PARP(82)=3.05D0
62944 ELSEIF (ITUNE.EQ.355) THEN
62945C... LO**
62946 MSTP(52)=2
62947 MSTP(51)=20651
62948 PARP(62)=1.5D0
62949C... Compensate for higher <pT> with less CR
62950 PARP(78)=0.034
62951 PARP(82)=3.40D0
62952C... Need slower energy scaling than CTEQ5L
62953 PARP(90)=0.23D0
62954 ELSEIF (ITUNE.EQ.356) THEN
62955C... CTEQ6L1
62956 MSTP(52)=2
62957 MSTP(51)=10042
62958 PARP(82)=2.65D0
62959C... Need slower cutoff scaling than CTEQ5L
62960 PARP(90)=0.22D0
62961 ELSEIF (ITUNE.EQ.357) THEN
62962C... T16
62963 PARP(90)=0.16
62964 ELSEIF (ITUNE.EQ.358) THEN
62965C... T32
62966 PARP(90)=0.32
62967 ELSEIF (ITUNE.EQ.359) THEN
62968C... Tevatron
62969 PARP(89)=1800D0
62970 PARP(90)=0.28
62971 PARP(82)=2.10
62972 PARP(78)=0.05
62973 ENDIF
62974
62975C================
62976C...Schulz-Skands 2011 tunes
62977C...(written as modifications on top of Perugia 0)
62978C================
62979 ELSEIF (ITUNSV.GE.360.AND.ITUNSV.LE.365) THEN
62980 ITUNE = ITUNSV
62981
62982 IF (ITUNE.EQ.360) THEN
62983 PARP(78)=0.40D0
62984 PARP(82)=2.19D0
62985 PARP(83)=1.45D0
62986 PARP(89)=1800.0D0
62987 PARP(90)=0.27D0
62988 ELSEIF (ITUNE.EQ.361) THEN
62989 PARP(78)=0.20D0
62990 PARP(82)=2.75D0
62991 PARP(83)=1.73D0
62992 PARP(89)=7000.0D0
62993 ELSEIF (ITUNE.EQ.362) THEN
62994 PARP(78)=0.31D0
62995 PARP(82)=1.97D0
62996 PARP(83)=1.98D0
62997 PARP(89)=1960.0D0
62998 ELSEIF (ITUNE.EQ.363) THEN
62999 PARP(78)=0.35D0
63000 PARP(82)=1.91D0
63001 PARP(83)=2.02D0
63002 PARP(89)=1800.0D0
63003 ELSEIF (ITUNE.EQ.364) THEN
63004 PARP(78)=0.33D0
63005 PARP(82)=1.69D0
63006 PARP(83)=1.92D0
63007 PARP(89)=900.0D0
63008 ELSEIF (ITUNE.EQ.365) THEN
63009 PARP(78)=0.47D0
63010 PARP(82)=1.61D0
63011 PARP(83)=1.50D0
63012 PARP(89)=630.0D0
63013 ENDIF
63014
63015 ENDIF
63016
63017C...Switch off trial joinings
63018 MSTP(96)=0
63019
63020C...S0 (300), S0A (303)
63021 IF (ITUNEB.EQ.300.OR.ITUNEB.EQ.303) THEN
63022 IF (M13.GE.1) THEN
63023 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
63024 WRITE(M11,5030) CH60
63025 CH60='M. Sandhoff & P. Skands, in hep-ph/0604120'
63026 WRITE(M11,5030) CH60
63027 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63028 WRITE(M11,5030) CH60
63029 IF (ITUNE.GE.310) THEN
63030 CH60='LEP parameters tuned by Professor,'//
63031 & ' hep-ph/0907.2973'
63032 WRITE(M11,5030) CH60
63033 ENDIF
63034 ENDIF
63035
63036C...S1 (301)
63037 ELSEIF(ITUNEB.EQ.301) THEN
63038 IF (M13.GE.1) THEN
63039 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
63040 WRITE(M11,5030) CH60
63041 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63042 WRITE(M11,5030) CH60
63043 IF (ITUNE.GE.310) THEN
63044 CH60='LEP parameters tuned by Professor,'//
63045 & ' hep-ph/0907.2973'
63046 WRITE(M11,5030) CH60
63047 ENDIF
63048 ENDIF
63049
63050C...S2 (302)
63051 ELSEIF(ITUNEB.EQ.302) THEN
63052 IF (M13.GE.1) THEN
63053 CH60='see M. Sandhoff & P. Skands, in hep-ph/0604120'
63054 WRITE(M11,5030) CH60
63055 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63056 WRITE(M11,5030) CH60
63057 IF (ITUNE.GE.310) THEN
63058 CH60='LEP parameters tuned by Professor,'//
63059 & ' hep-ph/0907.2973'
63060 WRITE(M11,5030) CH60
63061 ENDIF
63062 ENDIF
63063
63064C...NOCR (304)
63065 ELSEIF(ITUNEB.EQ.304) THEN
63066 IF (M13.GE.1) THEN
63067 CH60='"best try" without colour reconnections'
63068 WRITE(M11,5030) CH60
63069 CH60='see P. Skands & D. Wicke, hep-ph/0703081'
63070 WRITE(M11,5030) CH60
63071 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63072 WRITE(M11,5030) CH60
63073 IF (ITUNE.GE.310) THEN
63074 CH60='LEP parameters tuned by Professor,'//
63075 & ' hep-ph/0907.2973'
63076 WRITE(M11,5030) CH60
63077 ENDIF
63078 ENDIF
63079
63080C..."Lo FSR" retune (305)
63081 ELSEIF(ITUNEB.EQ.305) THEN
63082 IF (M13.GE.1) THEN
63083 CH60='"Lo FSR retune" with primitive colour reconnections'
63084 WRITE(M11,5030) CH60
63085 CH60='see T. Sjostrand & P. Skands, hep-ph/0408302'
63086 WRITE(M11,5030) CH60
63087 IF (ITUNE.GE.310) THEN
63088 CH60='LEP parameters tuned by Professor,'//
63089 & ' hep-ph/0907.2973'
63090 WRITE(M11,5030) CH60
63091 ENDIF
63092 ENDIF
63093
63094C...Perugia Tunes (320-328 and 334)
63095 ELSEIF((ITUNE.GE.320.AND.ITUNE.LE.328).OR.ITUNE.EQ.334) THEN
63096 IF (M13.GE.1) THEN
63097 CH60='Tuned by P. Skands, hep-ph/1005.3457'
63098 WRITE(M11,5030) CH60
63099 CH60='Physics Model: '//
63100 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63101 WRITE(M11,5030) CH60
63102 IF (ITUNE.LE.326) THEN
63103 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
63104 WRITE(M11,5030) CH60
63105 CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
63106 WRITE(M11,5030) CH60
63107 ENDIF
63108 IF (ITUNE.EQ.325) THEN
63109 CH70='NB! This tune requires MRST LO* pdfs to be '//
63110 & 'externally linked'
63111 WRITE(M11,5035) CH70
63112 ELSEIF (ITUNE.EQ.326) THEN
63113 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
63114 & 'externally linked'
63115 WRITE(M11,5035) CH70
63116 ELSEIF (ITUNE.EQ.321) THEN
63117 CH60='NB! This tune has MORE ISR & FSR / LESS UE & BR'
63118 WRITE(M11,5030) CH60
63119 ELSEIF (ITUNE.EQ.322) THEN
63120 CH60='NB! This tune has LESS ISR & FSR / MORE UE & BR'
63121 WRITE(M11,5030) CH60
63122 ENDIF
63123 ENDIF
63124
63125C...Professor-pTO (329)
63126 ELSEIF(ITUNE.EQ.329.OR.ITUNE.EQ.335.OR.ITUNE.EQ.336.OR.
63127 & ITUNE.EQ.339) THEN
63128 IF (M13.GE.1) THEN
63129 CH60='Tuned by Professor, hep-ph/0907.2973'
63130 WRITE(M11,5030) CH60
63131 CH60='Physics Model: '//
63132 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63133 WRITE(M11,5030) CH60
63134 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
63135 WRITE(M11,5030) CH60
63136 ENDIF
63137
63138C...Perugia 2011 Tunes (350-359)
63139 ELSEIF(ITUNE.GE.350.AND.ITUNE.LE.359) THEN
63140 IF (M13.GE.1) THEN
63141 CH60='Tuned by P. Skands, hep-ph/1005.3457'
63142 WRITE(M11,5030) CH60
63143 CH60='Physics Model: '//
63144 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63145 WRITE(M11,5030) CH60
63146 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
63147 WRITE(M11,5030) CH60
63148 IF (ITUNE.EQ.355) THEN
63149 CH70='NB! This tune requires MRST LO** pdfs to be '//
63150 & 'externally linked'
63151 WRITE(M11,5035) CH70
63152 ELSEIF (ITUNE.EQ.356) THEN
63153 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
63154 & 'externally linked'
63155 WRITE(M11,5035) CH70
63156 ENDIF
63157 ENDIF
63158
63159C...Schulz-Skands Tunes (360-365)
63160 ELSEIF(ITUNE.GE.360.AND.ITUNE.LE.365) THEN
63161 IF (M13.GE.1) THEN
63162 CH60='Tuned by H. Schulz & P. Skands, MCNET-11-07'
63163 WRITE(M11,5030) CH60
63164 CH60='Based on Perugia 0, hep-ph/1005.3457'
63165 WRITE(M11,5030) CH60
63166 CH60='Physics Model: '//
63167 & 'T. Sjostrand & P. Skands, hep-ph/0408302'
63168 WRITE(M11,5030) CH60
63169 CH60='CR by M. Sandhoff & P. Skands, in hep-ph/0604120'
63170 WRITE(M11,5030) CH60
63171 ENDIF
63172
63173 ENDIF
63174
63175C...Output
63176 IF (M13.GE.1) THEN
63177 WRITE(M11,5030) ' '
63178 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63179 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63180 IF (MSTP(33).GE.10) THEN
63181 WRITE(M11,5050) 32, PARP(32), CHPARP(32)
63182 ENDIF
63183 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63184 IF (MSTP(3).EQ.1) THEN
63185 WRITE(M11,6100) 112, MSTU(112), CHMSTU(112)
63186 WRITE(M11,6110) 112, PARU(112), CHPARU(112)
63187 WRITE(M11,5050) 1, PARP(1) , CHPARP( 1)
63188 ENDIF
63189 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63190 IF (MSTP(3).EQ.1)
63191 & WRITE(M11,5050) 72, PARP(72) , CHPARP( 72)
63192 IF (MSTP(3).EQ.1) THEN
63193 WRITE(M11,5050) 61, PARP(61) , CHPARP( 61)
63194 ENDIF
63195 WRITE(M11,5040) 64, MSTP(64), CHMSTP(64)
63196 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63197 WRITE(M11,5040) 67, MSTP(67), CHMSTP(67)
63198 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63199 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63200 WRITE(M11,5030) CH60
63201 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63202 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
63203 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63204 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
63205 IF (MSTP(70).EQ.0) THEN
63206 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63207 ELSEIF (MSTP(70).EQ.1) THEN
63208 WRITE(M11,5050) 81, PARP(81), CHPARP(62)
63209 CH60='(Note: PARP(81) replaces PARP(62).)'
63210 WRITE(M11,5030) CH60
63211 ENDIF
63212 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
63213 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63214 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63215 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63216 IF (MSTP(70).EQ.2) THEN
63217 CH60='(Note: PARP(82) replaces PARP(62).)'
63218 WRITE(M11,5030) CH60
63219 ENDIF
63220 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63221 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63222 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63223 IF (MSTP(82).EQ.5) THEN
63224 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63225 ELSEIF (MSTP(82).EQ.4) THEN
63226 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63227 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
63228 ENDIF
63229 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
63230 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
63231 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
63232 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
63233 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
63234 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
63235 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63236 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
63237 IF (MSTP(95).GE.1) THEN
63238 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
63239 IF (MSTP(95).GE.2) WRITE(M11,5050) 77, PARP(77), CHPARP(77)
63240 ENDIF
63241
63242 ENDIF
63243
63244C=======================================================================
63245C...ATLAS-CSC 11-parameter tune (By A. Moraes)
63246 ELSEIF (ITUNE.EQ.306) THEN
63247 IF (M13.GE.1) WRITE(M11,5010) ITUNE, CHNAME
63248 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
63249 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63250 & ' with tune.')
63251 ENDIF
63252
63253C...PDFs
63254 MSTP(52)=2
63255 MSTP(54)=2
63256 MSTP(51)=10042
63257 MSTP(53)=10042
63258C...ISR
63259C PARP(64)=1D0
63260C...UE on, new model.
63261 MSTP(81)=21
63262C...Energy scaling
63263 PARP(89)=1800D0
63264 PARP(90)=0.22D0
63265C...Switch off trial joinings
63266 MSTP(96)=0
63267C...Primordial kT cutoff
63268
63269 IF (M13.GE.1) THEN
63270 CH60='see presentations by A. Moraes (ATLAS),'
63271 WRITE(M11,5030) CH60
63272 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63273 WRITE(M11,5030) CH60
63274 WRITE(M11,5030) ' '
63275 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
63276 & 'externally linked'
63277 WRITE(M11,5035) CH70
63278 ENDIF
63279C...Smooth ISR, low FSR
63280 MSTP(70)=2
63281 MSTP(72)=0
63282C...pT0
63283 PARP(82)=1.9D0
63284C...Transverse density profile.
63285 MSTP(82)=4
63286 PARP(83)=0.3D0
63287 PARP(84)=0.5D0
63288C...ISR & FSR in interactions after the first (default)
63289 MSTP(84)=1
63290 MSTP(85)=1
63291C...No double-counting (default)
63292 MSTP(86)=2
63293C...Companion quark parent gluon (1-x) power
63294 MSTP(87)=4
63295C...Primordial kT compensation along chaings (default = 0 : uniform)
63296 MSTP(90)=1
63297C...Colour Reconnections
63298 MSTP(95)=1
63299 PARP(78)=0.2D0
63300C...Lambda_FSR scale.
63301 PARJ(81)=0.23D0
63302C...Rap order, Valence qq, qq x enhc, BR-g-BR supp
63303 MSTP(89)=1
63304 MSTP(88)=0
63305C PARP(79)=2D0
63306 PARP(80)=0.01D0
63307C...Peterson charm frag, and c and b hadr parameters
63308 MSTJ(11)=3
63309 PARJ(54)=-0.07
63310 PARJ(55)=-0.006
63311C... Output
63312 IF (M13.GE.1) THEN
63313 WRITE(M11,5030) ' '
63314 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63315 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63316 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63317 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63318 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63319 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63320 WRITE(M11,5030) CH60
63321 WRITE(M11,5040) 70, MSTP(70), CHMSTP(70)
63322 WRITE(M11,5040) 72, MSTP(72), CHMSTP(72)
63323 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63324 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63325 CH60='(Note: PARJ(81) changed from 0.14! See update notes)'
63326 WRITE(M11,5030) CH60
63327 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63328 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63329 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63330 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63331 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63332 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63333 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63334 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
63335 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
63336 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
63337 WRITE(M11,5040) 90, MSTP(90), CHMSTP(90)
63338 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
63339 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
63340 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63341 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
63342 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
63343
63344 ENDIF
63345
63346C=======================================================================
63347C...Tunes A, AW, BW, DW, DWT, QW, D6, D6T (by R.D. Field, CDF)
63348C...(100-105,108-109), ATLAS-DC2 Tune (by A. Moraes, ATLAS) (106)
63349C...A-Pro, DW-Pro, etc (100-119), and Pro-Q2O (129)
63350 ELSEIF ((ITUNE.GE.100.AND.ITUNE.LE.106).OR.ITUNE.EQ.108.OR.
63351 & ITUNE.EQ.109.OR.(ITUNE.GE.110.AND.ITUNE.LE.116).OR.
63352 & ITUNE.EQ.118.OR.ITUNE.EQ.119.OR.ITUNE.EQ.129) THEN
63353 IF (M13.GE.1.AND.ITUNE.NE.106.AND.ITUNE.NE.129) THEN
63354 WRITE(M11,5010) ITUNE, CHNAME
63355 CH60='see R.D. Field, in hep-ph/0610012'
63356 WRITE(M11,5030) CH60
63357 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
63358 WRITE(M11,5030) CH60
63359 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
63360 CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
63361 WRITE(M11,5030) CH60
63362 ENDIF
63363 ELSEIF (M13.GE.1.AND.ITUNE.EQ.129) THEN
63364 WRITE(M11,5010) ITUNE, CHNAME
63365 CH60='Tuned by Professor, hep-ph/0907.2973'
63366 WRITE(M11,5030) CH60
63367 CH60='Physics Model: '//
63368 & 'T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
63369 WRITE(M11,5030) CH60
63370 ENDIF
63371
63372C...Make sure we start from old default fragmentation parameters
63373 PARJ(81) = 0.29
63374 PARJ(82) = 1.0
63375
63376C...Use Professor's LEP pars if ITUNE >= 110
63377C...(i.e., for A-Pro, DW-Pro etc)
63378 IF (ITUNE.LT.110) THEN
63379C...# Old defaults
63380 MSTJ(11) = 4
63381 PARJ(1) = 0.1
63382 PARJ(2) = 0.3
63383 PARJ(3) = 0.40
63384 PARJ(4) = 0.05
63385 PARJ(11) = 0.5
63386 PARJ(12) = 0.6
63387 PARJ(21) = 0.36
63388 PARJ(41) = 0.30
63389 PARJ(42) = 0.58
63390 PARJ(46) = 1.0
63391 PARJ(81) = 0.29
63392 PARJ(82) = 1.0
63393 ELSE
63394C...# Tuned flavour parameters:
63395 PARJ(1) = 0.073
63396 PARJ(2) = 0.2
63397 PARJ(3) = 0.94
63398 PARJ(4) = 0.032
63399 PARJ(11) = 0.31
63400 PARJ(12) = 0.4
63401 PARJ(13) = 0.54
63402 PARJ(25) = 0.63
63403 PARJ(26) = 0.12
63404C...# Switch on Bowler:
63405 MSTJ(11) = 5
63406C...# Fragmentation
63407 PARJ(21) = 0.325
63408 PARJ(41) = 0.5
63409 PARJ(42) = 0.6
63410 PARJ(47) = 0.67
63411 PARJ(81) = 0.29
63412 PARJ(82) = 1.65
63413 ENDIF
63414
63415C...Remove middle digit now for Professor variants, since identical pars
63416 ITUNEB=ITUNE
63417 IF (ITUNE.GE.110.AND.ITUNE.LE.119) THEN
63418 ITUNEB=(ITUNE/100)*100+MOD(ITUNE,10)
63419 ENDIF
63420
63421C...Multiple interactions on, old framework
63422 MSTP(81)=1
63423C...Fast IR cutoff energy scaling by default
63424 PARP(89)=1800D0
63425 PARP(90)=0.25D0
63426C...Default CTEQ5L (internal), except for QW: CTEQ61 (external)
63427 MSTP(51)=7
63428 MSTP(52)=1
63429 IF (ITUNEB.EQ.105) THEN
63430 MSTP(51)=10150
63431 MSTP(52)=2
63432 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
63433 MSTP(52)=2
63434 MSTP(54)=2
63435 MSTP(51)=10042
63436 MSTP(53)=10042
63437 ENDIF
63438C...Double Gaussian matter distribution.
63439 MSTP(82)=4
63440 PARP(83)=0.5D0
63441 PARP(84)=0.4D0
63442C...FSR activity.
63443 PARP(71)=4D0
63444C...Fragmentation functions and c and b parameters
63445C...(only if not using Professor)
63446 IF (ITUNE.LE.109) THEN
63447 MSTJ(11)=4
63448 PARJ(54)=-0.05
63449 PARJ(55)=-0.005
63450 ENDIF
63451
63452C...Tune A and AW
63453 IF(ITUNEB.EQ.100.OR.ITUNEB.EQ.101) THEN
63454C...pT0.
63455 PARP(82)=2.0D0
63456c...String drawing almost completely minimizes string length.
63457 PARP(85)=0.9D0
63458 PARP(86)=0.95D0
63459C...ISR cutoff, muR scale factor, and phase space size
63460 PARP(62)=1D0
63461 PARP(64)=1D0
63462 PARP(67)=4D0
63463C...Intrinsic kT, size, and max
63464 MSTP(91)=1
63465 PARP(91)=1D0
63466 PARP(93)=5D0
63467C...AW : higher ISR IR cutoff, but also larger alphaS, more intrinsic kT
63468 IF (ITUNEB.EQ.101) THEN
63469 PARP(62)=1.25D0
63470 PARP(64)=0.2D0
63471 PARP(91)=2.1D0
63472 PARP(92)=15.0D0
63473 ENDIF
63474
63475C...Tune BW (larger alphaS, more intrinsic kT. Smaller ISR phase space)
63476 ELSEIF (ITUNEB.EQ.102) THEN
63477C...pT0.
63478 PARP(82)=1.9D0
63479c...String drawing completely minimizes string length.
63480 PARP(85)=1.0D0
63481 PARP(86)=1.0D0
63482C...ISR cutoff, muR scale factor, and phase space size
63483 PARP(62)=1.25D0
63484 PARP(64)=0.2D0
63485 PARP(67)=1D0
63486C...Intrinsic kT, size, and max
63487 MSTP(91)=1
63488 PARP(91)=2.1D0
63489 PARP(93)=15D0
63490
63491C...Tune DW
63492 ELSEIF (ITUNEB.EQ.103) THEN
63493C...pT0.
63494 PARP(82)=1.9D0
63495c...String drawing completely minimizes string length.
63496 PARP(85)=1.0D0
63497 PARP(86)=1.0D0
63498C...ISR cutoff, muR scale factor, and phase space size
63499 PARP(62)=1.25D0
63500 PARP(64)=0.2D0
63501 PARP(67)=2.5D0
63502C...Intrinsic kT, size, and max
63503 MSTP(91)=1
63504 PARP(91)=2.1D0
63505 PARP(93)=15D0
63506
63507C...Tune DWT
63508 ELSEIF (ITUNEB.EQ.104) THEN
63509C...pT0.
63510 PARP(82)=1.9409D0
63511C...Run II ref scale and slow scaling
63512 PARP(89)=1960D0
63513 PARP(90)=0.16D0
63514c...String drawing completely minimizes string length.
63515 PARP(85)=1.0D0
63516 PARP(86)=1.0D0
63517C...ISR cutoff, muR scale factor, and phase space size
63518 PARP(62)=1.25D0
63519 PARP(64)=0.2D0
63520 PARP(67)=2.5D0
63521C...Intrinsic kT, size, and max
63522 MSTP(91)=1
63523 PARP(91)=2.1D0
63524 PARP(93)=15D0
63525
63526C...Tune QW
63527 ELSEIF(ITUNEB.EQ.105) THEN
63528 IF (M13.GE.1) THEN
63529 WRITE(M11,5030) ' '
63530 CH70='NB! This tune requires CTEQ6.1 pdfs to be '//
63531 & 'externally linked'
63532 WRITE(M11,5035) CH70
63533 ENDIF
63534C...pT0.
63535 PARP(82)=1.1D0
63536c...String drawing completely minimizes string length.
63537 PARP(85)=1.0D0
63538 PARP(86)=1.0D0
63539C...ISR cutoff, muR scale factor, and phase space size
63540 PARP(62)=1.25D0
63541 PARP(64)=0.2D0
63542 PARP(67)=2.5D0
63543C...Intrinsic kT, size, and max
63544 MSTP(91)=1
63545 PARP(91)=2.1D0
63546 PARP(93)=15D0
63547
63548C...Tune D6 and D6T
63549 ELSEIF(ITUNEB.EQ.108.OR.ITUNEB.EQ.109) THEN
63550 IF (M13.GE.1) THEN
63551 WRITE(M11,5030) ' '
63552 CH70='NB! This tune requires CTEQ6L pdfs to be '//
63553 & 'externally linked'
63554 WRITE(M11,5035) CH70
63555 ENDIF
63556C...The "Rick" proton, double gauss with 0.5/0.4
63557 MSTP(82)=4
63558 PARP(83)=0.5D0
63559 PARP(84)=0.4D0
63560c...String drawing completely minimizes string length.
63561 PARP(85)=1.0D0
63562 PARP(86)=1.0D0
63563 IF (ITUNEB.EQ.108) THEN
63564C...D6: pT0, Run I ref scale, and fast energy scaling
63565 PARP(82)=1.8D0
63566 PARP(89)=1800D0
63567 PARP(90)=0.25D0
63568 ELSE
63569C...D6T: pT0, Run II ref scale, and slow energy scaling
63570 PARP(82)=1.8387D0
63571 PARP(89)=1960D0
63572 PARP(90)=0.16D0
63573 ENDIF
63574C...ISR cutoff, muR scale factor, and phase space size
63575 PARP(62)=1.25D0
63576 PARP(64)=0.2D0
63577 PARP(67)=2.5D0
63578C...Intrinsic kT, size, and max
63579 MSTP(91)=1
63580 PARP(91)=2.1D0
63581 PARP(93)=15D0
63582
63583C...Old ATLAS-DC2 5-parameter tune
63584 ELSEIF(ITUNEB.EQ.106) THEN
63585 IF (M13.GE.1) THEN
63586 WRITE(M11,5010) ITUNE, CHNAME
63587 CH60='see A. Moraes et al., SN-ATLAS-2006-057,'
63588 WRITE(M11,5030) CH60
63589 CH60=' R. Field in hep-ph/0610012,'
63590 WRITE(M11,5030) CH60
63591 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
63592 WRITE(M11,5030) CH60
63593 ENDIF
63594C... pT0.
63595 PARP(82)=1.8D0
63596C... Different ref and rescaling pacee
63597 PARP(89)=1000D0
63598 PARP(90)=0.16D0
63599C... Parameters of mass distribution
63600 PARP(83)=0.5D0
63601 PARP(84)=0.5D0
63602C... Old default string drawing
63603 PARP(85)=0.33D0
63604 PARP(86)=0.66D0
63605C... ISR, phase space equivalent to Tune B
63606 PARP(62)=1D0
63607 PARP(64)=1D0
63608 PARP(67)=1D0
63609C... FSR
63610 PARP(71)=4D0
63611C... Intrinsic kT
63612 MSTP(91)=1
63613 PARP(91)=1D0
63614 PARP(93)=5D0
63615
63616C...Professor's Pro-Q2O Tune
63617 ELSEIF(ITUNE.EQ.129) THEN
63618 PARP(62)=2.9
63619 PARP(64)=0.14
63620 PARP(67)=2.65
63621 PARP(82)=1.9
63622 PARP(83)=0.83
63623 PARP(84)=0.6
63624 PARP(85)=0.86
63625 PARP(86)=0.93
63626 PARP(89)=1800D0
63627 PARP(90)=0.22
63628 MSTP(91)=1
63629 PARP(91)=2.1
63630 PARP(93)=5.0
63631
63632 ENDIF
63633
63634C... Output
63635 IF (M13.GE.1) THEN
63636 WRITE(M11,5030) ' '
63637 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63638 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63639 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63640 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63641 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63642 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63643 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63644 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63645 WRITE(M11,5030) CH60
63646 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63647 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63648 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
63649 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63650 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63651 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63652 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63653 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63654 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63655 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63656 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
63657 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
63658 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
63659 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
63660 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
63661 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63662
63663 ENDIF
63664
63665C=======================================================================
63666C... ACR, tune A with new CR (107)
63667 ELSEIF(ITUNE.EQ.107.OR.ITUNE.EQ.117) THEN
63668 IF (M13.GE.1) THEN
63669 WRITE(M11,5010) ITUNE, CHNAME
63670 CH60='Tune A modified with new colour reconnections'
63671 WRITE(M11,5030) CH60
63672 CH60='PARP(85)=0D0 and amount of CR is regulated by PARP(78)'
63673 WRITE(M11,5030) CH60
63674 CH60='see P. Skands & D. Wicke, hep-ph/0703081,'
63675 WRITE(M11,5030) CH60
63676 CH60=' R. Field, in hep-ph/0610012 (Tune A),'
63677 WRITE(M11,5030) CH60
63678 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
63679 WRITE(M11,5030) CH60
63680 IF (ITUNE.EQ.117) THEN
63681 CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
63682 WRITE(M11,5030) CH60
63683 ENDIF
63684 ENDIF
63685 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.406))THEN
63686 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63687 & ' with tune. Using defaults.')
63688 GOTO 100
63689 ENDIF
63690
63691C...Make sure we start from old default fragmentation parameters
63692 PARJ(81) = 0.29
63693 PARJ(82) = 1.0
63694
63695C...Use Professor's LEP pars if ITUNE >= 110
63696C...(i.e., for A-Pro, DW-Pro etc)
63697 IF (ITUNE.LT.110) THEN
63698C...# Old defaults
63699 MSTJ(11) = 4
63700C...# Old default flavour parameters
63701 PARJ(21) = 0.36
63702 PARJ(41) = 0.30
63703 PARJ(42) = 0.58
63704 PARJ(46) = 1.0
63705 PARJ(82) = 1.0
63706 ELSE
63707C...# Tuned flavour parameters:
63708 PARJ(1) = 0.073
63709 PARJ(2) = 0.2
63710 PARJ(3) = 0.94
63711 PARJ(4) = 0.032
63712 PARJ(11) = 0.31
63713 PARJ(12) = 0.4
63714 PARJ(13) = 0.54
63715 PARJ(25) = 0.63
63716 PARJ(26) = 0.12
63717C...# Switch on Bowler:
63718 MSTJ(11) = 5
63719C...# Fragmentation
63720 PARJ(21) = 0.325
63721 PARJ(41) = 0.5
63722 PARJ(42) = 0.6
63723 PARJ(47) = 0.67
63724 PARJ(81) = 0.29
63725 PARJ(82) = 1.65
63726 ENDIF
63727
63728 MSTP(81)=1
63729 PARP(89)=1800D0
63730 PARP(90)=0.25D0
63731 MSTP(82)=4
63732 PARP(83)=0.5D0
63733 PARP(84)=0.4D0
63734 MSTP(51)=7
63735 MSTP(52)=1
63736 PARP(71)=4D0
63737 PARP(82)=2.0D0
63738 PARP(85)=0.0D0
63739 PARP(86)=0.66D0
63740 PARP(62)=1D0
63741 PARP(64)=1D0
63742 PARP(67)=4D0
63743 MSTP(91)=1
63744 PARP(91)=1D0
63745 PARP(93)=5D0
63746 MSTP(95)=6
63747C...P78 changed from 0.12 to 0.09 in 6.4.19 to improve <pT>(Nch)
63748 PARP(78)=0.09D0
63749C...Frag functions (only if not using Professor)
63750 IF (ITUNE.LE.109) THEN
63751 MSTJ(11)=4
63752 PARJ(54)=-0.05
63753 PARJ(55)=-0.005
63754 ENDIF
63755
63756C...Output
63757 IF (M13.GE.1) THEN
63758 WRITE(M11,5030) ' '
63759 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63760 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63761 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63762 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63763 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63764 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63765 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63766 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63767 WRITE(M11,5030) CH60
63768 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63769 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63770 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
63771 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63772 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63773 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63774 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63775 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63776 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63777 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63778 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
63779 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
63780 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
63781 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
63782 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
63783 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63784 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
63785 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
63786
63787 ENDIF
63788
63789C=======================================================================
63790C...Intermediate model. Rap tune
63791C...(retuned to post-6.406 IR factorization)
63792 ELSEIF(ITUNE.EQ.200) THEN
63793 IF (M13.GE.1) THEN
63794 WRITE(M11,5010) ITUNE, CHNAME
63795 CH60='see T. Sjostrand & P. Skands, JHEP03(2004)053'
63796 WRITE(M11,5030) CH60
63797 ENDIF
63798 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.405))THEN
63799 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63800 & ' with tune.')
63801 ENDIF
63802C...PDF
63803 MSTP(51)=7
63804 MSTP(52)=1
63805C...ISR
63806 PARP(62)=1D0
63807 PARP(64)=1D0
63808 PARP(67)=4D0
63809C...FSR
63810 PARP(71)=4D0
63811 PARJ(81)=0.29D0
63812C...UE
63813 MSTP(81)=11
63814 PARP(82)=2.25D0
63815 PARP(89)=1800D0
63816 PARP(90)=0.25D0
63817C... ExpOfPow(1.8) overlap profile
63818 MSTP(82)=5
63819 PARP(83)=1.8D0
63820C... Valence qq
63821 MSTP(88)=0
63822C... Rap Tune
63823 MSTP(89)=1
63824C... Default diquark, BR-g-BR supp
63825 PARP(79)=2D0
63826 PARP(80)=0.01D0
63827C... Final state reconnect.
63828 MSTP(95)=1
63829 PARP(78)=0.55D0
63830C...Fragmentation functions and c and b parameters
63831 MSTJ(11)=4
63832 PARJ(54)=-0.05
63833 PARJ(55)=-0.005
63834C... Output
63835 IF (M13.GE.1) THEN
63836 WRITE(M11,5030) ' '
63837 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63838 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63839 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63840 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63841 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63842 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63843 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63844 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
63845 WRITE(M11,5030) CH60
63846 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
63847 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
63848 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
63849 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
63850 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
63851 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
63852 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
63853 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
63854 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
63855 WRITE(M11,5040) 88, MSTP(88), CHMSTP(88)
63856 WRITE(M11,5040) 89, MSTP(89), CHMSTP(89)
63857 WRITE(M11,5050) 79, PARP(79), CHPARP(79)
63858 WRITE(M11,5050) 80, PARP(80), CHPARP(80)
63859 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
63860 WRITE(M11,5040) 95, MSTP(95), CHMSTP(95)
63861 WRITE(M11,5050) 78, PARP(78), CHPARP(78)
63862
63863 ENDIF
63864
63865C...APT(201), APT-Pro (211), Perugia-APT (221), Perugia-APT6 (226).
63866C...Old model for ISR and UE, new pT-ordered model for FSR
63867 ELSEIF(ITUNE.EQ.201.OR.ITUNE.EQ.211.OR.ITUNE.EQ.221.OR
63868 & .ITUNE.EQ.226) THEN
63869 IF (M13.GE.1) THEN
63870 WRITE(M11,5010) ITUNE, CHNAME
63871 CH60='see P. Skands & D. Wicke, hep-ph/0703081 (Tune APT),'
63872 WRITE(M11,5030) CH60
63873 CH60=' R.D. Field, in hep-ph/0610012 (Tune A)'
63874 WRITE(M11,5030) CH60
63875 CH60=' T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
63876 WRITE(M11,5030) CH60
63877 CH60='and T. Sjostrand & P. Skands, hep-ph/0408302'
63878 WRITE(M11,5030) CH60
63879 IF (ITUNE.EQ.211.OR.ITUNE.GE.221) THEN
63880 CH60='LEP parameters tuned by Professor, hep-ph/0907.2973'
63881 WRITE(M11,5030) CH60
63882 ENDIF
63883 ENDIF
63884 IF (MSTP(181).LE.5.OR.(MSTP(181).EQ.6.AND.MSTP(182).LE.411))THEN
63885 CALL PYERRM(9,'(PYTUNE:) linked PYTHIA version incompatible'//
63886 & ' with tune.')
63887 ENDIF
63888C...First set as if Pythia tune A
63889C...Multiple interactions on, old framework
63890 MSTP(81)=1
63891C...Fast IR cutoff energy scaling by default
63892 PARP(89)=1800D0
63893 PARP(90)=0.25D0
63894C...Default CTEQ5L (internal)
63895 MSTP(51)=7
63896 MSTP(52)=1
63897C...Double Gaussian matter distribution.
63898 MSTP(82)=4
63899 PARP(83)=0.5D0
63900 PARP(84)=0.4D0
63901C...FSR activity.
63902 PARP(71)=4D0
63903c...String drawing almost completely minimizes string length.
63904 PARP(85)=0.9D0
63905 PARP(86)=0.95D0
63906C...ISR cutoff, muR scale factor, and phase space size
63907 PARP(62)=1D0
63908 PARP(64)=1D0
63909 PARP(67)=4D0
63910C...Intrinsic kT, size, and max
63911 MSTP(91)=1
63912 PARP(91)=1D0
63913 PARP(93)=5D0
63914C...Use 2 GeV of primordial kT for "Perugia" version
63915 IF (ITUNE.EQ.221) THEN
63916 PARP(91)=2D0
63917 PARP(93)=10D0
63918 ENDIF
63919C...Use pT-ordered FSR
63920 MSTJ(41)=12
63921C...Lambda_FSR scale for pT-ordering
63922 PARJ(81)=0.23D0
63923C...Retune pT0 (changed from 2.1 to 2.05 in 6.4.20)
63924 PARP(82)=2.05D0
63925C...Fragmentation functions and c and b parameters
63926C...(overwritten for 211, i.e., if using Professor pars)
63927 PARJ(54)=-0.05
63928 PARJ(55)=-0.005
63929
63930C...Use Professor's LEP pars if ITUNE == 211, 221, 226
63931 IF (ITUNE.LT.210) THEN
63932C...# Old defaults
63933 MSTJ(11) = 4
63934C...# Old default flavour parameters
63935 PARJ(21) = 0.36
63936 PARJ(41) = 0.30
63937 PARJ(42) = 0.58
63938 PARJ(46) = 1.0
63939 PARJ(82) = 1.0
63940 ELSE
63941C...# Tuned flavour parameters:
63942 PARJ(1) = 0.073
63943 PARJ(2) = 0.2
63944 PARJ(3) = 0.94
63945 PARJ(4) = 0.032
63946 PARJ(11) = 0.31
63947 PARJ(12) = 0.4
63948 PARJ(13) = 0.54
63949 PARJ(25) = 0.63
63950 PARJ(26) = 0.12
63951C...# Always use pT-ordered shower:
63952 MSTJ(41) = 12
63953C...# Switch on Bowler:
63954 MSTJ(11) = 5
63955C...# Fragmentation
63956 PARJ(21) = 3.1327e-01
63957 PARJ(41) = 4.8989e-01
63958 PARJ(42) = 1.2018e+00
63959 PARJ(47) = 1.0000e+00
63960 PARJ(81) = 2.5696e-01
63961 PARJ(82) = 8.0000e-01
63962 ENDIF
63963
63964C...221, 226 : Perugia-APT and Perugia-APT6
63965 IF (ITUNE.EQ.221.OR.ITUNE.EQ.226) THEN
63966
63967 PARP(64)=0.5D0
63968 PARP(82)=2.05D0
63969 PARP(90)=0.26D0
63970 PARP(91)=2.0D0
63971C...The Perugia variants use Steve's showers off the old MPI
63972 MSTP(152)=1
63973C...And use a lower PARP(71) as suggested by Professor tunings
63974C...(although not certain that applies to Q2-pT2 hybrid)
63975 PARP(71)=2.5D0
63976
63977C...Perugia-APT6 uses CTEQ6L1 and a slightly lower pT0
63978 IF (ITUNE.EQ.226) THEN
63979 CH70='NB! This tune requires CTEQ6L1 pdfs to be '//
63980 & 'externally linked'
63981 WRITE(M11,5035) CH70
63982 MSTP(52)=2
63983 MSTP(51)=10042
63984 PARP(82)=1.95D0
63985 ENDIF
63986
63987 ENDIF
63988
63989C... Output
63990 IF (M13.GE.1) THEN
63991 WRITE(M11,5030) ' '
63992 WRITE(M11,5040) 51, MSTP(51), CHMSTP(51)
63993 WRITE(M11,5040) 52, MSTP(52), CHMSTP(52)
63994 WRITE(M11,5040) 3, MSTP( 3), CHMSTP( 3)
63995 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
63996 WRITE(M11,5050) 64, PARP(64), CHPARP(64)
63997 WRITE(M11,5050) 67, PARP(67), CHPARP(67)
63998 WRITE(M11,5040) 68, MSTP(68), CHMSTP(68)
63999 CH60='(Note: MSTP(68) is not explicitly (re-)set by PYTUNE)'
64000 WRITE(M11,5030) CH60
64001 WRITE(M11,5070) 41, MSTJ(41), CHMSTJ(41)
64002 WRITE(M11,5050) 71, PARP(71), CHPARP(71)
64003 WRITE(M11,5060) 81, PARJ(81), CHPARJ(81)
64004 WRITE(M11,5040) 33, MSTP(33), CHMSTP(33)
64005 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64006 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64007 WRITE(M11,5050) 89, PARP(89), CHPARP(89)
64008 WRITE(M11,5050) 90, PARP(90), CHPARP(90)
64009 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64010 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64011 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
64012 WRITE(M11,5050) 85, PARP(85), CHPARP(85)
64013 WRITE(M11,5050) 86, PARP(86), CHPARP(86)
64014 WRITE(M11,5040) 91, MSTP(91), CHMSTP(91)
64015 WRITE(M11,5050) 91, PARP(91), CHPARP(91)
64016 WRITE(M11,5050) 93, PARP(93), CHPARP(93)
64017
64018 ENDIF
64019
64020C======================================================================
64021C...Uppsala models: Generalized Area Law and Soft Colour Interactions
64022 ELSEIF(CHNAME.EQ.'GAL Tune 0'.OR.CHNAME.EQ.'GAL Tune 1') THEN
64023 IF (M13.GE.1) THEN
64024 WRITE(M11,5010) ITUNE, CHNAME
64025 CH60='see J. Rathsman, PLB452(1999)364'
64026 WRITE(M11,5030) CH60
64027C ? CH60='A. Edin, G. Ingelman, J. Rathsman, hep-ph/9912539,'
64028C ? WRITE(M11,5030)
64029 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64030 WRITE(M11,5030) CH60
64031 WRITE(M11,5030) ' '
64032 CH70='NB! The GAL model must be run with modified '//
64033 & 'Pythia v6.215:'
64034 WRITE(M11,5035) CH70
64035 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
64036 WRITE(M11,5035) CH70
64037 WRITE(M11,5030) ' '
64038 ENDIF
64039C...GAL Recommended settings from Uppsala web page (as per 22/08 2006)
64040 MSWI(2) = 3
64041 PARSCI(2) = 0.10
64042 MSWI(1) = 2
64043 PARSCI(1) = 0.44
64044 MSTJ(16) = 0
64045 PARJ(42) = 0.45
64046 PARJ(82) = 2.0
64047 PARP(62) = 2.0
64048 MSTP(81) = 1
64049 MSTP(82) = 1
64050 PARP(81) = 1.9
64051 MSTP(92) = 1
64052 IF(CHNAME.EQ.'GAL Tune 1') THEN
64053C...GAL retune (P. Skands) to get better min-bias <Nch> at Tevatron
64054 MSTP(82)=4
64055 PARP(83)=0.25D0
64056 PARP(84)=0.5D0
64057 PARP(82) = 1.75
64058 IF (M13.GE.1) THEN
64059 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64060 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64061 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64062 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64063 WRITE(M11,5050) 84, PARP(84), CHPARP(84)
64064 ENDIF
64065 ELSE
64066 IF (M13.GE.1) THEN
64067 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64068 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
64069 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64070 ENDIF
64071 ENDIF
64072C...Output
64073 IF (M13.GE.1) THEN
64074 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
64075 WRITE(M11,5060) 82, PARJ(82), CHPARJ(82)
64076 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
64077 CH40='FSI SCI/GAL selection'
64078 WRITE(M11,6040) 1, MSWI(1), CH40
64079 CH40='FSI SCI/GAL sea quark treatment'
64080 WRITE(M11,6040) 2, MSWI(2), CH40
64081 CH40='FSI SCI/GAL sea quark treatment parm'
64082 WRITE(M11,6050) 1, PARSCI(1), CH40
64083 CH40='FSI SCI/GAL string reco probability R_0'
64084 WRITE(M11,6050) 2, PARSCI(2), CH40
64085 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
64086 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
64087 ENDIF
64088 ELSEIF(CHNAME.EQ.'SCI Tune 0'.OR.CHNAME.EQ.'SCI Tune 1') THEN
64089 IF (M13.GE.1) THEN
64090 WRITE(M11,5010) ITUNE, CHNAME
64091 CH60='see A.Edin et al, PLB366(1996)371, Z.Phys.C75(1997)57,'
64092 WRITE(M11,5030) CH60
64093 CH60='and T. Sjostrand & M. v. Zijl, PRD36(1987)2019'
64094 WRITE(M11,5030) CH60
64095 WRITE(M11,5030) ' '
64096 CH70='NB! The SCI model must be run with modified '//
64097 & 'Pythia v6.215:'
64098 WRITE(M11,5035) CH70
64099 CH70='available from http://www.isv.uu.se/thep/MC/scigal/'
64100 WRITE(M11,5035) CH70
64101 WRITE(M11,5030) ' '
64102 ENDIF
64103C...SCI Recommended settings from Uppsala web page (as per 22/08 2006)
64104 MSTP(81)=1
64105 MSTP(82)=1
64106 PARP(81)=2.2
64107 MSTP(92)=1
64108 MSWI(2)=2
64109 PARSCI(2)=0.50
64110 MSWI(1)=2
64111 PARSCI(1)=0.44
64112 MSTJ(16)=0
64113 IF (CHNAME.EQ.'SCI Tune 1') THEN
64114C...SCI retune (P. Skands) to get better min-bias <Nch> at Tevatron
64115 MSTP(81) = 1
64116 MSTP(82) = 3
64117 PARP(82) = 2.4
64118 PARP(83) = 0.5D0
64119 PARP(62) = 1.5
64120 PARP(84)=0.25D0
64121 IF (M13.GE.1) THEN
64122 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64123 WRITE(M11,5050) 82, PARP(82), CHPARP(82)
64124 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64125 WRITE(M11,5050) 83, PARP(83), CHPARP(83)
64126 WRITE(M11,5050) 62, PARP(62), CHPARP(62)
64127 ENDIF
64128 ELSE
64129 IF (M13.GE.1) THEN
64130 WRITE(M11,5040) 81, MSTP(81), CHMSTP(81)
64131 WRITE(M11,5050) 81, PARP(81), CHPARP(81)
64132 WRITE(M11,5040) 82, MSTP(82), CHMSTP(82)
64133 ENDIF
64134 ENDIF
64135C...Output
64136 IF (M13.GE.1) THEN
64137 WRITE(M11,5040) 92, MSTP(92), CHMSTP(92)
64138 CH40='FSI SCI/GAL selection'
64139 WRITE(M11,6040) 1, MSWI(1), CH40
64140 CH40='FSI SCI/GAL sea quark treatment'
64141 WRITE(M11,6040) 2, MSWI(2), CH40
64142 CH40='FSI SCI/GAL sea quark treatment parm'
64143 WRITE(M11,6050) 1, PARSCI(1), CH40
64144 CH40='FSI SCI/GAL string reco probability R_0'
64145 WRITE(M11,6050) 2, PARSCI(2), CH40
64146 WRITE(M11,5070) 16, MSTJ(16), CHMSTJ(16)
64147 ENDIF
64148
64149 ELSE
64150 IF (MSTU(13).GE.1) WRITE(M11,5020) ITUNE
64151
64152 ENDIF
64153
64154C...Output of LEP parameters, common to all models
64155 IF (M13.GE.1) THEN
64156 WRITE(M11,5080)
64157 WRITE(M11,5070) 11, MSTJ(11), CHMSTJ(11)
64158 IF (MSTJ(11).EQ.3) THEN
64159 CH60='Warning: using Peterson fragmentation function'
64160 WRITE(M11,5030) CH60
64161 ENDIF
64162
64163 WRITE(M11,5060) 1, PARJ( 1), CHPARJ( 1)
64164 WRITE(M11,5060) 2, PARJ( 2), CHPARJ( 2)
64165 WRITE(M11,5060) 3, PARJ( 3), CHPARJ( 3)
64166 WRITE(M11,5060) 4, PARJ( 4), CHPARJ( 4)
64167 WRITE(M11,5060) 5, PARJ( 5), CHPARJ( 5)
64168 WRITE(M11,5060) 6, PARJ( 6), CHPARJ( 6)
64169 WRITE(M11,5060) 7, PARJ( 7), CHPARJ( 7)
64170
64171 WRITE(M11,5060) 11, PARJ(11), CHPARJ(11)
64172 WRITE(M11,5060) 12, PARJ(12), CHPARJ(12)
64173 WRITE(M11,5060) 13, PARJ(13), CHPARJ(13)
64174
64175 WRITE(M11,5060) 21, PARJ(21), CHPARJ(21)
64176
64177 WRITE(M11,5060) 25, PARJ(25), CHPARJ(25)
64178 WRITE(M11,5060) 26, PARJ(26), CHPARJ(26)
64179
64180 WRITE(M11,5060) 41, PARJ(41), CHPARJ(41)
64181 WRITE(M11,5060) 42, PARJ(42), CHPARJ(42)
64182 WRITE(M11,5060) 45, PARJ(45), CHPARJ(45)
64183
64184 IF (MSTJ(11).LE.3) THEN
64185 WRITE(M11,5060) 54, PARJ(54), CHPARJ(54)
64186 WRITE(M11,5060) 55, PARJ(55), CHPARJ(55)
64187 ELSE
64188 WRITE(M11,5060) 46, PARJ(46), CHPARJ(46)
64189 ENDIF
64190 IF (MSTJ(11).EQ.5) WRITE(M11,5060) 47, PARJ(47), CHPARJ(47)
64191 ENDIF
64192
64193 100 IF (MSTU(13).GE.1) WRITE(M11,6000)
64194
64195 9999 RETURN
64196
64197 5000 FORMAT(1x,78('*')/' *',76x,'*'/' *',3x,'PYTUNE : ',
64198 & 'Presets for underlying-event (and min-bias)',21x,'*'/' *',
64199 & 12x,'Last Change : ',A8,' - P. Skands',30x,'*'/' *',76x,'*')
64200 5010 FORMAT(' *',3x,I4,1x,A16,52x,'*')
64201 5020 FORMAT(' *',3x,'Tune ',I4, ' not recognized. Using defaults.')
64202 5030 FORMAT(' *',3x,10x,A60,3x,'*')
64203 5035 FORMAT(' *',3x,A70,3x,'*')
64204 5040 FORMAT(' *',5x,'MSTP(',I2,') = ',I12,3x,A42,3x,'*')
64205 5050 FORMAT(' *',5x,'PARP(',I2,') = ',F12.4,3x,A40,5x,'*')
64206 5060 FORMAT(' *',5x,'PARJ(',I2,') = ',F12.4,3x,A40,5x,'*')
64207 5070 FORMAT(' *',5x,'MSTJ(',I2,') = ',I12,3x,A40,5x,'*')
64208 5080 FORMAT(' *',3x,'----------------------------',42('-'),3x,'*')
64209 6100 FORMAT(' *',5x,'MSTU(',I3,')= ',I12,3x,A42,3x,'*')
64210 6110 FORMAT(' *',5x,'PARU(',I3,')= ',F12.4,3x,A42,3x,'*')
64211C 5140 FORMAT(' *',5x,'MSTP(',I3,')= ',I12,3x,A40,5x,'*')
64212C 5150 FORMAT(' *',5x,'PARP(',I3,')= ',F12.4,3x,A40,5x,'*')
64213 6000 FORMAT(' *',76x,'*'/1x,32('*'),1x,'END OF PYTUNE',1x,31('*'))
64214 6040 FORMAT(' *',5x,'MSWI(',I1,') = ',I12,3x,A40,5x,'*')
64215 6050 FORMAT(' *',5x,'PARSCI(',I1,')= ',F12.4,3x,A40,5x,'*')
64216
64217 END
64218
64219C*********************************************************************
64220
64221C...PYEXEC
64222C...Administrates the fragmentation and decay chain.
64223
64224 SUBROUTINE PYEXEC
64225
64226C...Double precision and integer declarations.
64227 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64228 IMPLICIT INTEGER(I-N)
64229 INTEGER PYK,PYCHGE,PYCOMP
64230C...Commonblocks.
64231 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64232 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64233 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64234 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
64235 COMMON/PYINT1/MINT(400),VINT(400)
64236 COMMON/PYINT4/MWID(500),WIDS(500,5)
64237 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYINT4/
64238C...Local array.
64239 DIMENSION PS(2,6),IJOIN(100)
64240
64241C...Initialize and reset.
64242 MSTU(24)=0
64243 IF(MSTU(12).NE.12345) CALL PYLIST(0)
64244 MSTU(29)=0
64245 MSTU(31)=MSTU(31)+1
64246 MSTU(1)=0
64247 MSTU(2)=0
64248 MSTU(3)=0
64249 IF(MSTU(17).LE.0) MSTU(90)=0
64250 MCONS=1
64251
64252C...Sum up momentum, energy and charge for starting entries.
64253 NSAV=N
64254 DO 110 I=1,2
64255 DO 100 J=1,6
64256 PS(I,J)=0D0
64257 100 CONTINUE
64258 110 CONTINUE
64259 DO 130 I=1,N
64260 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 130
64261 DO 120 J=1,4
64262 PS(1,J)=PS(1,J)+P(I,J)
64263 120 CONTINUE
64264 PS(1,6)=PS(1,6)+PYCHGE(K(I,2))
64265 130 CONTINUE
64266 PARU(21)=PS(1,4)
64267
64268C...Start by all decays of coloured resonances involved in shower.
64269 NORIG=N
64270 DO 140 I=1,NORIG
64271 IF(K(I,1).EQ.3) THEN
64272 KC=PYCOMP(K(I,2))
64273 IF(MWID(KC).NE.0.AND.KCHG(KC,2).NE.0) CALL PYRESD(I)
64274 ENDIF
64275 140 CONTINUE
64276
64277C...Prepare system for subsequent fragmentation/decay.
64278 CALL PYPREP(0)
64279 IF(MINT(51).NE.0) RETURN
64280
64281C...Loop through jet fragmentation and particle decays.
64282 MBE=0
64283 150 MBE=MBE+1
64284 IP=0
64285 160 IP=IP+1
64286 KC=0
64287 IF(K(IP,1).GT.0.AND.K(IP,1).LE.10) KC=PYCOMP(K(IP,2))
64288 IF(KC.EQ.0) THEN
64289
64290C...Deal with any remaining undecayed resonance
64291C...(normally the task of PYEVNT, so seldom used).
64292 ELSEIF(MWID(KC).NE.0) THEN
64293 IBEG=IP
64294 IF(KCHG(KC,2).NE.0.AND.K(I,1).NE.3) THEN
64295 IBEG=IP+1
64296 170 IBEG=IBEG-1
64297 IF(IBEG.GE.2.AND.K(IBEG,1).EQ.2) GOTO 170
64298 IF(K(IBEG,1).NE.2) IBEG=IBEG+1
64299 IEND=IP-1
64300 180 IEND=IEND+1
64301 IF(IEND.LT.N.AND.K(IEND,1).EQ.2) GOTO 180
64302 IF(IEND.LT.N.AND.KCHG(PYCOMP(K(IEND,2)),2).EQ.0) GOTO 180
64303 NJOIN=0
64304 DO 190 I=IBEG,IEND
64305 IF(KCHG(PYCOMP(K(IEND,2)),2).NE.0) THEN
64306 NJOIN=NJOIN+1
64307 IJOIN(NJOIN)=I
64308 ENDIF
64309 190 CONTINUE
64310 ENDIF
64311 CALL PYRESD(IP)
64312 CALL PYPREP(IBEG)
64313 IF(MINT(51).NE.0) RETURN
64314
64315C...Particle decay if unstable and allowed. Save long-lived particle
64316C...decays until second pass after Bose-Einstein effects.
64317 ELSEIF(KCHG(KC,2).EQ.0) THEN
64318 IF(MSTJ(21).GE.1.AND.MDCY(KC,1).GE.1.AND.(MSTJ(51).LE.0.OR.MBE
64319 & .EQ.2.OR.PMAS(KC,2).GE.PARJ(91).OR.IABS(K(IP,2)).EQ.311))
64320 & CALL PYDECY(IP)
64321
64322C...Decay products may develop a shower.
64323 IF(MSTJ(92).GT.0) THEN
64324 IP1=MSTJ(92)
64325 QMAX=SQRT(MAX(0D0,(P(IP1,4)+P(IP1+1,4))**2-(P(IP1,1)+P(IP1+1,
64326 & 1))**2-(P(IP1,2)+P(IP1+1,2))**2-(P(IP1,3)+P(IP1+1,3))**2))
64327 MINT(33)=0
64328 CALL PYSHOW(IP1,IP1+1,QMAX)
64329 CALL PYPREP(IP1)
64330 IF(MINT(51).NE.0) RETURN
64331 MSTJ(92)=0
64332 ELSEIF(MSTJ(92).LT.0) THEN
64333 IP1=-MSTJ(92)
64334 MINT(33)=0
64335 CALL PYSHOW(IP1,-3,P(IP,5))
64336 CALL PYPREP(IP1)
64337 IF(MINT(51).NE.0) RETURN
64338 MSTJ(92)=0
64339 ENDIF
64340
64341C...Jet fragmentation: string or independent fragmentation.
64342 ELSEIF(K(IP,1).EQ.1.OR.K(IP,1).EQ.2) THEN
64343 MFRAG=MSTJ(1)
64344 IF(MFRAG.GE.1.AND.K(IP,1).EQ.1) MFRAG=2
64345 IF(MSTJ(21).GE.2.AND.K(IP,1).EQ.2.AND.N.GT.IP) THEN
64346 IF(K(IP+1,1).EQ.1.AND.K(IP+1,3).EQ.K(IP,3).AND.
64347 & K(IP,3).GT.0.AND.K(IP,3).LT.IP) THEN
64348 IF(KCHG(PYCOMP(K(K(IP,3),2)),2).EQ.0) MFRAG=MIN(1,MFRAG)
64349 ENDIF
64350 ENDIF
64351 IF(MFRAG.EQ.1) CALL PYSTRF(IP)
64352 IF(MFRAG.EQ.2) CALL PYINDF(IP)
64353 IF(MFRAG.EQ.2.AND.K(IP,1).EQ.1) MCONS=0
64354 IF(MFRAG.EQ.2.AND.(MSTJ(3).LE.0.OR.MOD(MSTJ(3),5).EQ.0)) MCONS=0
64355 ENDIF
64356
64357C...Loop back if enough space left in PYJETS and no error abort.
64358 IF(MSTU(24).NE.0.AND.MSTU(21).GE.2) THEN
64359 ELSEIF(IP.LT.N.AND.N.LT.MSTU(4)-20-MSTU(32)) THEN
64360 GOTO 160
64361 ELSEIF(IP.LT.N) THEN
64362 CALL PYERRM(11,'(PYEXEC:) no more memory left in PYJETS')
64363 ENDIF
64364
64365C...Include simple Bose-Einstein effect parametrization if desired.
64366 IF(MBE.EQ.1.AND.MSTJ(51).GE.1) THEN
64367 CALL PYBOEI(NSAV)
64368 GOTO 150
64369 ENDIF
64370
64371C...Check that momentum, energy and charge were conserved.
64372 DO 210 I=1,N
64373 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 210
64374 DO 200 J=1,4
64375 PS(2,J)=PS(2,J)+P(I,J)
64376 200 CONTINUE
64377 PS(2,6)=PS(2,6)+PYCHGE(K(I,2))
64378 210 CONTINUE
64379 PDEV=(ABS(PS(2,1)-PS(1,1))+ABS(PS(2,2)-PS(1,2))+ABS(PS(2,3)-
64380 &PS(1,3))+ABS(PS(2,4)-PS(1,4)))/(1D0+ABS(PS(2,4))+ABS(PS(1,4)))
64381 IF(MCONS.EQ.1.AND.PDEV.GT.PARU(11)) CALL PYERRM(15,
64382 &'(PYEXEC:) four-momentum was not conserved')
64383 IF(MCONS.EQ.1.AND.ABS(PS(2,6)-PS(1,6)).GT.0.1D0) CALL PYERRM(15,
64384 &'(PYEXEC:) charge was not conserved')
64385
64386 RETURN
64387 END
64388
64389C*********************************************************************
64390
64391C...PYPREP
64392C...Rearranges partons along strings.
64393C...Special considerations for systems with junctions, with
64394C...possibility of junction-antijunction annihilation.
64395C...Allows small systems to collapse into one or two particles.
64396C...Checks flavours and colour singlet invariant masses.
64397
64398 SUBROUTINE PYPREP(IP)
64399
64400C...Double precision and integer declarations.
64401 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
64402 INTEGER PYK,PYCHGE,PYCOMP
64403C...Commonblocks.
64404 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
64405 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
64406 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
64407 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
64408 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
64409 COMMON/PYINT1/MINT(400),VINT(400)
64410C...The common block of colour tags.
64411 COMMON/PYCTAG/NCT,MCT(4000,2)
64412 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYINT1/,/PYCTAG/,
64413 &/PYPARS/
64414 DATA NERRPR/0/
64415 SAVE NERRPR
64416C...Local arrays.
64417 DIMENSION DPS(5),DPC(5),UE(3),PG(5),E1(3),E2(3),E3(3),E4(3),
64418 &ECL(3),IJUNC(10,0:4),IPIECE(30,0:4),KFEND(4),KFQ(4),
64419 &IJUR(4),PJU(4,6),IRNG(4,2),TJJ(2,5),T(5),PUL(3,5),
64420 &IJCP(0:6),TJUOLD(5)
64421 CHARACTER CHTMP*6
64422
64423C...Function to give four-product.
64424 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)
64425
64426C...Rearrange parton shower product listing along strings: begin loop.
64427 MSTU(24)=0
64428 NOLD=N
64429 I1=N
64430 NJUNC=0
64431 NPIECE=0
64432 NJJSTR=0
64433 MSTU32=MSTU(32)+1
64434 DO 100 I=MAX(1,IP),N
64435C...First store junction positions.
64436 IF(K(I,1).EQ.42) THEN
64437 NJUNC=NJUNC+1
64438 IJUNC(NJUNC,0)=I
64439 IJUNC(NJUNC,4)=0
64440 ENDIF
64441 100 CONTINUE
64442
64443 DO 250 MQGST=1,3
64444 DO 240 I=MAX(1,IP),N
64445C...Special treatment for junctions
64446 IF (K(I,1).LE.0) GOTO 240
64447 IF(K(I,1).EQ.42) THEN
64448C...MQGST=2: Look for junction-junction strings (not detected in the
64449C...main search below).
64450 IF (MQGST.EQ.2.AND.NPIECE.NE.3*NJUNC) THEN
64451 IF (NJJSTR.EQ.0) THEN
64452 NJJSTR = (3*NJUNC-NPIECE)/2
64453 ENDIF
64454C...Check how many already identified strings end on this junction
64455 ILC=0
64456 DO 110 J=1,NPIECE
64457 IF (IPIECE(J,4).EQ.I) ILC=ILC+1
64458 110 CONTINUE
64459C...If less than 3, remaining must be to another junction
64460 IF (ILC.LT.3) THEN
64461 IF (ILC.NE.2) THEN
64462C...Multiple j-j connections not handled yet.
64463 CALL PYERRM(2,
64464 & '(PYPREP:) Too many junction-junction strings.')
64465 MINT(51)=1
64466 RETURN
64467 ENDIF
64468C...The colour information in the junction is unreadable for the
64469C...colour space search further down in this routine, so we must
64470C...start on the colour mother of this junction and then "artificially"
64471C...prevent the colour mother from connecting here again.
64472 ITJUNC=MOD(K(I,4)/MSTU(5),MSTU(5))
64473 KCS=4
64474 IF (MOD(ITJUNC,2).EQ.0) KCS=5
64475C...Switch colour if the junction-junction leg is presumably a
64476C...junction mother leg rather than a junction daughter leg.
64477 IF (ITJUNC.GE.3) KCS=9-KCS
64478 IF (MINT(33).EQ.0) THEN
64479C...Find the unconnected leg and reorder junction daughter pointers so
64480C...MOD(K(I,4),MSTU(5)) always points to the junction-junction string
64481C...piece.
64482 IA=MOD(K(I,4),MSTU(5))
64483 IF (K(IA,KCS)/MSTU(5)**2.GE.2) THEN
64484 ITMP=MOD(K(I,5),MSTU(5))
64485 IF (K(ITMP,KCS)/MSTU(5)**2.GE.2) THEN
64486 ITMP=MOD(K(I,5)/MSTU(5),MSTU(5))
64487 K(I,5)=K(I,5)+(IA-ITMP)*MSTU(5)
64488 ELSE
64489 K(I,5)=K(I,5)+(IA-ITMP)
64490 ENDIF
64491 K(I,4)=K(I,4)+(ITMP-IA)
64492 IA=ITMP
64493 ENDIF
64494 IF (ITJUNC.LE.2) THEN
64495C...Beam baryon junction
64496 K(IA,KCS) = K(IA,KCS) + 2*MSTU(5)**2
64497 K(I,KCS) = K(I,KCS) + 1*MSTU(5)**2
64498C...Else 1 -> 2 decay junction
64499 ELSE
64500 K(IA,KCS) = K(IA,KCS) + MSTU(5)**2
64501 K(I,KCS) = K(I,KCS) + 2*MSTU(5)**2
64502 ENDIF
64503 I1BEG = I1
64504 NSTP = 0
64505 GOTO 170
64506C...Alternatively use colour tag information.
64507 ELSE
64508C...Find a final state parton with appropriate dangling colour tag.
64509 JCT=0
64510 IA=0
64511 IJUMO=K(I,3)
64512 DO 140 J1=MAX(1,IP),N
64513 IF (K(J1,1).NE.3) GOTO 140
64514C...Check for matching final-state colour tag
64515 IMATCH=0
64516 DO 120 J2=MAX(1,IP),N
64517 IF (K(J2,1).NE.3) GOTO 120
64518 IF (MCT(J1,KCS-3).EQ.MCT(J2,6-KCS)) IMATCH=1
64519 120 CONTINUE
64520 IF (IMATCH.EQ.1) GOTO 140
64521C...Check whether this colour tag belongs to the present junction
64522C...by seeing whether any parton with this colour tag has the same
64523C...mother as the junction.
64524 JCT=MCT(J1,KCS-3)
64525 IMATCH=0
64526 DO 130 J2=MINT(84)+1,N
64527 IMO2=K(J2,3)
64528C...First scattering partons have IMO1 = 3 and 4.
64529 IF (IMO2.EQ.MINT(83)+3.OR.IMO2.EQ.MINT(83)+4)
64530 & IMO2=IMO2-2
64531 IF (MCT(J2,KCS-3).EQ.JCT.AND.IMO2.EQ.IJUMO)
64532 & IMATCH=1
64533 130 CONTINUE
64534 IF (IMATCH.EQ.0) GOTO 140
64535 IA=J1
64536 140 CONTINUE
64537C...Check for junction-junction strings without intermediate final state
64538C...glue (not detected above).
64539 IF (IA.EQ.0) THEN
64540 DO 160 MJU=1,NJUNC
64541 IJU2=IJUNC(MJU,0)
64542 IF (IJU2.EQ.I) GOTO 160
64543 ITJU2=MOD(K(IJU2,4)/MSTU(5),MSTU(5))
64544C...Only opposite types of junctions can connect to each other.
64545 IF (MOD(ITJU2,2).EQ.MOD(ITJUNC,2)) GOTO 160
64546 IS=0
64547 DO 150 J=1,NPIECE
64548 IF (IPIECE(J,4).EQ.IJU2) IS=IS+1
64549 150 CONTINUE
64550 IF (IS.EQ.3) GOTO 160
64551 IB=I
64552 IA=IJU2
64553 160 CONTINUE
64554 ENDIF
64555C...Switch to other side of adjacent parton and step from there.
64556 KCS=9-KCS
64557 I1BEG = I1
64558 NSTP = 0
64559 GOTO 170
64560 ENDIF
64561 ELSE IF (ILC.NE.3) THEN
64562 ENDIF
64563 ENDIF
64564 ENDIF
64565
64566C...Look for coloured string endpoint, or (later) leftover gluon.
64567 IF(K(I,1).NE.3) GOTO 240
64568 KC=PYCOMP(K(I,2))
64569 IF(KC.EQ.0) GOTO 240
64570 KQ=KCHG(KC,2)
64571 IF(KQ.EQ.0.OR.(MQGST.LE.2.AND.KQ.EQ.2)) GOTO 240
64572
64573C...Pick up loose string end.
64574 KCS=4
64575 IF(KQ*ISIGN(1,K(I,2)).LT.0) KCS=5
64576 IA=I
64577 IB=I
64578 I1BEG=I1
64579 NSTP=0
64580 170 NSTP=NSTP+1
64581 IF(NSTP.GT.4*N) THEN
64582 CALL PYERRM(14,'(PYPREP:) caught in infinite loop')
64583 MINT(51)=1
64584 RETURN
64585 ENDIF
64586
64587C...Copy undecayed parton. Finished if reached string endpoint.
64588 IF(K(IA,1).EQ.3) THEN
64589 IF(I1.GE.MSTU(4)-MSTU32-5) THEN
64590 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
64591 MINT(51)=1
64592 MSTU(24)=1
64593 RETURN
64594 ENDIF
64595 I1=I1+1
64596 K(I1,1)=2
64597 IF(NSTP.GE.2.AND.KCHG(PYCOMP(K(IA,2)),2).NE.2) K(I1,1)=1
64598 K(I1,2)=K(IA,2)
64599 K(I1,3)=IA
64600 K(I1,4)=0
64601 K(I1,5)=0
64602 DO 180 J=1,5
64603 P(I1,J)=P(IA,J)
64604 V(I1,J)=V(IA,J)
64605 180 CONTINUE
64606 K(IA,1)=K(IA,1)+10
64607 IF(K(I1,1).EQ.1) GOTO 240
64608 ENDIF
64609
64610C...Also finished (for now) if reached junction; then copy to end.
64611 IF(K(IA,1).EQ.42) THEN
64612 NCOPY=I1-I1BEG
64613 IF(I1.GE.MSTU(4)-MSTU32-NCOPY-5) THEN
64614 CALL PYERRM(11,'(PYPREP:) no more memory left in PYJETS')
64615 MINT(51)=1
64616 MSTU(24)=1
64617 RETURN
64618 ENDIF
64619 IF (MQGST.LE.2.AND.NCOPY.NE.0) THEN
64620 DO 200 ICOPY=1,NCOPY
64621 DO 190 J=1,5
64622 K(MSTU(4)-MSTU32-ICOPY,J)=K(I1BEG+ICOPY,J)
64623 P(MSTU(4)-MSTU32-ICOPY,J)=P(I1BEG+ICOPY,J)
64624 V(MSTU(4)-MSTU32-ICOPY,J)=V(I1BEG+ICOPY,J)
64625 190 CONTINUE
64626 200 CONTINUE
64627 ENDIF
64628C...For junction-junction strings, find end leg and reorder junction
64629C...daughter pointers so MOD(K(I,4),MSTU(5)) always points to the
64630C...junction-junction string piece.
64631 IF (K(I,1).EQ.42.AND.MINT(33).EQ.0) THEN
64632 ITMP=MOD(K(IA,4),MSTU(5))
64633 IF (ITMP.NE.IB) THEN
64634 IF (MOD(K(IA,5),MSTU(5)).EQ.IB) THEN
64635 K(IA,5)=K(IA,5)+(ITMP-IB)
64636 ELSE
64637 K(IA,5)=K(IA,5)+(ITMP-IB)*MSTU(5)
64638 ENDIF
64639 K(IA,4)=K(IA,4)+(IB-ITMP)
64640 ENDIF
64641 ENDIF
64642 NPIECE=NPIECE+1
64643C...IPIECE:
64644C...0: endpoint in original ER
64645C...1:
64646C...2:
64647C...3: Parton immediately next to junction
64648C...4: Junction
64649 IPIECE(NPIECE,0)=I
64650 IPIECE(NPIECE,1)=MSTU32+1
64651 IPIECE(NPIECE,2)=MSTU32+NCOPY
64652 IPIECE(NPIECE,3)=IB
64653 IPIECE(NPIECE,4)=IA
64654 MSTU32=MSTU32+NCOPY
64655 I1=I1BEG
64656 GOTO 240
64657 ENDIF
64658
64659C...GOTO next parton in colour space.
64660 IB=IA
64661 IF (MINT(33).EQ.0) THEN
64662 IF(MOD(K(IB,KCS)/MSTU(5)**2,2).EQ.0.AND.MOD(K(IB,KCS),MSTU(5
64663 & )).NE.0) THEN
64664 IA=MOD(K(IB,KCS),MSTU(5))
64665 K(IB,KCS)=K(IB,KCS)+MSTU(5)**2
64666 MREV=0
64667 ELSE
64668 IF(K(IB,KCS).GE.2*MSTU(5)**2.OR.MOD(K(IB,KCS)/MSTU(5),
64669 & MSTU(5)).EQ.0) KCS=9-KCS
64670 IA=MOD(K(IB,KCS)/MSTU(5),MSTU(5))
64671 K(IB,KCS)=K(IB,KCS)+2*MSTU(5)**2
64672 MREV=1
64673 ENDIF
64674 IF(IA.LE.0.OR.IA.GT.N) THEN
64675 CALL PYERRM(12,'(PYPREP:) colour rearrangement failed')
64676 IF(NERRPR.LT.5) THEN
64677 NERRPR=NERRPR+1
64678 WRITE(MSTU(11),*) 'started at:', I
64679 WRITE(MSTU(11),*) 'ended going from',IB,' to',IA
64680 WRITE(MSTU(11),*) 'MQGST =',MQGST
64681 CALL PYLIST(4)
64682 ENDIF
64683 MINT(51)=1
64684 RETURN
64685 ENDIF
64686 IF(MOD(K(IA,4)/MSTU(5),MSTU(5)).EQ.IB.OR.MOD(K(IA,5)/MSTU(5)
64687 & ,MSTU(5)).EQ.IB) THEN
64688 IF(MREV.EQ.1) KCS=9-KCS
64689 IF(MOD(K(IA,KCS)/MSTU(5),MSTU(5)).NE.IB) KCS=9-KCS
64690 K(IA,KCS)=K(IA,KCS)+2*MSTU(5)**2
64691 ELSE
64692 IF(MREV.EQ.0) KCS=9-KCS
64693 IF(MOD(K(IA,KCS),MSTU(5)).NE.IB) KCS=9-KCS
64694 K(IA,KCS)=K(IA,KCS)+MSTU(5)**2
64695 ENDIF
64696 IF(IA.NE.I) GOTO 170
64697C...Use colour tag information
64698 ELSE
64699C...First create colour tags starting on IB if none already present.
64700 IF (MCT(IB,KCS-3).EQ.0) THEN
64701 CALL PYCTTR(IB,KCS,IB)
64702 IF(MINT(51).NE.0) RETURN
64703 ENDIF
64704 JCT=MCT(IB,KCS-3)
64705 IFOUND=0
64706C...Find final state tag partner
64707 DO 210 IT=MAX(1,IP),N
64708 IF (IT.EQ.IB) GOTO 210
64709 IF (MCT(IT,6-KCS).EQ.JCT.AND.K(IT,1).LT.10.AND.K(IT,1).GT
64710 & .0) THEN
64711 IFOUND=IFOUND+1
64712 IA=IT
64713 ENDIF
64714 210 CONTINUE
64715C...Just copy and goto next if exactly one partner found.
64716 IF (IFOUND.EQ.1) THEN
64717 GOTO 170
64718C...When no match found, match is presumably junction.
64719 ELSEIF (IFOUND.EQ.0.AND.MQGST.LE.2) THEN
64720C...Check whether this colour tag matches a junction
64721C...by seeing whether any parton with this colour tag has the same
64722C...mother as a junction.
64723C...NB: Only type 1 and 2 junctions handled presently.
64724 DO 230 IJU=1,NJUNC
64725 IJUMO=K(IJUNC(IJU,0),3)
64726 ITJUNC=MOD(K(IJUNC(IJU,0),4)/MSTU(5),MSTU(5))
64727C...Colours only connect to junctions, anti-colours to antijunctions:
64728 IF (MOD(ITJUNC+1,2)+1.NE.KCS-3) GOTO 230
64729 IMATCH=0
64730 DO 220 J1=MAX(1,IP),N
64731 IF (K(J1,1).LE.0) GOTO 220
64732C...First scattering partons have IMO1 = 3 and 4.
64733 IMO=K(J1,3)
64734 IF (IMO.EQ.MINT(83)+3.OR.IMO.EQ.MINT(83)+4)
64735 & IMO=IMO-2
64736 IF (MCT(J1,KCS-3).EQ.JCT.AND.IMO.EQ.IJUMO.AND.MOD(K(J1
64737 & ,3+ITJUNC)/MSTU(5),MSTU(5)).EQ.IJUNC(IJU,0))
64738 & IMATCH=1
64739C...Attempt at handling type > 3 junctions also. Not tested.
64740 IF (ITJUNC.GE.3.AND.MCT(J1,6-KCS).EQ.JCT.AND.IMO.EQ
64741 & .IJUMO) IMATCH=1
64742 220 CONTINUE
64743 IF (IMATCH.EQ.0) GOTO 230
64744 IA=IJUNC(IJU,0)
64745 IFOUND=IFOUND+1
64746 230 CONTINUE
64747
64748 IF (IFOUND.EQ.1) THEN
64749 GOTO 170
64750 ELSEIF (IFOUND.EQ.0) THEN
64751 WRITE(CHTMP,'(I6)') JCT
64752 CALL PYERRM(12,'(PYPREP:) no matching colour tag: '
64753 & //CHTMP)
64754 IF(NERRPR.LT.5) THEN
64755 NERRPR=NERRPR+1
64756 CALL PYLIST(4)
64757 ENDIF
64758 MINT(51)=1
64759 RETURN
64760 ENDIF
64761 ELSEIF (IFOUND.GE.2) THEN
64762 WRITE(CHTMP,'(I6)') JCT
64763 CALL PYERRM(12
64764 & ,'(PYPREP:) too many occurences of colour line: '//
64765 & CHTMP)
64766 IF(NERRPR.LT.5) THEN
64767 NERRPR=NERRPR+1
64768 CALL PYLIST(4)
64769 ENDIF
64770 MINT(51)=1
64771 RETURN
64772 ENDIF
64773 ENDIF
64774 K(I1,1)=1
64775 240 CONTINUE
64776 250 CONTINUE
64777
64778C...Junction systems remain.
64779 IJU=0
64780 IJUS=0
64781 IJUCNT=0
64782 MREV=0
64783 IJJSTR=0
64784 260 IJUCNT=IJUCNT+1
64785 IF (IJUCNT.LE.NJUNC) THEN
64786C...If we are not processing a j-j string, treat this junction as new.
64787 IF (IJJSTR.EQ.0) THEN
64788 IJU=IJUNC(IJUCNT,0)
64789 MREV=0
64790C...If junction has already been read, ignore it.
64791 IF (IJUNC(IJUCNT,4).EQ.1) GOTO 260
64792C...If we are on a j-j string, goto second j-j junction.
64793 ELSE
64794 IJUCNT=IJUCNT-1
64795 IJU=IJUS
64796 ENDIF
64797C...Mark selected junction read.
64798 DO 270 J=1,NJUNC
64799 IF (IJUNC(J,0).EQ.IJU) IJUNC(J,4)=1
64800 270 CONTINUE
64801C...Determine junction type
64802 ITJUNC = MOD(K(IJU,4)/MSTU(5),MSTU(5))
64803C...Type 1 and 2 junctions: ~chi -> q q q, ~chi -> qbar,qbar,qbar
64804C...Type 3 and 4 junctions: ~qbar -> q q , ~q -> qbar qbar
64805C...Type 5 and 6 junctions: ~g -> q q q, ~g -> qbar qbar qbar
64806 IF (ITJUNC.GE.1.AND.ITJUNC.LE.6) THEN
64807 IHK=0
64808 280 IHK=IHK+1
64809C...Find which quarks belong to given junction.
64810 IHF=0
64811 DO 290 IPC=1,NPIECE
64812 IF (IPIECE(IPC,4).EQ.IJU) THEN
64813 IHF=IHF+1
64814 IF (IHF.EQ.IHK) IEND=IPIECE(IPC,3)
64815 ENDIF
64816 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJU) IEND=IPIECE(IPC,3)
64817 290 CONTINUE
64818C...IHK = 3 is special. Either normal string piece, or j-j string.
64819 IF(IHK.EQ.3) THEN
64820 IF (MREV.NE.1) THEN
64821 DO 300 IPC=1,NPIECE
64822C...If there is a j-j string starting on the present junction which has
64823C...zero length, insert next junction immediately.
64824 IF (IPIECE(IPC,0).EQ.IJU.AND.K(IPIECE(IPC,4),1)
64825 & .EQ.42.AND.IPIECE(IPC,1)-1-IPIECE(IPC,2).EQ.0) THEN
64826 IJJSTR = 1
64827 GOTO 340
64828 ENDIF
64829 300 CONTINUE
64830 MREV = 1
64831C...If MREV is 1 and IHK is 3 we are finished with this system.
64832 ELSE
64833 MREV=0
64834 GOTO 260
64835 ENDIF
64836 ENDIF
64837
64838C...If we've gotten this far, then either IHK < 3, or
64839C...an interjunction string exists, or just a third normal string.
64840 IJUNC(IJUCNT,IHK)=0
64841 IJJSTR = 0
64842C..Order pieces belonging to this junction. Also look for j-j.
64843 DO 310 IPC=1,NPIECE
64844 IF (IPIECE(IPC,3).EQ.IEND) IJUNC(IJUCNT,IHK)=IPC
64845 IF (IHK.EQ.3.AND.IPIECE(IPC,0).EQ.IJUNC(IJUCNT,0)
64846 & .AND.K(IPIECE(IPC,4),1).EQ.42) THEN
64847 IJUNC(IJUCNT,IHK)=IPC
64848 IJJSTR = 1
64849 MREV = 0
64850 ENDIF
64851 310 CONTINUE
64852C...Copy back chains in proper order. MREV=0/1 : descending/ascending
64853 IPC=IJUNC(IJUCNT,IHK)
64854C...Temporary solution to cover for bug.
64855 IF(IPC.LE.0) THEN
64856 CALL PYERRM(12,'(PYPREP:) fails to hook up junctions')
64857 MINT(51)=1
64858 RETURN
64859 ENDIF
64860 DO 330 ICP=IPIECE(IPC,1+MREV),IPIECE(IPC,2-MREV),1-2*MREV
64861 I1=I1+1
64862 DO 320 J=1,5
64863 K(I1,J)=K(MSTU(4)-ICP,J)
64864 P(I1,J)=P(MSTU(4)-ICP,J)
64865 V(I1,J)=V(MSTU(4)-ICP,J)
64866 320 CONTINUE
64867 330 CONTINUE
64868 K(I1,1)=2
64869C...Mark last quark.
64870 IF (MREV.EQ.1.AND.IHK.GE.2) K(I1,1)=1
64871C...Do not insert junctions at wrong places.
64872 IF(IHK.LT.2.OR.MREV.NE.0) GOTO 360
64873C...Insert junction.
64874 340 IJUS = IJU
64875 IF (IHK.EQ.3) THEN
64876C...Shift to end junction if a j-j string has been processed.
64877 IF (IJJSTR.NE.0) IJUS = IPIECE(IPC,4)
64878 MREV= 1
64879 ENDIF
64880 I1=I1+1
64881 DO 350 J=1,5
64882 K(I1,J)=0
64883 P(I1,J)=0.
64884 V(I1,J)=0.
64885 350 CONTINUE
64886 K(I1,1)=41
64887 K(IJUS,1)=K(IJUS,1)+10
64888 K(I1,2)=K(IJUS,2)
64889 K(I1,3)=IJUS
64890 360 IF (IHK.LT.3) GOTO 280
64891 ELSE
64892 CALL PYERRM(12,'(PYPREP:) Unknown junction type')
64893 MINT(51)=1
64894 RETURN
64895 ENDIF
64896 IF (IJUCNT.NE.NJUNC) GOTO 260
64897 ENDIF
64898 N=I1
64899
64900C...Rearrange three strings from junction, e.g. in case one has been
64901C...shortened by shower, so the last is the largest-energy one.
64902 IF(NJUNC.GE.1) THEN
64903C...Find systems with exactly one junction.
64904 MJUN1=0
64905 NBEG=NOLD+1
64906 DO 470 I=NOLD+1,N
64907 IF(K(I,1).NE.1.AND.K(I,1).NE.41) THEN
64908 ELSEIF(K(I,1).EQ.41) THEN
64909 MJUN1=MJUN1+1
64910 ELSEIF(K(I,1).EQ.1.AND.MJUN1.NE.1) THEN
64911 MJUN1=0
64912 NBEG=I+1
64913 ELSE
64914 NEND=I
64915C...Sum up energy-momentum in each junction string.
64916 DO 370 J=1,5
64917 PJU(1,J)=0D0
64918 PJU(2,J)=0D0
64919 PJU(3,J)=0D0
64920 370 CONTINUE
64921 NJU=0
64922 DO 390 I1=NBEG,NEND
64923 IF(K(I1,2).NE.21) THEN
64924 NJU=NJU+1
64925 IJUR(NJU)=I1
64926 ENDIF
64927 DO 380 J=1,5
64928 PJU(MIN(NJU,3),J)=PJU(MIN(NJU,3),J)+P(I1,J)
64929 380 CONTINUE
64930 390 CONTINUE
64931C...Find which of them has highest energy (minus mass) in rest frame.
64932 DO 400 J=1,5
64933 PJU(4,J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
64934 400 CONTINUE
64935 PMJU=SQRT(MAX(0D0,PJU(4,4)**2-PJU(4,1)**2-PJU(4,2)**2-
64936 & PJU(4,3)**2))
64937 DO 410 I2=1,3
64938 PJU(I2,6)=(PJU(4,4)*PJU(I2,4)-PJU(4,1)*PJU(I2,1)-
64939 & PJU(4,2)*PJU(I2,2)-PJU(4,3)*PJU(I2,3))/PMJU-PJU(I2,5)
64940 410 CONTINUE
64941 IF(PJU(3,6).LT.MIN(PJU(1,6),PJU(2,6))) THEN
64942C...Decide how to rearrange so that new last has highest energy.
64943 IF(PJU(1,6).LT.PJU(2,6)) THEN
64944 IRNG(1,1)=IJUR(1)
64945 IRNG(1,2)=IJUR(2)-1
64946 IRNG(2,1)=IJUR(4)
64947 IRNG(2,2)=IJUR(3)+1
64948 IRNG(4,1)=IJUR(3)-1
64949 IRNG(4,2)=IJUR(2)
64950 ELSE
64951 IRNG(1,1)=IJUR(4)
64952 IRNG(1,2)=IJUR(3)+1
64953 IRNG(2,1)=IJUR(2)
64954 IRNG(2,2)=IJUR(3)-1
64955 IRNG(4,1)=IJUR(2)-1
64956 IRNG(4,2)=IJUR(1)
64957 ENDIF
64958 IRNG(3,1)=IJUR(3)
64959 IRNG(3,2)=IJUR(3)
64960C...Copy in correct order below bottom of current event record.
64961 I2=N
64962 DO 440 II=1,4
64963 DO 430 I1=IRNG(II,1),IRNG(II,2),
64964 & ISIGN(1,IRNG(II,2)-IRNG(II,1))
64965 I2=I2+1
64966 IF(I2.GE.MSTU(4)-MSTU32-5) THEN
64967 CALL PYERRM(11,
64968 & '(PYPREP:) no more memory left in PYJETS')
64969 MINT(51)=1
64970 MSTU(24)=1
64971 RETURN
64972 ENDIF
64973 DO 420 J=1,5
64974 K(I2,J)=K(I1,J)
64975 P(I2,J)=P(I1,J)
64976 V(I2,J)=V(I1,J)
64977 420 CONTINUE
64978 IF(K(I2,1).EQ.1) K(I2,1)=2
64979 430 CONTINUE
64980 440 CONTINUE
64981 K(I2,1)=1
64982C...Copy back up, overwriting but now in correct order.
64983 DO 460 I1=NBEG,NEND
64984 I2=I1-NBEG+N+1
64985 DO 450 J=1,5
64986 K(I1,J)=K(I2,J)
64987 P(I1,J)=P(I2,J)
64988 V(I1,J)=V(I2,J)
64989 450 CONTINUE
64990 460 CONTINUE
64991 ENDIF
64992 MJUN1=0
64993 NBEG=I+1
64994 ENDIF
64995 470 CONTINUE
64996
64997C...Check whether q-q-j-j-qbar-qbar systems should be collapsed
64998C...to two q-qbar systems.
64999C...(MSTJ(19)=1 forces q-q-j-j-qbar-qbar.)
65000 IF (MSTJ(19).NE.1) THEN
65001 MJUN1 = 0
65002 JJGLUE = 0
65003 NBEG = NOLD+1
65004C...Force collapse when MSTJ(19)=2.
65005 IF (MSTJ(19).EQ.2) THEN
65006 DELMJJ = 1D9
65007 DELMQQ = 0D0
65008 ENDIF
65009C...Find systems with exactly two junctions.
65010 DO 700 I=NOLD+1,N
65011C...Count junctions
65012 IF (K(I,1).EQ.41) THEN
65013 MJUN1 = MJUN1+1
65014C...Check for interjunction gluons
65015 IF (MJUN1.EQ.2.AND.K(I-1,1).NE.41) THEN
65016 JJGLUE = 1
65017 ENDIF
65018 ELSEIF(K(I,1).EQ.1.AND.(MJUN1.NE.2)) THEN
65019C...If end of system reached with either zero or one junction, restart
65020C...with next system.
65021 MJUN1 = 0
65022 JJGLUE = 0
65023 NBEG = I+1
65024 ELSEIF(K(I,1).EQ.1) THEN
65025C...If end of system reached with exactly two junctions, compute string
65026C...length measure for the (q-q-j-j-qbar-qbar) topology and compare with
65027C...length measure for the (q-qbar)(q-qbar) topology.
65028 NEND=I
65029C...Loop down through chain.
65030 ISID=0
65031 DO 480 I1=NBEG,NEND
65032C...Store string piece division locations in event record
65033 IF (K(I1,2).NE.21) THEN
65034 ISID = ISID+1
65035 IJCP(ISID) = I1
65036 ENDIF
65037 480 CONTINUE
65038C...Randomly choose between (1,3)(2,4) and (1,4)(2,3) topologies.
65039 ISW=0
65040 IF (PYR(0).LT.0.5D0) ISW=1
65041C...Randomly choose which qqbar string gets the jj gluons.
65042 IGS=1
65043 IF (PYR(0).GT.0.5D0) IGS=2
65044C...Only compute string lengths when no topology forced.
65045 IF (MSTJ(19).EQ.0) THEN
65046C...Repeat following for each junction
65047 DO 570 IJU=1,2
65048C...Initialize iterative procedure for finding JRF
65049 IJRFIT=0
65050 DO 490 IX=1,3
65051 TJUOLD(IX)=0D0
65052 490 CONTINUE
65053 TJUOLD(4)=1D0
65054C...Start iteration. Sum up momenta in string pieces
65055 500 DO 540 IJS=1,3
65056C...JD=-1 for first junction, +1 for second junction.
65057C...Find out where piece starts and ends and which direction to go.
65058 JD=2*IJU-3
65059 IF (IJS.LE.2) THEN
65060 IA = IJCP((IJU-1)*7 - JD*(IJS+1)) + JD
65061 IB = IJCP((IJU-1)*7 - JD*IJS)
65062 ELSEIF (IJS.EQ.3) THEN
65063 JD =-JD
65064 IA = IJCP((IJU-1)*7 + JD*(IJS)) + JD
65065 IB = IJCP((IJU-1)*7 + JD*(IJS+3))
65066 ENDIF
65067C...Initialize junction pull 4-vector.
65068 DO 510 J=1,5
65069 PUL(IJS,J)=0D0
65070 510 CONTINUE
65071C...Initialize weight
65072 PWT = 0D0
65073 PWTOLD = 0D0
65074C...Sum up (weighted) momenta along each string piece
65075 DO 530 ISP=IA,IB,JD
65076C...If present parton not last in chain
65077 IF (ISP.NE.IA.AND.ISP.NE.IB) THEN
65078C...If last parton was a junction, store present weight
65079 IF (K(ISP-JD,2).EQ.88) THEN
65080 PWTOLD = PWT
65081C...If last parton was a quark, reset to stored weight.
65082 ELSEIF (K(ISP-JD,2).NE.21) THEN
65083 PWT = PWTOLD
65084 ENDIF
65085 ENDIF
65086C...Skip next parton if weight already large
65087 IF (PWT.GT.10D0) GOTO 530
65088C...Compute momentum in TJUOLD frame:
65089 TDP=TJUOLD(1)*P(ISP,1)+TJUOLD(2)*P(ISP,2)+TJUOLD(3
65090 & )*P(ISP,3)
65091 BFC=TDP/(1D0+TJUOLD(4))+P(ISP,4)
65092 DO 520 J=1,3
65093 TMP=P(ISP,J)+TJUOLD(J)*BFC
65094 PUL(IJS,J)=PUL(IJS,J)+TMP*EXP(-PWT)
65095 520 CONTINUE
65096C...Boosted energy
65097 TMP=TJUOLD(4)*P(ISP,4)+TDP
65098 PUL(IJS,4)=PUL(IJS,J)+TMP*EXP(-PWT)
65099C...Update weight
65100 PWT=PWT+TMP/PARJ(48)
65101C...Put |p| rather than m in 5th slot
65102 PUL(IJS,5)=SQRT(PUL(IJS,1)**2+PUL(IJS,2)**2
65103 & +PUL(IJS,3)**2)
65104 530 CONTINUE
65105 540 CONTINUE
65106C...Compute boost
65107 IJRFIT=IJRFIT+1
65108 CALL PYJURF(PUL,T)
65109C...Combine new boost (T) with old boost (TJUOLD)
65110 TMP=T(1)*TJUOLD(1)+T(2)*TJUOLD(2)+T(3)*TJUOLD(3)
65111 DO 550 IX=1,3
65112 TJUOLD(IX)=T(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+T(4
65113 & ))
65114 550 CONTINUE
65115 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)
65116 & **2)
65117C...If last boost small, accept JRF, else iterate.
65118C...Also prevent possibility of infinite loop.
65119 IF (ABS((T(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
65120 & IJRFIT.LT.MSTJ(18))THEN
65121 GOTO 500
65122 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
65123 CALL PYERRM(1,'(PYPREP:) failed to converge on JRF')
65124 ENDIF
65125C...Store final boost, with change of sign since TJJ motion vector.
65126 DO 560 IX=1,3
65127 TJJ(IJU,IX)=-TJUOLD(IX)
65128 560 CONTINUE
65129 TJJ(IJU,4)=SQRT(1D0+TJJ(IJU,1)**2+TJJ(IJU,2)**2
65130 & +TJJ(IJU,3)**2)
65131 570 CONTINUE
65132C...String length measure for (q-qbar)(q-qbar) topology.
65133C...Note only momenta of nearest partons used (since rest of system
65134C...identical).
65135 IF (JJGLUE.EQ.0) THEN
65136 DELMQQ=4D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)*FOUR(IJCP(3)
65137 & -1,IJCP(5-ISW)+1)
65138 ELSE
65139C...Put jj gluons on selected string (IGS selected randomly above).
65140 IF (IGS.EQ.1) THEN
65141 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
65142 & ,IJCP(4+ISW)+1)*FOUR(IJCP(3)-1,IJCP(5-ISW)+1)
65143 ELSE
65144 DELMQQ=8D0*FOUR(IJCP(2)-1,IJCP(4+ISW)+1)
65145 & *FOUR(IJCP(3)-1,IJCP(4)-1)*FOUR(IJCP(3)+1
65146 & ,IJCP(5-ISW)+1)
65147 ENDIF
65148 ENDIF
65149C...String length measure for q-q-j-j-q-q topology.
65150 T1G1=0D0
65151 T2G2=0D0
65152 T1T2=0D0
65153 T1P1=0D0
65154 T1P2=0D0
65155 T2P3=0D0
65156 T2P4=0D0
65157 ISGN=-1
65158C...Note only momenta of nearest partons used (since rest of system
65159C...identical).
65160 DO 580 IX=1,4
65161 IF (IX.EQ.4) ISGN=1
65162 T1P1=T1P1+ISGN*TJJ(1,IX)*P(IJCP(2)-1,IX)
65163 T1P2=T1P2+ISGN*TJJ(1,IX)*P(IJCP(3)-1,IX)
65164 T2P3=T2P3+ISGN*TJJ(2,IX)*P(IJCP(4)+1,IX)
65165 T2P4=T2P4+ISGN*TJJ(2,IX)*P(IJCP(5)+1,IX)
65166 IF (JJGLUE.EQ.0) THEN
65167C...Junction motion vector dot product gives length when inter-junction
65168C...gluons absent.
65169 T1T2=T1T2+ISGN*TJJ(1,IX)*TJJ(2,IX)
65170 ELSE
65171C...Junction motion vector dot products with gluon momenta give length
65172C...when inter-junction gluons present.
65173 T1G1=T1G1+ISGN*TJJ(1,IX)*P(IJCP(3)+1,IX)
65174 T2G2=T2G2+ISGN*TJJ(2,IX)*P(IJCP(4)-1,IX)
65175 ENDIF
65176 580 CONTINUE
65177 DELMJJ=16D0*T1P1*T1P2*T2P3*T2P4
65178 IF (JJGLUE.EQ.0) THEN
65179 DELMJJ=DELMJJ*(T1T2+SQRT(T1T2**2-1))
65180 ELSE
65181 DELMJJ=DELMJJ*4D0*T1G1*T2G2
65182 ENDIF
65183 ENDIF
65184C...If delmjj > delmqq collapse string system to q-qbar q-qbar
65185C...(Always the case for MSTJ(19)=2 due to initialization above)
65186 IF (DELMJJ.GT.DELMQQ) THEN
65187C...Put new system at end of event record
65188 NCOP=N
65189 DO 650 IST=1,2
65190 DO 600 ICOP=IJCP(IST),IJCP(IST+1)-1
65191 NCOP=NCOP+1
65192 DO 590 IX=1,5
65193 P(NCOP,IX)=P(ICOP,IX)
65194 K(NCOP,IX)=K(ICOP,IX)
65195 590 CONTINUE
65196 600 CONTINUE
65197 IF (JJGLUE.NE.0.AND.IST.EQ.IGS) THEN
65198C...Insert inter-junction gluon string piece (reversed)
65199 NJJGL=0
65200 DO 620 ICOP=IJCP(4)-1,IJCP(3)+1,-1
65201 NJJGL=NJJGL+1
65202 NCOP=NCOP+1
65203 DO 610 IX=1,5
65204 P(NCOP,IX)=P(ICOP,IX)
65205 K(NCOP,IX)=K(ICOP,IX)
65206 610 CONTINUE
65207 620 CONTINUE
65208 ENDIF
65209 IFC=-2*IST+3
65210 DO 640 ICOP=IJCP(IST+IFC*ISW+3)+1,IJCP(IST+IFC*ISW+4)
65211 NCOP=NCOP+1
65212 DO 630 IX=1,5
65213 P(NCOP,IX)=P(ICOP,IX)
65214 K(NCOP,IX)=K(ICOP,IX)
65215 630 CONTINUE
65216 640 CONTINUE
65217 K(NCOP,1)=1
65218 650 CONTINUE
65219C...Copy system back in right order
65220 DO 670 ICOP=NBEG,NEND-2
65221 DO 660 IX=1,5
65222 P(ICOP,IX)=P(N+ICOP-NBEG+1,IX)
65223 K(ICOP,IX)=K(N+ICOP-NBEG+1,IX)
65224 660 CONTINUE
65225 670 CONTINUE
65226C...Shift down rest of event record
65227 DO 690 ICOP=NEND+1,N
65228 DO 680 IX=1,5
65229 P(ICOP-2,IX)=P(ICOP,IX)
65230 K(ICOP-2,IX)=K(ICOP,IX)
65231 680 CONTINUE
65232 690 CONTINUE
65233C...Update length of event record.
65234 N=N-2
65235 ENDIF
65236 MJUN1=0
65237 NBEG=I+1
65238 ENDIF
65239 700 CONTINUE
65240 ENDIF
65241 ENDIF
65242
65243C...Done if no checks on small-mass systems.
65244 IF(MSTJ(14).LT.0) RETURN
65245 IF(MSTJ(14).EQ.0) GOTO 1140
65246
65247C...Find lowest-mass colour singlet jet system.
65248 NS=N
65249 710 NSIN=N-NS
65250 PDMIN=1D0+PARJ(32)
65251 IC=0
65252 DO 770 I=MAX(1,IP),N
65253 IF(K(I,1).NE.1.AND.K(I,1).NE.2) THEN
65254 ELSEIF(K(I,1).EQ.2.AND.IC.EQ.0) THEN
65255 NSIN=NSIN+1
65256 IC=I
65257 DO 720 J=1,4
65258 DPS(J)=P(I,J)
65259 720 CONTINUE
65260 MSTJ(93)=1
65261 DPS(5)=PYMASS(K(I,2))
65262 ELSEIF(K(I,1).EQ.2.AND.K(I,2).NE.21) THEN
65263 DO 730 J=1,4
65264 DPS(J)=DPS(J)+P(I,J)
65265 730 CONTINUE
65266 MSTJ(93)=1
65267 DPS(5)=DPS(5)+PYMASS(K(I,2))
65268 ELSEIF(K(I,1).EQ.2) THEN
65269 DO 740 J=1,4
65270 DPS(J)=DPS(J)+P(I,J)
65271 740 CONTINUE
65272 ELSEIF(IC.NE.0.AND.KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
65273 DO 750 J=1,4
65274 DPS(J)=DPS(J)+P(I,J)
65275 750 CONTINUE
65276 MSTJ(93)=1
65277 DPS(5)=DPS(5)+PYMASS(K(I,2))
65278 PD=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))-
65279 & DPS(5)
65280 IF(PD.LT.PDMIN) THEN
65281 PDMIN=PD
65282 DO 760 J=1,5
65283 DPC(J)=DPS(J)
65284 760 CONTINUE
65285 IC1=IC
65286 IC2=I
65287 ENDIF
65288 IC=0
65289 ELSE
65290 NSIN=NSIN+1
65291 ENDIF
65292 770 CONTINUE
65293
65294C...Done if lowest-mass system above threshold for string frag.
65295 IF(PDMIN.GE.PARJ(32)) GOTO 1140
65296
65297C...Fill small-mass system as cluster.
65298 NSAV=N
65299 PECM=SQRT(MAX(0D0,DPC(4)**2-DPC(1)**2-DPC(2)**2-DPC(3)**2))
65300 K(N+1,1)=11
65301 K(N+1,2)=91
65302 K(N+1,3)=IC1
65303 P(N+1,1)=DPC(1)
65304 P(N+1,2)=DPC(2)
65305 P(N+1,3)=DPC(3)
65306 P(N+1,4)=DPC(4)
65307 P(N+1,5)=PECM
65308
65309C...Set up history, assuming cluster -> 2 hadrons.
65310 NBODY=2
65311 K(N+1,4)=N+2
65312 K(N+1,5)=N+3
65313 K(N+2,1)=1
65314 K(N+3,1)=1
65315 IF(MSTU(16).NE.2) THEN
65316 K(N+2,3)=N+1
65317 K(N+3,3)=N+1
65318 ELSE
65319 K(N+2,3)=IC1
65320 K(N+3,3)=IC2
65321 ENDIF
65322 K(N+2,4)=0
65323 K(N+3,4)=0
65324 K(N+2,5)=0
65325 K(N+3,5)=0
65326 V(N+1,5)=0D0
65327 V(N+2,5)=0D0
65328 V(N+3,5)=0D0
65329
65330C...Find total flavour content - complicated by presence of junctions.
65331 NQ=0
65332 NDIQ=0
65333 DO 780 I=IC1,IC2
65334 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.K(I,2).NE.21) THEN
65335 NQ=NQ+1
65336 KFQ(NQ)=K(I,2)
65337 IF(IABS(K(I,2)).GT.1000) NDIQ=NDIQ+1
65338 ENDIF
65339 780 CONTINUE
65340
65341C...If several diquarks, split up one to give even number of flavours.
65342 IF(NQ.EQ.3.AND.NDIQ.GE.2) THEN
65343 I1=3
65344 IF(IABS(KFQ(3)).LT.1000) I1=1
65345 KFQ(4)=ISIGN(MOD(IABS(KFQ(I1))/100,10),KFQ(I1))
65346 KFQ(I1)=KFQ(I1)/1000
65347 NQ=4
65348 NDIQ=NDIQ-1
65349 ENDIF
65350
65351C...If four quark ends, join two to diquark.
65352 IF(NQ.EQ.4.AND.NDIQ.EQ.0) THEN
65353 I1=1
65354 I2=2
65355 IF(KFQ(I1)*KFQ(I2).LT.0) I2=3
65356 IF(I2.EQ.3.AND.KFQ(I1)*KFQ(I2).LT.0) I2=4
65357 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
65358 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
65359 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
65360 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
65361 KFQ(I2)=KFQ(4)
65362 NQ=3
65363 NDIQ=1
65364 ENDIF
65365
65366C...If two quark ends, plus quark or diquark, join quarks to diquark.
65367 IF(NQ.EQ.3) THEN
65368 I1=1
65369 I2=2
65370 IF(IABS(KFQ(I1)).GT.1000) I1=3
65371 IF(IABS(KFQ(I2)).GT.1000) I2=3
65372 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
65373 IF(KFQ(I1).EQ.KFQ(I2)) KFLS=3
65374 KFQ(I1)=ISIGN(1000*MAX(IABS(KFQ(I1)),IABS(KFQ(I2)))+
65375 & 100*MIN(IABS(KFQ(I1)),IABS(KFQ(I2)))+KFLS,KFQ(I1))
65376 KFQ(I2)=KFQ(3)
65377 NQ=2
65378 NDIQ=NDIQ+1
65379 ENDIF
65380
65381C...Form two particles from flavours of lowest-mass system, if feasible.
65382 NTRY = 0
65383 790 NTRY = NTRY + 1
65384
65385C...Open string with two specified endpoint flavours.
65386 IF(NQ.EQ.2) THEN
65387 KC1=PYCOMP(KFQ(1))
65388 KC2=PYCOMP(KFQ(2))
65389 IF(KC1.EQ.0.OR.KC2.EQ.0) GOTO 1140
65390 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
65391 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
65392 IF(KQ1+KQ2.NE.0) GOTO 1140
65393C...Start with qq, if there is one. Only allow for rank 1 popcorn meson
65394 800 K1=KFQ(1)
65395 IF(IABS(KFQ(2)).GT.1000) K1=KFQ(2)
65396 MSTU(125)=0
65397 CALL PYDCYK(K1,0,KFLN,K(N+2,2))
65398 CALL PYDCYK(KFQ(1)+KFQ(2)-K1,-KFLN,KFLDMP,K(N+3,2))
65399 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 800
65400
65401C...Open string with four specified flavours.
65402 ELSEIF(NQ.EQ.4) THEN
65403 KC1=PYCOMP(KFQ(1))
65404 KC2=PYCOMP(KFQ(2))
65405 KC3=PYCOMP(KFQ(3))
65406 KC4=PYCOMP(KFQ(4))
65407 IF(KC1.EQ.0.OR.KC2.EQ.0.OR.KC3.EQ.0.OR.KC4.EQ.0) GOTO 1140
65408 KQ1=KCHG(KC1,2)*ISIGN(1,KFQ(1))
65409 KQ2=KCHG(KC2,2)*ISIGN(1,KFQ(2))
65410 KQ3=KCHG(KC3,2)*ISIGN(1,KFQ(3))
65411 KQ4=KCHG(KC4,2)*ISIGN(1,KFQ(4))
65412 IF(KQ1+KQ2+KQ3+KQ4.NE.0) GOTO 1140
65413C...Combine flavours pairwise to form two hadrons.
65414 810 I1=1
65415 I2=2
65416 IF(KQ1*KQ2.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
65417 & IABS(KFQ(2)).GT.1000)) I2=3
65418 IF(I2.EQ.3.AND.(KQ1*KQ3.GT.0.OR.(IABS(KFQ(1)).GT.1000.AND.
65419 & IABS(KFQ(3)).GT.1000))) I2=4
65420 I3=3
65421 IF(I2.EQ.3) I3=2
65422 I4=10-I1-I2-I3
65423 CALL PYDCYK(KFQ(I1),KFQ(I2),KFLDMP,K(N+2,2))
65424 CALL PYDCYK(KFQ(I3),KFQ(I4),KFLDMP,K(N+3,2))
65425 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 810
65426
65427C...Closed string.
65428 ELSE
65429 IF(IABS(K(IC2,2)).NE.21) GOTO 1140
65430C...No room for popcorn mesons in closed string -> 2 hadrons.
65431 MSTU(125)=0
65432 820 CALL PYDCYK(1+INT((2D0+PARJ(2))*PYR(0)),0,KFLN,KFDMP)
65433 CALL PYDCYK(KFLN,0,KFLM,K(N+2,2))
65434 CALL PYDCYK(-KFLN,-KFLM,KFLDMP,K(N+3,2))
65435 IF(K(N+2,2).EQ.0.OR.K(N+3,2).EQ.0) GOTO 820
65436 ENDIF
65437 P(N+2,5)=PYMASS(K(N+2,2))
65438 P(N+3,5)=PYMASS(K(N+3,2))
65439
65440C...If it does not work: try again (a number of times), give up (if no
65441C...place to shuffle momentum or too many flavours), or form one hadron.
65442 IF(P(N+2,5)+P(N+3,5)+PARJ(64).GE.PECM) THEN
65443 IF(NTRY.LT.MSTJ(17).OR.(NQ.EQ.4.AND.NTRY.LT.5*MSTJ(17))) THEN
65444 GOTO 790
65445 ELSEIF(NSIN.EQ.1.OR.NQ.EQ.4) THEN
65446 GOTO 1140
65447 ELSE
65448 GOTO 890
65449 END IF
65450 END IF
65451
65452C...Perform two-particle decay of jet system.
65453C...First step: find reference axis in decaying system rest frame.
65454C...(Borrow slot N+2 for temporary direction.)
65455 DO 830 J=1,4
65456 P(N+2,J)=P(IC1,J)
65457 830 CONTINUE
65458 DO 850 I=IC1+1,IC2-1
65459 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
65460 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
8ff9ce7d 65461 IF (ABS(FOUR(IC1,I)+FOUR(IC2,I)).GT.0.D0) THEN
65462 FRAC1=FOUR(IC2,I)/(FOUR(IC1,I)+FOUR(IC2,I))
65463 ELSE
65464 FRAC1 = 1.D0
65465 ENDIF
92e27c01 65466 DO 840 J=1,4
65467 P(N+2,J)=P(N+2,J)+FRAC1*P(I,J)
65468 840 CONTINUE
65469 ENDIF
65470 850 CONTINUE
65471 CALL PYROBO(N+2,N+2,0D0,0D0,-DPC(1)/DPC(4),-DPC(2)/DPC(4),
65472 &-DPC(3)/DPC(4))
65473 THE1=PYANGL(P(N+2,3),SQRT(P(N+2,1)**2+P(N+2,2)**2))
65474 PHI1=PYANGL(P(N+2,1),P(N+2,2))
65475
65476C...Second step: generate isotropic/anisotropic decay.
65477 PA=SQRT((PECM**2-(P(N+2,5)+P(N+3,5))**2)*(PECM**2-
65478 &(P(N+2,5)-P(N+3,5))**2))/(2D0*PECM)
65479 860 UE(3)=PYR(0)
65480 IF(PARJ(21).LE.0.01D0) UE(3)=1D0
65481 PT2=(1D0-UE(3)**2)*PA**2
65482 IF(MSTJ(16).LE.0) THEN
65483 PREV=0.5D0
65484 ELSE
65485 IF(EXP(-PT2/(2D0*MAX(0.01D0,PARJ(21))**2)).LT.PYR(0)) GOTO 860
65486 PR1=P(N+2,5)**2+PT2
65487 PR2=P(N+3,5)**2+PT2
65488 ALAMBD=SQRT(MAX(0D0,(PECM**2-PR1-PR2)**2-4D0*PR1*PR2))
65489 PREVCF=PARJ(42)
65490 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
65491 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*ALAMBD*PARJ(40))))
65492 ENDIF
65493 IF(PYR(0).LT.PREV) UE(3)=-UE(3)
65494 PHI=PARU(2)*PYR(0)
65495 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
65496 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
65497 DO 870 J=1,3
65498 P(N+2,J)=PA*UE(J)
65499 P(N+3,J)=-PA*UE(J)
65500 870 CONTINUE
65501 P(N+2,4)=SQRT(PA**2+P(N+2,5)**2)
65502 P(N+3,4)=SQRT(PA**2+P(N+3,5)**2)
65503
65504C...Third step: move back to event frame and set production vertex.
65505 CALL PYROBO(N+2,N+3,THE1,PHI1,DPC(1)/DPC(4),DPC(2)/DPC(4),
65506 &DPC(3)/DPC(4))
65507 DO 880 J=1,4
65508 V(N+1,J)=V(IC1,J)
65509 V(N+2,J)=V(IC1,J)
65510 V(N+3,J)=V(IC2,J)
65511 880 CONTINUE
65512 N=N+3
65513 GOTO 1120
65514
65515C...Else form one particle, if possible.
65516 890 NBODY=1
65517 K(N+1,5)=N+2
65518 DO 900 J=1,4
65519 V(N+1,J)=V(IC1,J)
65520 V(N+2,J)=V(IC1,J)
65521 900 CONTINUE
65522
65523C...Select hadron flavour from available quark flavours.
65524 910 IF(NQ.EQ.2.AND.IABS(KFQ(1)).GT.100.AND.IABS(KFQ(2)).GT.100) THEN
65525 GOTO 1140
65526 ELSEIF(NQ.EQ.2) THEN
65527 CALL PYKFDI(KFQ(1),KFQ(2),KFLDMP,K(N+2,2))
65528 ELSE
65529 KFLN=1+INT((2D0+PARJ(2))*PYR(0))
65530 CALL PYKFDI(KFLN,-KFLN,KFLDMP,K(N+2,2))
65531 ENDIF
65532 IF(K(N+2,2).EQ.0) GOTO 910
65533 P(N+2,5)=PYMASS(K(N+2,2))
65534
65535C...Use old algorithm for E/p conservation? (EN)
65536 IF (MSTJ(16).LE.0) GOTO 1080
65537
65538C...Find the string piece closest to the cluster by a loop
65539C...over the undecayed partons not in present cluster. (EN)
65540 DGLOMI=1D30
65541 IBEG=0
65542 I0=0
65543 NJUNC=0
65544 DO 940 I1=MAX(1,IP),N-1
65545 IF(K(I1,1).EQ.1) NJUNC=0
65546 IF(K(I1,1).EQ.41) NJUNC=NJUNC+1
65547 IF(K(I1,1).EQ.41) GOTO 940
65548 IF(I1.GE.IC1-1.AND.I1.LE.IC2) THEN
65549 I0=0
65550 ELSEIF(K(I1,1).EQ.2) THEN
65551 IF(I0.EQ.0) I0=I1
65552 I2=I1
65553 920 I2=I2+1
65554 IF(K(I2,1).EQ.41) GOTO 940
65555 IF(K(I2,1).GT.10) GOTO 920
65556 IF(KCHG(PYCOMP(K(I2,2)),2).EQ.0) GOTO 920
65557 IF(K(I1,2).EQ.21.AND.K(I2,2).NE.21.AND.K(I2,1).NE.1.AND.
65558 & NJUNC.EQ.0) GOTO 940
65559 IF(K(I1,2).NE.21.AND.K(I2,2).EQ.21.AND.NJUNC.NE.0) GOTO 940
65560 IF(K(I1,2).NE.21.AND.K(I2,2).NE.21.AND.(I1.GT.I0.OR.
65561 & K(I2,1).NE.1)) GOTO 940
65562
65563C...Define velocity vectors e1, e2, ecl and differences e3, e4.
65564 DO 930 J=1,3
65565 E1(J)=P(I1,J)/P(I1,4)
65566 E2(J)=P(I2,J)/P(I2,4)
65567 ECL(J)=P(N+1,J)/P(N+1,4)
65568 E3(J)=E2(J)-E1(J)
65569 E4(J)=ECL(J)-E1(J)
65570 930 CONTINUE
65571
65572C...Calculate minimal D=(e4-alpha*e3)**2 for 0<alpha<1.
65573 E3S=E3(1)**2+E3(2)**2+E3(3)**2
65574 E4S=E4(1)**2+E4(2)**2+E4(3)**2
65575 E34=E3(1)*E4(1)+E3(2)*E4(2)+E3(3)*E4(3)
65576 IF(E34.LE.0D0) THEN
65577 DDMIN=E4S
65578 ELSEIF(E34.LT.E3S) THEN
65579 DDMIN=E4S-E34**2/E3S
65580 ELSE
65581 DDMIN=E4S-2D0*E34+E3S
65582 ENDIF
65583
65584C...Is this the smallest so far?
65585 IF(DDMIN.LT.DGLOMI) THEN
65586 DGLOMI=DDMIN
65587 IBEG=I0
65588 IPCS=I1
65589 ENDIF
65590 ELSEIF(K(I1,1).EQ.1.AND.KCHG(PYCOMP(K(I1,2)),2).NE.0) THEN
65591 I0=0
65592 ENDIF
65593 940 CONTINUE
65594
65595C... Check if there are any strings to connect to the new gluon. (EN)
65596 IF (IBEG.EQ.0) GOTO 1080
65597
65598C...Delta_m = m_clus - m_had > 0: emit a 'gluon' (EN)
65599 IF (P(N+1,5).GE.P(N+2,5)) THEN
65600
65601C...Construct 'gluon' that is needed to put hadron on the mass shell.
65602 FRAC=P(N+2,5)/P(N+1,5)
65603 DO 950 J=1,5
65604 P(N+2,J)=FRAC*P(N+1,J)
65605 PG(J)=(1D0-FRAC)*P(N+1,J)
65606 950 CONTINUE
65607
65608C... Copy string with new gluon put in.
65609 N=N+2
65610 I=IBEG-1
65611 960 I=I+1
65612 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 960
65613 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 960
65614 N=N+1
65615 DO 970 J=1,5
65616 K(N,J)=K(I,J)
65617 P(N,J)=P(I,J)
65618 V(N,J)=V(I,J)
65619 970 CONTINUE
65620 K(I,1)=K(I,1)+10
65621 K(I,4)=N
65622 K(I,5)=N
65623 K(N,3)=I
65624 IF(I.EQ.IPCS) THEN
65625 N=N+1
65626 DO 980 J=1,5
65627 K(N,J)=K(N-1,J)
65628 P(N,J)=PG(J)
65629 V(N,J)=V(N-1,J)
65630 980 CONTINUE
65631 K(N,2)=21
65632 K(N,3)=NSAV+1
65633 ENDIF
65634 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 960
65635 GOTO 1120
65636
65637C...Delta_m = m_clus - m_had < 0: have to absorb a 'gluon' instead,
65638C...from string piece endpoints.
65639 ELSE
65640
65641C...Begin by copying string that should give energy to cluster.
65642 N=N+2
65643 I=IBEG-1
65644 990 I=I+1
65645 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 990
65646 IF(KCHG(PYCOMP(K(I,2)),2).EQ.0.AND.K(I,1).NE.41) GOTO 990
65647 N=N+1
65648 DO 1000 J=1,5
65649 K(N,J)=K(I,J)
65650 P(N,J)=P(I,J)
65651 V(N,J)=V(I,J)
65652 1000 CONTINUE
65653 K(I,1)=K(I,1)+10
65654 K(I,4)=N
65655 K(I,5)=N
65656 K(N,3)=I
65657 IF(I.EQ.IPCS) I1=N
65658 IF(K(I,1).EQ.12.OR.K(I,1).EQ.51) GOTO 990
65659 I2=I1+1
65660
65661C...Set initial Phad.
65662 DO 1010 J=1,4
65663 P(NSAV+2,J)=P(NSAV+1,J)
65664 1010 CONTINUE
65665
65666C...Calculate Pg, a part of which will be added to Phad later. (EN)
65667 1020 IF(MSTJ(16).EQ.1) THEN
65668 ALPHA=1D0
65669 BETA=1D0
65670 ELSE
8ff9ce7d 65671 IF (ABS(FOUR(I1,I2)).GT.0.D0) THEN
65672 ALPHA=FOUR(NSAV+1,I2)/FOUR(I1,I2)
65673 BETA=FOUR(NSAV+1,I1)/FOUR(I1,I2)
65674 ELSE
65675 ALPHA=1D0
65676 BETA=1D0
65677 ENDIF
92e27c01 65678 ENDIF
65679 DO 1030 J=1,4
65680 PG(J)=ALPHA*P(I1,J)+BETA*P(I2,J)
65681 1030 CONTINUE
65682 PG(5)=SQRT(MAX(1D-20,PG(4)**2-PG(1)**2-PG(2)**2-PG(3)**2))
65683
65684C..Solve 2nd order equation, use the best (smallest) solution. (EN)
65685 PMSCOL=P(NSAV+2,4)**2-P(NSAV+2,1)**2-P(NSAV+2,2)**2-
65686 & P(NSAV+2,3)**2
65687 PCLPG=(P(NSAV+2,4)*PG(4)-P(NSAV+2,1)*PG(1)-
65688 & P(NSAV+2,2)*PG(2)-P(NSAV+2,3)*PG(3))/PG(5)**2
65689 DELTA=SQRT(PCLPG**2+(P(NSAV+2,5)**2-PMSCOL)/PG(5)**2)-PCLPG
65690
65691C...If all gluon energy eaten, zero it and take a step back.
65692 ITER=0
65693 IF(DELTA*ALPHA.GT.1D0.AND.I1.GT.NSAV+3.AND.K(I1,2).EQ.21) THEN
65694 ITER=1
65695 DO 1040 J=1,4
65696 P(NSAV+2,J)=P(NSAV+2,J)+P(I1,J)
65697 P(I1,J)=0D0
65698 1040 CONTINUE
65699 P(I1,5)=0D0
65700 K(I1,1)=K(I1,1)+10
65701 I1=I1-1
65702 IF(K(I1,1).EQ.41) ITER=-1
65703 ENDIF
65704 IF(DELTA*BETA.GT.1D0.AND.I2.LT.N.AND.K(I2,2).EQ.21) THEN
65705 ITER=1
65706 DO 1050 J=1,4
65707 P(NSAV+2,J)=P(NSAV+2,J)+P(I2,J)
65708 P(I2,J)=0D0
65709 1050 CONTINUE
65710 P(I2,5)=0D0
65711 K(I2,1)=K(I2,1)+10
65712 I2=I2+1
65713 IF(K(I2,1).EQ.41) ITER=-1
65714 ENDIF
65715 IF(ITER.EQ.1) GOTO 1020
65716
65717C...If also all endpoint energy eaten, revert to old procedure.
65718 IF((1D0-DELTA*ALPHA)*P(I1,4).LT.P(I1,5).OR.
65719 & (1D0-DELTA*BETA)*P(I2,4).LT.P(I2,5).OR.ITER.EQ.-1) THEN
65720 DO 1060 I=NSAV+3,N
65721 IM=K(I,3)
65722 K(IM,1)=K(IM,1)-10
65723 K(IM,4)=0
65724 K(IM,5)=0
65725 1060 CONTINUE
65726 N=NSAV
65727 GOTO 1080
65728 ENDIF
65729
65730C... Construct the collapsed hadron and modified string partons.
65731 DO 1070 J=1,4
65732 P(NSAV+2,J)=P(NSAV+2,J)+DELTA*PG(J)
65733 P(I1,J)=(1D0-DELTA*ALPHA)*P(I1,J)
65734 P(I2,J)=(1D0-DELTA*BETA)*P(I2,J)
65735 1070 CONTINUE
65736 P(I1,5)=(1D0-DELTA*ALPHA)*P(I1,5)
65737 P(I2,5)=(1D0-DELTA*BETA)*P(I2,5)
65738
65739C...Finished with string collapse in new scheme.
65740 GOTO 1120
65741 ENDIF
65742
65743C... Use old algorithm; by choice or when in trouble.
65744 1080 CONTINUE
65745C...Find parton/particle which combines to largest extra mass.
65746 IR=0
65747 HA=0D0
65748 HSM=0D0
65749 DO 1100 MCOMB=1,3
65750 IF(IR.NE.0) GOTO 1100
65751 DO 1090 I=MAX(1,IP),N
65752 IF(K(I,1).LE.0.OR.K(I,1).GT.10.OR.(I.GE.IC1.AND.I.LE.IC2
65753 & .AND.K(I,1).GE.1.AND.K(I,1).LE.2)) GOTO 1090
65754 IF(MCOMB.EQ.1) KCI=PYCOMP(K(I,2))
65755 IF(MCOMB.EQ.1.AND.KCI.EQ.0) GOTO 1090
65756 IF(MCOMB.EQ.1.AND.KCHG(KCI,2).EQ.0.AND.I.LE.NS) GOTO 1090
65757 IF(MCOMB.EQ.2.AND.IABS(K(I,2)).GT.10.AND.IABS(K(I,2)).LE.100)
65758 & GOTO 1090
65759 HCR=DPC(4)*P(I,4)-DPC(1)*P(I,1)-DPC(2)*P(I,2)-DPC(3)*P(I,3)
65760 HSR=2D0*HCR+PECM**2-P(N+2,5)**2-2D0*P(N+2,5)*P(I,5)
65761 IF(HSR.GT.HSM) THEN
65762 IR=I
65763 HA=HCR
65764 HSM=HSR
65765 ENDIF
65766 1090 CONTINUE
65767 1100 CONTINUE
65768
65769C...Shuffle energy and momentum to put new particle on mass shell.
65770 IF(IR.NE.0) THEN
65771 HB=PECM**2+HA
65772 HC=P(N+2,5)**2+HA
65773 HD=P(IR,5)**2+HA
65774 HK2=0.5D0*(HB*SQRT(MAX(0D0,((HB+HC)**2-4D0*(HB+HD)*P(N+2,5)**2)/
65775 & (HA**2-(PECM*P(IR,5))**2)))-(HB+HC))/(HB+HD)
65776 HK1=(0.5D0*(P(N+2,5)**2-PECM**2)+HD*HK2)/HB
65777 DO 1110 J=1,4
65778 P(N+2,J)=(1D0+HK1)*DPC(J)-HK2*P(IR,J)
65779 P(IR,J)=(1D0+HK2)*P(IR,J)-HK1*DPC(J)
65780 1110 CONTINUE
65781 N=N+2
65782 ELSE
65783 CALL PYERRM(3,'(PYPREP:) no match for collapsing cluster')
65784 RETURN
65785 ENDIF
65786
65787C...Mark collapsed system and store daughter pointers. Iterate.
65788 1120 DO 1130 I=IC1,IC2
65789 IF((K(I,1).EQ.1.OR.K(I,1).EQ.2).AND.
65790 & KCHG(PYCOMP(K(I,2)),2).NE.0) THEN
65791 K(I,1)=K(I,1)+10
65792 IF(MSTU(16).NE.2) THEN
65793 K(I,4)=NSAV+1
65794 K(I,5)=NSAV+1
65795 ELSE
65796 K(I,4)=NSAV+2
65797 K(I,5)=NSAV+1+NBODY
65798 ENDIF
65799 ENDIF
65800 IF(K(I,1).EQ.41) K(I,1)=K(I,1)+10
65801 1130 CONTINUE
65802 IF(N.LT.MSTU(4)-MSTU(32)-5) GOTO 710
65803
65804C...Check flavours and invariant masses in parton systems.
65805 1140 NP=0
65806 KFN=0
65807 KQS=0
65808 NJU=0
65809 DO 1150 J=1,5
65810 DPS(J)=0D0
65811 1150 CONTINUE
65812 DO 1180 I=MAX(1,IP),N
65813 IF(K(I,1).EQ.41) NJU=NJU+1
65814 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 1180
65815 KC=PYCOMP(K(I,2))
65816 IF(KC.EQ.0) GOTO 1180
65817 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
65818 IF(KQ.EQ.0) GOTO 1180
65819 NP=NP+1
65820 IF(KQ.NE.2) THEN
65821 KFN=KFN+1
65822 KQS=KQS+KQ
65823 MSTJ(93)=1
65824 DPS(5)=DPS(5)+PYMASS(K(I,2))
65825 ENDIF
65826 DO 1160 J=1,4
65827 DPS(J)=DPS(J)+P(I,J)
65828 1160 CONTINUE
65829 IF(K(I,1).EQ.1) THEN
65830 NFERR=0
65831 IF(NJU.EQ.0.AND.NP.NE.1) THEN
65832 IF(KFN.EQ.1.OR.KFN.GE.3.OR.KQS.NE.0) NFERR=1
65833 ELSEIF(NJU.EQ.1) THEN
65834 IF(KFN.NE.3.OR.IABS(KQS).NE.3) NFERR=1
65835 ELSEIF(NJU.EQ.2) THEN
65836 IF(KFN.NE.4.OR.KQS.NE.0) NFERR=1
65837 ELSEIF(NJU.GE.3) THEN
65838 NFERR=1
65839 ENDIF
65840 IF(NFERR.EQ.1) THEN
65841 CALL PYERRM(2,'(PYPREP:) unphysical flavour combination')
65842 MINT(51)=1
65843 RETURN
65844 ENDIF
65845 IF(NP.NE.1.AND.DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2.LT.
65846 & (0.9D0*PARJ(32)+DPS(5))**2) CALL PYERRM(3,
65847 & '(PYPREP:) too small mass in jet system')
65848 NP=0
65849 KFN=0
65850 KQS=0
65851 NJU=0
65852 DO 1170 J=1,5
65853 DPS(J)=0D0
65854 1170 CONTINUE
65855 ENDIF
65856 1180 CONTINUE
65857
65858 RETURN
65859 END
65860
65861C*********************************************************************
65862
65863C...PYSTRF
65864C...Handles the fragmentation of an arbitrary colour singlet
65865C...jet system according to the Lund string fragmentation model.
65866
65867 SUBROUTINE PYSTRF(IP)
65868
65869C...Double precision and integer declarations.
65870 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
65871 IMPLICIT INTEGER(I-N)
65872 INTEGER PYK,PYCHGE,PYCOMP
65873C...Commonblocks.
65874 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
65875 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
65876 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
65877 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
65878C...Local arrays. All MOPS variables ends with MO
65879 DIMENSION DPS(5),KFL(3),PMQ(3),PX(3),PY(3),GAM(3),IE(2),PR(2),
65880 &IN(9),DHM(4),DHG(4),DP(5,5),IRANK(2),MJU(4),IJU(6),PJU(5,5),
65881 &TJU(5),KFJH(2),NJS(2),KFJS(2),PJS(4,5),MSTU9T(8),PARU9T(8),
65882 &INMO(9),PM2QMO(2),XTMO(2),EJSTR(2),IJUORI(2),IBARRK(2),
65883 &PBST(3,5),TJUOLD(5)
65884
65885C...Function: four-product of two vectors.
65886 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)
65887 DFOUR(I,J)=DP(I,4)*DP(J,4)-DP(I,1)*DP(J,1)-DP(I,2)*DP(J,2)-
65888 &DP(I,3)*DP(J,3)
65889
65890C...Reset counters.
65891 MSTJ(91)=0
65892 NSAV=N
65893 MSTU90=MSTU(90)
65894 NP=0
65895 KQSUM=0
65896 DO 100 J=1,5
65897 DPS(J)=0D0
65898 100 CONTINUE
65899 MJU(1)=0
65900 MJU(2)=0
65901 NTRYFN=0
65902 IJUORI(1)=0
65903 IJUORI(2)=0
65904
65905C...Identify parton system.
65906 I=IP-1
65907 110 I=I+1
65908 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
65909 CALL PYERRM(12,'(PYSTRF:) failed to reconstruct jet system')
65910 IF(MSTU(21).GE.1) RETURN
65911 ENDIF
65912 IF(K(I,1).NE.1.AND.K(I,1).NE.2.AND.K(I,1).NE.41) GOTO 110
65913 KC=PYCOMP(K(I,2))
65914 IF(KC.EQ.0) GOTO 110
65915 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
65916 IF(KQ.EQ.0.AND.K(I,1).NE.41) GOTO 110
65917 IF(N+5*NP+11.GT.MSTU(4)-MSTU(32)-5) THEN
65918 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
65919 IF(MSTU(21).GE.1) RETURN
65920 ENDIF
65921
65922C...Take copy of partons to be considered. Check flavour sum.
65923 NP=NP+1
65924 DO 120 J=1,5
65925 K(N+NP,J)=K(I,J)
65926 P(N+NP,J)=P(I,J)
65927 IF(J.NE.4) DPS(J)=DPS(J)+P(I,J)
65928 120 CONTINUE
65929 DPS(4)=DPS(4)+SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
65930 K(N+NP,3)=I
65931 IF(KQ.NE.2) KQSUM=KQSUM+KQ
65932 IF(K(I,1).EQ.41) THEN
65933 IF(MOD(KQSUM,2).EQ.0.AND.MJU(1).EQ.0) THEN
65934 MJU(1)=N+NP
65935 IJUORI(1)=I
65936 ELSE
65937 MJU(2)=N+NP
65938 IJUORI(2)=I
65939 ENDIF
65940 ENDIF
65941 IF(K(I,1).EQ.2.OR.K(I,1).EQ.41) GOTO 110
65942 IF(MOD(KQSUM,3).NE.0) THEN
65943 CALL PYERRM(12,'(PYSTRF:) unphysical flavour combination')
65944 IF(MSTU(21).GE.1) RETURN
65945 ENDIF
65946 IF(MJU(1).GT.0.OR.MJU(2).GT.0) MSTU(29)=1
65947
65948C...Boost copied system to CM frame (for better numerical precision).
65949 IF(ABS(DPS(3)).LT.0.99D0*DPS(4)) THEN
65950 MBST=0
65951 MSTU(33)=1
65952 CALL PYROBO(N+1,N+NP,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
65953 & -DPS(3)/DPS(4))
65954 ELSE
65955 MBST=1
65956 HHBZ=SQRT(MAX(1D-6,DPS(4)+DPS(3))/MAX(1D-6,DPS(4)-DPS(3)))
65957 DO 130 I=N+1,N+NP
65958 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
65959 IF(P(I,3).GT.0D0) THEN
65960 HHPEZ=MAX(1D-10,(P(I,4)+P(I,3))/HHBZ)
65961 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
65962 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65963 ELSE
65964 HHPEZ=MAX(1D-10,(P(I,4)-P(I,3))*HHBZ)
65965 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
65966 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
65967 ENDIF
65968 130 CONTINUE
65969 ENDIF
65970
65971C...Search for very nearby partons that may be recombined.
65972 NTRYR=0
65973 NTRYWR=0
65974 PARU12=PARU(12)
65975 PARU13=PARU(13)
65976 MJU(3)=MJU(1)
65977 MJU(4)=MJU(2)
65978 NR=NP
65979 NRMIN=2
65980 IF(MJU(1).GT.0) NRMIN=NRMIN+2
65981 IF(MJU(2).GT.0) NRMIN=NRMIN+2
65982 140 IF(NR.GT.NRMIN) THEN
65983 PDRMIN=2D0*PARU12
65984 DO 150 I=N+1,N+NR
65985 IF(I.EQ.N+NR.AND.IABS(K(N+1,2)).NE.21) GOTO 150
65986 I1=I+1
65987 IF(I.EQ.N+NR) I1=N+1
65988 IF(K(I,1).EQ.41.OR.K(I1,1).EQ.41) GOTO 150
65989 IF(MJU(1).NE.0.AND.I1.LT.MJU(1).AND.IABS(K(I1,2)).NE.21)
65990 & GOTO 150
65991 IF(MJU(2).NE.0.AND.I.GT.MJU(2).AND.IABS(K(I,2)).NE.21)
65992 & GOTO 150
65993 PAP=SQRT((P(I,1)**2+P(I,2)**2+P(I,3)**2)*(P(I1,1)**2+
65994 & P(I1,2)**2+P(I1,3)**2))
65995 PVP=P(I,1)*P(I1,1)+P(I,2)*P(I1,2)+P(I,3)*P(I1,3)
65996 PDR=4D0*(PAP-PVP)**2/MAX(1D-6,PARU13**2*PAP+2D0*(PAP-PVP))
65997 IF(PDR.LT.PDRMIN) THEN
65998 IR=I
65999 PDRMIN=PDR
66000 ENDIF
66001 150 CONTINUE
66002
66003C...Recombine very nearby partons to avoid machine precision problems.
66004 IF(PDRMIN.LT.PARU12.AND.IR.EQ.N+NR) THEN
66005 DO 160 J=1,4
66006 P(N+1,J)=P(N+1,J)+P(N+NR,J)
66007 160 CONTINUE
66008 P(N+1,5)=SQRT(MAX(0D0,P(N+1,4)**2-P(N+1,1)**2-P(N+1,2)**2-
66009 & P(N+1,3)**2))
66010 NR=NR-1
66011 GOTO 140
66012 ELSEIF(PDRMIN.LT.PARU12) THEN
66013 DO 170 J=1,4
66014 P(IR,J)=P(IR,J)+P(IR+1,J)
66015 170 CONTINUE
66016 P(IR,5)=SQRT(MAX(0D0,P(IR,4)**2-P(IR,1)**2-P(IR,2)**2-
66017 & P(IR,3)**2))
66018 IF(MJU(2).NE.0.AND.IR.GT.MJU(2)) K(IR,2)=K(IR+1,2)
66019 DO 190 I=IR+1,N+NR-1
66020 K(I,1)=K(I+1,1)
66021 K(I,2)=K(I+1,2)
66022 DO 180 J=1,5
66023 P(I,J)=P(I+1,J)
66024 180 CONTINUE
66025 190 CONTINUE
66026 IF(IR.EQ.N+NR-1) K(IR,2)=K(N+NR,2)
66027 NR=NR-1
66028 IF(MJU(1).GT.IR) MJU(1)=MJU(1)-1
66029 IF(MJU(2).GT.IR) MJU(2)=MJU(2)-1
66030 GOTO 140
66031 ENDIF
66032 ENDIF
66033 NTRYR=NTRYR+1
66034
66035C...Reset particle counter. Skip ahead if no junctions are present;
66036C...this is usually the case!
66037 NRS=MAX(5*NR+11,NP)
66038 NTRY=0
66039 200 NTRY=NTRY+1
66040 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
66041 PARU12=4D0*PARU12
66042 PARU13=2D0*PARU13
66043 GOTO 140
66044 ELSEIF(NTRY.GT.100.OR.NTRYR.GT.100) THEN
66045 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
66046 IF(MSTU(21).GE.1) RETURN
66047 ENDIF
66048 I=N+NRS
66049 MSTU(90)=MSTU90
66050 IF(MJU(1).EQ.0.AND.MJU(2).EQ.0) GOTO 650
66051 IF(MSTJ(12).GE.4) CALL PYERRM(29,'(PYSTRF:) sorry,'//
66052 & ' junction strings not handled by MSTJ(12)>3 options')
66053 DO 640 JT=1,2
66054 NJS(JT)=0
66055 IF(MJU(JT).EQ.0) GOTO 640
66056 JS=3-2*JT
66057
66058C++SKANDS
66059C...Find and sum up momentum on three sides of junction.
66060C...Begin with previous boost = zero.
66061 IJRFIT=0
66062 DO 210 IX=1,3
66063 TJUOLD(IX)=0D0
66064 210 CONTINUE
66065C...Prevent IJU (specifically IJU(5)) from containing junk below
66066 DO 215 IU=1,6
66067 IJU(IU)=0
66068 215 CONTINUE
66069 TJUOLD(4)=1D0
66070 220 IU=0
66071C...Beginning and end of string system in event record.
66072 I1BEG=N+1+(JT-1)*(NR-1)
66073 I1END=N+NR+(JT-1)*(1-NR)
66074C...Look for junction string piece end points
66075 DO 230 I1=I1BEG,I1END,JS
66076 IF(K(I1,2).NE.21.AND.IU.LE.5.AND.IJRFIT.EQ.0) THEN
66077C...Store junction string piece end points.
66078C 1-junction systems 2-junction systems
66079C IU : 1 2 3 4 1 2 3 4 5 6
66080C 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
66081 IU=IU+1
66082 IJU(IU)=I1
66083 ENDIF
66084C...Sum over momenta, from junction outwards.
66085 230 CONTINUE
66086 DO 280 IU=1,3
66087 PWT=0D0
66088C...Initialize junction drag and string piece 4-vectors.
66089 DO 240 J=1,5
66090 PBST(IU,J)=0D0
66091 PJU(IU,J)=0D0
66092 240 CONTINUE
66093C...First two branches. Inwards out means opposite direction to JS.
66094C...(JS is 1 for JT=1, -1 for JT=2)
66095 IF (IU.LT.3) THEN
66096 I1A=IJU(IU+1)-JS
66097 I1B=IJU(IU)
66098 IDIR=-JS
66099C...Last branch (gq or gjgqgq). Direction now reversed.
66100 ELSE
66101 I1A=IJU(IU)+JS
66102 I1B=I1END
66103 IDIR=JS
66104 ENDIF
66105 DO 270 I1=I1A,I1B,IDIR
66106C...Sum up momentum directions with exponential suppression
66107C...for use in finding junction rest frame below.
66108 IF (K(I1,2).EQ.88) THEN
66109C...gjgqgq type system encountered. Use current PWT as start
66110C...for both strings.
66111 PWTOLD=PWT
66112 ELSE
66113 IF (I1.EQ.IJU(5)+IDIR) PWT=PWTOLD
66114C...Sum up string piece (boosted) 4-momenta.
66115 DO 250 J=1,4
66116 PJU(IU,J)=PJU(IU,J)+P(I1,J)
66117 250 CONTINUE
66118C...Compute "junction drag" vectors from (boosted) 4-momenta (initial
66119C...boost is zero, see above). Skip parton if suppression factor large.
66120 IF (PWT.GT.10D0) GOTO 270
66121C...Compute momentum in current frame:
66122 TDP=TJUOLD(1)*P(I1,1)+TJUOLD(2)*P(I1,2)+TJUOLD(3)*P(I1,3)
66123 BFC=TDP/(1D0+TJUOLD(4))+P(I1,4)
66124 DO 260 J=1,3
66125 PTMP=P(I1,J)+TJUOLD(J)*BFC
66126 PBST(IU,J)=PBST(IU,J)+PTMP*EXP(-PWT)
66127 260 CONTINUE
66128C...Boosted energy
66129 PTMP=TJUOLD(4)*P(I1,4)+TDP
66130 PBST(IU,4)=PBST(IU,J)+PTMP*EXP(-PWT)
66131 PWT=PWT+PTMP/PARJ(48)
66132 ENDIF
66133 270 CONTINUE
66134C...Put |p| rather than m in 5th slot.
66135 PBST(IU,5)=SQRT(PBST(IU,1)**2+PBST(IU,2)**2+PBST(IU,3)**2)
66136 PJU(IU,5)=SQRT(PJU(IU,1)**2+PJU(IU,2)**2+PJU(IU,3)**2)
66137 280 CONTINUE
66138
66139C...Calculate boost from present frame to next JRF candidate.
66140 IJRFIT=IJRFIT+1
66141 CALL PYJURF(PBST,TJU)
66142
66143C...After some iterations do not take full step in new direction.
66144 IF(IJRFIT.GT.5) THEN
66145 REDUCE=0.8D0**(IJRFIT-5)
66146 TJU(1)=REDUCE*TJU(1)
66147 TJU(2)=REDUCE*TJU(2)
66148 TJU(3)=REDUCE*TJU(3)
66149 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
66150 ENDIF
66151
66152C...Combine new boost (TJU) with old boost (TJUOLD)
66153 TMP=TJU(1)*TJUOLD(1)+TJU(2)*TJUOLD(2)+TJU(3)*TJUOLD(3)
66154 DO 290 IX=1,3
66155 TJUOLD(IX)=TJU(IX)+TJUOLD(IX)*(TMP/(1D0+TJUOLD(4))+TJU(4))
66156 290 CONTINUE
66157 TJUOLD(4)=SQRT(1D0+TJUOLD(1)**2+TJUOLD(2)**2+TJUOLD(3)**2)
66158
66159C...If last boost small, accept JRF, else iterate.
66160C...Also prevent possibility of infinite loop.
66161 IF (ABS((TJU(4)-1D0)/TJUOLD(4)).GT.0.01D0.AND.
66162 & IJRFIT.LT.MSTJ(18)) THEN
66163 GOTO 220
66164 ELSEIF (IJRFIT.GE.MSTJ(18)) THEN
66165 CALL PYERRM(1,'(PYSTRF:) failed to converge on JRF')
66166 ENDIF
66167
66168C...Now store total boost in TJU and change perception.
66169C...TJUOLD = boost vector from CM of string syst -> JRF. Henceforth,
66170C...TJU = junction motion vector in string CM, so the sign changes.
66171 DO 300 J=1,3
66172 TJU(J)=-TJUOLD(J)
66173 300 CONTINUE
66174 TJU(4)=SQRT(1D0+TJU(1)**2+TJU(2)**2+TJU(3)**2)
66175
66176C--SKANDS
66177
66178C...Calculate string piece energies in junction rest frame.
66179 DO 310 IU=1,3
66180 PJU(IU,5)=TJU(4)*PJU(IU,4)-TJU(1)*PJU(IU,1)-TJU(2)*PJU(IU,2)-
66181 & TJU(3)*PJU(IU,3)
66182 PBST(IU,5)=TJU(4)*PBST(IU,4)-TJU(1)*PBST(IU,1)-
66183 & TJU(2)*PBST(IU,2)-TJU(3)*PBST(IU,3)
66184 310 CONTINUE
66185
66186C...Start preparing for fragmentation of two strings from junction.
66187 ISTA=I
66188 NTRYER=0
66189 320 NTRYER=NTRYER+1
66190 I=ISTA
66191 DO 620 IU=1,2
66192 NS=IABS(IJU(IU+1)-IJU(IU))
66193
66194C...Junction strings: find longitudinal string directions.
66195 DO 350 IS=1,NS
66196 IS1=IJU(IU)+JS*(IS-1)
66197 IS2=IJU(IU)+JS*IS
66198 DO 330 J=1,5
66199 DP(1,J)=0.5D0*P(IS1,J)
66200 IF(IS.EQ.1) DP(1,J)=P(IS1,J)
66201 DP(2,J)=0.5D0*P(IS2,J)
66202 IF(IS.EQ.NS) DP(2,J)=(-PBST(IU,J)+2D0*PBST(IU,5)*TJU(J))*
66203 & (PJU(IU,5)/PBST(IU,5))
66204 330 CONTINUE
66205 IF(IS.EQ.NS) DP(2,5)=SQRT(MAX(0D0,PJU(IU,4)**2-
66206 & PJU(IU,1)**2-PJU(IU,2)**2-PJU(IU,3)**2))
66207 DP(3,5)=DFOUR(1,1)
66208 DP(4,5)=DFOUR(2,2)
66209 DHKC=DFOUR(1,2)
66210 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) THEN
66211 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66212 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66213 DP(3,5)=0D0
66214 DP(4,5)=0D0
66215 DHKC=DFOUR(1,2)
66216 ENDIF
66217 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
66218 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
66219 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
66220 IN1=N+NR+4*IS-3
66221 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
66222 DO 340 J=1,4
66223 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
66224 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
66225 340 CONTINUE
66226 350 CONTINUE
66227
66228C...Junction strings: initialize flavour, momentum and starting pos.
66229 ISAV=I
66230 MSTU91=MSTU(90)
66231 360 NTRY=NTRY+1
66232 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
66233 PARU12=4D0*PARU12
66234 PARU13=2D0*PARU13
66235 GOTO 140
66236 ELSEIF(NTRY.GT.100) THEN
66237 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
66238 IF(MSTU(21).GE.1) RETURN
66239 ENDIF
66240 I=ISAV
66241 MSTU(90)=MSTU91
66242 IRANKJ=0
66243 IE(1)=K(N+1+(JT/2)*(NP-1),3)
66244 IF (MOD(JT+IU,2).NE.0) THEN
66245 IE(1)=K(IJU(IU),3)
66246 IF (NP-NR.NE.0) THEN
66247C...If gluons have disappeared. Original IJU must be used.
66248 IT=IP
66249 NE=1
66250 370 IT=IT+1
66251 IF (K(IT,2).NE.21) THEN
66252 NE=NE+1
66253 ENDIF
66254 IF (NE.EQ.IU+4*(JT-1)) THEN
66255 IE(1)=IT
66256 ELSEIF (IT.LE.IP+NP) THEN
66257 GOTO 370
66258 ELSE
66259 CALL PYERRM(14,'(PYSTRF:) '//
66260 & 'Original IJU could not be reconstructed!')
66261 ENDIF
66262 ENDIF
66263 ENDIF
66264 IN(4)=N+NR+1
66265 IN(5)=IN(4)+1
66266 IN(6)=N+NR+4*NS+1
66267 DO 390 JQ=1,2
66268 DO 380 IN1=N+NR+2+JQ,N+NR+4*NS-2+JQ,4
66269 P(IN1,1)=2-JQ
66270 P(IN1,2)=JQ-1
66271 P(IN1,3)=1D0
66272 380 CONTINUE
66273 390 CONTINUE
66274 KFL(1)=K(IJU(IU),2)
66275 PX(1)=0D0
66276 PY(1)=0D0
66277 GAM(1)=0D0
66278 DO 400 J=1,5
66279 PJU(IU+3,J)=0D0
66280 400 CONTINUE
66281
66282C...Junction strings: find initial transverse directions.
66283 DO 410 J=1,4
66284 DP(1,J)=P(IN(4),J)
66285 DP(2,J)=P(IN(4)+1,J)
66286 DP(3,J)=0D0
66287 DP(4,J)=0D0
66288 410 CONTINUE
66289 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66290 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66291 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
66292 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
66293 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
66294 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
66295 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
66296 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
66297 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
66298 DHC12=DFOUR(1,2)
66299 DHCX1=DFOUR(3,1)/DHC12
66300 DHCX2=DFOUR(3,2)/DHC12
66301 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
66302 DHCY1=DFOUR(4,1)/DHC12
66303 DHCY2=DFOUR(4,2)/DHC12
66304 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
66305 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
66306 DO 420 J=1,4
66307 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
66308 P(IN(6),J)=DP(3,J)
66309 P(IN(6)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
66310 & DHCYX*DP(3,J))
66311 420 CONTINUE
66312
66313C...Junction strings: produce new particle, origin.
66314 430 I=I+1
66315 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
66316 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
66317 IF(MSTU(21).GE.1) RETURN
66318 ENDIF
66319 IRANKJ=IRANKJ+1
66320 K(I,1)=1
66321 K(I,3)=IE(1)
66322 K(I,4)=0
66323 K(I,5)=0
66324
66325C...Junction strings: generate flavour, hadron, pT, z and Gamma.
66326 440 CALL PYKFDI(KFL(1),0,KFL(3),K(I,2))
66327 IF(K(I,2).EQ.0) GOTO 360
66328 IF(IRANKJ.EQ.1.AND.IABS(KFL(1)).LE.10.AND.
66329 & IABS(KFL(3)).GT.10) THEN
66330 IF(PYR(0).GT.PARJ(19)) GOTO 440
66331 ENDIF
66332 P(I,5)=PYMASS(K(I,2))
66333 CALL PYPTDI(KFL(1),PX(3),PY(3))
66334 PR(1)=P(I,5)**2+(PX(1)+PX(3))**2+(PY(1)+PY(3))**2
66335 CALL PYZDIS(KFL(1),KFL(3),PR(1),Z)
66336 IF(IABS(KFL(1)).GE.4.AND.IABS(KFL(1)).LE.8.AND.
66337 & MSTU(90).LT.8) THEN
66338 MSTU(90)=MSTU(90)+1
66339 MSTU(90+MSTU(90))=I
66340 PARU(90+MSTU(90))=Z
66341 ENDIF
66342 GAM(3)=(1D0-Z)*(GAM(1)+PR(1)/Z)
66343 DO 450 J=1,3
66344 IN(J)=IN(3+J)
66345 450 CONTINUE
66346
66347C...Junction strings: stepping within 'low' string region.
66348 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
66349 & P(IN(1),5)**2.GE.PR(1)) THEN
66350 P(IN(1)+2,4)=Z*P(IN(1)+2,3)
66351 P(IN(2)+2,4)=PR(1)/(P(IN(1)+2,4)*P(IN(1),5)**2)
66352 DO 460 J=1,4
66353 P(I,J)=(PX(1)+PX(3))*P(IN(3),J)+(PY(1)+PY(3))*P(IN(3)+1,J)
66354 460 CONTINUE
66355 GOTO 560
66356C...Has used up energy of junction string, i.e. no more hadrons in it.
66357 ELSEIF(IN(1)+1.EQ.IN(2).AND.IN(1).EQ.N+NR+4*NS-3) THEN
66358 DO 470 J=1,5
66359 P(I,J)=0D0
66360 470 CONTINUE
66361 GOTO 600
66362C...Stepping from 'low' string region
66363 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
66364 P(IN(2)+2,4)=P(IN(2)+2,3)
66365 P(IN(2)+2,1)=1D0
66366 IN(2)=IN(2)+4
66367 IF(IN(2).GT.N+NR+4*NS) GOTO 360
66368 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
66369 P(IN(1)+2,4)=P(IN(1)+2,3)
66370 P(IN(1)+2,1)=0D0
66371 IN(1)=IN(1)+4
66372 ENDIF
66373 ENDIF
66374
66375C...Junction strings: find new transverse directions.
66376 480 IF(IN(1).GT.N+NR+4*NS.OR.IN(2).GT.N+NR+4*NS.OR.
66377 & IN(1).GT.IN(2)) GOTO 360
66378 IF(IN(1).NE.IN(4).OR.IN(2).NE.IN(5)) THEN
66379 DO 490 J=1,4
66380 DP(1,J)=P(IN(1),J)
66381 DP(2,J)=P(IN(2),J)
66382 DP(3,J)=0D0
66383 DP(4,J)=0D0
66384 490 CONTINUE
66385 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66386 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66387 DHC12=DFOUR(1,2)
66388 IF(DHC12.LE.1D-2) THEN
66389 P(IN(1)+2,4)=P(IN(1)+2,3)
66390 P(IN(1)+2,1)=0D0
66391 IN(1)=IN(1)+4
66392 GOTO 480
66393 ENDIF
66394 IN(3)=N+NR+4*NS+5
66395 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
66396 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
66397 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
66398 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
66399 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
66400 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
66401 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
66402 DHCX1=DFOUR(3,1)/DHC12
66403 DHCX2=DFOUR(3,2)/DHC12
66404 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
66405 DHCY1=DFOUR(4,1)/DHC12
66406 DHCY2=DFOUR(4,2)/DHC12
66407 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
66408 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
66409 DO 500 J=1,4
66410 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
66411 P(IN(3),J)=DP(3,J)
66412 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
66413 & DHCYX*DP(3,J))
66414 500 CONTINUE
66415C...Express pT with respect to new axes, if sensible.
66416 PXP=-(PX(3)*FOUR(IN(6),IN(3))+PY(3)*FOUR(IN(6)+1,IN(3)))
66417 PYP=-(PX(3)*FOUR(IN(6),IN(3)+1)+PY(3)*FOUR(IN(6)+1,IN(3)+1))
66418 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
66419 PX(3)=PXP
66420 PY(3)=PYP
66421 ENDIF
66422 ENDIF
66423
66424C...Junction strings: sum up known four-momentum, coefficients for m2.
66425 DO 530 J=1,4
66426 DHG(J)=0D0
66427 P(I,J)=PX(1)*P(IN(6),J)+PY(1)*P(IN(6)+1,J)+PX(3)*P(IN(3),J)+
66428 & PY(3)*P(IN(3)+1,J)
66429 DO 510 IN1=IN(4),IN(1)-4,4
66430 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
66431 510 CONTINUE
66432 DO 520 IN2=IN(5),IN(2)-4,4
66433 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
66434 520 CONTINUE
66435 530 CONTINUE
66436 DHM(1)=FOUR(I,I)
66437 DHM(2)=2D0*FOUR(I,IN(1))
66438 DHM(3)=2D0*FOUR(I,IN(2))
66439 DHM(4)=2D0*FOUR(IN(1),IN(2))
66440
66441C...Junction strings: find coefficients for Gamma expression.
66442 DO 550 IN2=IN(1)+1,IN(2),4
66443 DO 540 IN1=IN(1),IN2-1,4
66444 DHC=2D0*FOUR(IN1,IN2)
66445 DHG(1)=DHG(1)+P(IN1+2,1)*P(IN2+2,1)*DHC
66446 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-P(IN2+2,1)*DHC
66447 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+P(IN1+2,1)*DHC
66448 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
66449 540 CONTINUE
66450 550 CONTINUE
66451
66452C...Junction strings: solve (m2, Gamma) equation system for energies.
66453 DHS1=DHM(3)*DHG(4)-DHM(4)*DHG(3)
66454 IF(ABS(DHS1).LT.1D-4) GOTO 360
66455 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(2)*DHG(3)-DHG(4)*
66456 & (P(I,5)**2-DHM(1))+DHG(2)*DHM(3)
66457 DHS3=DHM(2)*(GAM(3)-DHG(1))-DHG(2)*(P(I,5)**2-DHM(1))
66458 P(IN(2)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
66459 & ABS(DHS1)-DHS2/DHS1)
66460 IF(DHM(2)+DHM(4)*P(IN(2)+2,4).LE.0D0) GOTO 360
66461 P(IN(1)+2,4)=(P(I,5)**2-DHM(1)-DHM(3)*P(IN(2)+2,4))/
66462 & (DHM(2)+DHM(4)*P(IN(2)+2,4))
66463
66464C...Junction strings: step to new region if necessary.
66465 IF(P(IN(2)+2,4).GT.P(IN(2)+2,3)) THEN
66466 P(IN(2)+2,4)=P(IN(2)+2,3)
66467 P(IN(2)+2,1)=1D0
66468 IN(2)=IN(2)+4
66469 IF(IN(2).GT.N+NR+4*NS) GOTO 360
66470 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
66471 P(IN(1)+2,4)=P(IN(1)+2,3)
66472 P(IN(1)+2,1)=0D0
66473 IN(1)=IN(1)+4
66474 ENDIF
66475 GOTO 480
66476 ELSEIF(P(IN(1)+2,4).GT.P(IN(1)+2,3)) THEN
66477 P(IN(1)+2,4)=P(IN(1)+2,3)
66478 P(IN(1)+2,1)=0D0
66479 IN(1)=IN(1)+4
66480 GOTO 480
66481 ENDIF
66482
66483C...Junction strings: particle four-momentum, remainder, loop back.
66484 560 DO 570 J=1,4
66485 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+
66486 & P(IN(2)+2,4)*P(IN(2),J)
66487 PJU(IU+3,J)=PJU(IU+3,J)+P(I,J)
66488 570 CONTINUE
66489 IF(P(I,4).LT.P(I,5)) GOTO 360
66490 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
66491 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
66492 IF(PJU(IU+3,5).LT.PJU(IU,5)) THEN
66493 KFL(1)=-KFL(3)
66494 PX(1)=-PX(3)
66495 PY(1)=-PY(3)
66496 GAM(1)=GAM(3)
66497 IF(IN(3).NE.IN(6)) THEN
66498 DO 580 J=1,4
66499 P(IN(6),J)=P(IN(3),J)
66500 P(IN(6)+1,J)=P(IN(3)+1,J)
66501 580 CONTINUE
66502 ENDIF
66503 DO 590 JQ=1,2
66504 IN(3+JQ)=IN(JQ)
66505 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
66506 P(IN(JQ)+2,1)=P(IN(JQ)+2,1)-(3-2*JQ)*P(IN(JQ)+2,4)
66507 590 CONTINUE
66508 GOTO 430
66509 ENDIF
66510
66511C...Junction strings: save quantities left after each string.
66512 IF(IABS(KFL(1)).GT.10) GOTO 360
66513 600 I=I-1
66514 KFJH(IU)=KFL(1)
66515 DO 610 J=1,4
66516 PJU(IU+3,J)=PJU(IU+3,J)-P(I+1,J)
66517 610 CONTINUE
66518
66519C...Junction strings: loopback if much unused energy in both strings.
66520 PJU(IU+3,5)=TJU(4)*PJU(IU+3,4)-TJU(1)*PJU(IU+3,1)-
66521 & TJU(2)*PJU(IU+3,2)-TJU(3)*PJU(IU+3,3)
66522 EJSTR(IU)=PJU(IU,5)-PJU(IU+3,5)
66523 620 CONTINUE
66524 IF((MIN(EJSTR(1),EJSTR(2)).GT.PARJ(49).OR.
66525 & EJSTR(1).GT.PARJ(49)+PYR(0)*PARJ(50).OR.
66526 & EJSTR(2).GT.PARJ(49)+PYR(0)*PARJ(50))
66527 & .AND.NTRYER.LT.10) GOTO 320
66528
66529C...Junction strings: put together to new effective string endpoint.
66530 NJS(JT)=I-ISTA
66531 KFLS=2*INT(PYR(0)+3D0*PARJ(4)/(1D0+3D0*PARJ(4)))+1
66532 IF(KFJH(1).EQ.KFJH(2)) KFLS=3
66533 KFJS(JT)=ISIGN(1000*MAX(IABS(KFJH(1)),IABS(KFJH(2)))+
66534 & 100*MIN(IABS(KFJH(1)),IABS(KFJH(2)))+KFLS,KFJH(1))
66535 DO 630 J=1,4
66536 PJS(JT,J)=PJU(1,J)+PJU(2,J)+P(MJU(JT),J)
66537 PJS(JT+2,J)=PJU(4,J)+PJU(5,J)
66538 630 CONTINUE
66539 PJS(JT,5)=SQRT(MAX(0D0,PJS(JT,4)**2-PJS(JT,1)**2-PJS(JT,2)**2-
66540 & PJS(JT,3)**2))
66541 PJS(JT+2,5)=0D0
66542 640 CONTINUE
66543
66544C...Open versus closed strings. Choose breakup region for latter.
66545 650 IF(MJU(1).NE.0.AND.MJU(2).NE.0) THEN
66546 NS=MJU(2)-MJU(1)
66547 NB=MJU(1)-N
66548 ELSEIF(MJU(1).NE.0) THEN
66549 NS=N+NR-MJU(1)
66550 NB=MJU(1)-N
66551 ELSEIF(MJU(2).NE.0) THEN
66552 NS=MJU(2)-N
66553 NB=1
66554 ELSEIF(IABS(K(N+1,2)).NE.21) THEN
66555 NS=NR-1
66556 NB=1
66557 ELSE
66558 NS=NR+1
66559 W2SUM=0D0
66560 DO 660 IS=1,NR
66561 P(N+NR+IS,1)=0.5D0*FOUR(N+IS,N+IS+1-NR*(IS/NR))
66562 W2SUM=W2SUM+P(N+NR+IS,1)
66563 660 CONTINUE
66564 W2RAN=PYR(0)*W2SUM
66565 NB=0
66566 670 NB=NB+1
66567 W2SUM=W2SUM-P(N+NR+NB,1)
66568 IF(W2SUM.GT.W2RAN.AND.NB.LT.NR) GOTO 670
66569 ENDIF
66570
66571C...Find longitudinal string directions (i.e. lightlike four-vectors).
66572 DO 700 IS=1,NS
66573 IS1=N+IS+NB-1-NR*((IS+NB-2)/NR)
66574 IS2=N+IS+NB-NR*((IS+NB-1)/NR)
66575 DO 680 J=1,5
66576 DP(1,J)=P(IS1,J)
66577 IF(IABS(K(IS1,2)).EQ.21) DP(1,J)=0.5D0*DP(1,J)
66578 IF(IS1.EQ.MJU(1)) DP(1,J)=PJS(1,J)-PJS(3,J)
66579 DP(2,J)=P(IS2,J)
66580 IF(IABS(K(IS2,2)).EQ.21) DP(2,J)=0.5D0*DP(2,J)
66581 IF(IS2.EQ.MJU(2)) DP(2,J)=PJS(2,J)-PJS(4,J)
66582 680 CONTINUE
66583 IF(IS1.EQ.MJU(1)) DP(1,5)=SQRT(MAX(0D0,DP(1,4)**2-DP(1,1)**2-
66584 & DP(1,2)**2-DP(1,3)**2))
66585 IF(IS2.EQ.MJU(2)) DP(2,5)=SQRT(MAX(0D0,DP(2,4)**2-DP(2,1)**2-
66586 & DP(2,2)**2-DP(2,3)**2))
66587 DP(3,5)=DFOUR(1,1)
66588 DP(4,5)=DFOUR(2,2)
66589 DHKC=DFOUR(1,2)
66590 IF(DP(3,5)+2D0*DHKC+DP(4,5).LE.0D0) GOTO 200
66591 DHKS=SQRT(DHKC**2-DP(3,5)*DP(4,5))
66592 DHK1=0.5D0*((DP(4,5)+DHKC)/DHKS-1D0)
66593 DHK2=0.5D0*((DP(3,5)+DHKC)/DHKS-1D0)
66594 IN1=N+NR+4*IS-3
66595 P(IN1,5)=SQRT(DP(3,5)+2D0*DHKC+DP(4,5))
66596 DO 690 J=1,4
66597 P(IN1,J)=(1D0+DHK1)*DP(1,J)-DHK2*DP(2,J)
66598 P(IN1+1,J)=(1D0+DHK2)*DP(2,J)-DHK1*DP(1,J)
66599 690 CONTINUE
66600 700 CONTINUE
66601
66602C...Begin initialization: sum up energy, set starting position.
66603 ISAV=I
66604 MSTU91=MSTU(90)
66605 710 NTRY=NTRY+1
66606 IF(NTRY.GT.100.AND.NTRYR.LE.8.AND.NR.GT.NRMIN) THEN
66607 PARU12=4D0*PARU12
66608 PARU13=2D0*PARU13
66609 GOTO 140
66610 ELSEIF(NTRY.GT.100) THEN
66611 CALL PYERRM(14,'(PYSTRF:) caught in infinite loop')
66612 IF(MSTU(21).GE.1) RETURN
66613 ENDIF
66614 I=ISAV
66615 MSTU(90)=MSTU91
66616 DO 730 J=1,4
66617 P(N+NRS,J)=0D0
66618 DO 720 IS=1,NR
66619 P(N+NRS,J)=P(N+NRS,J)+P(N+IS,J)
66620 720 CONTINUE
66621 730 CONTINUE
66622 DO 750 JT=1,2
66623 IRANK(JT)=0
66624 IF(MJU(JT).NE.0) IRANK(JT)=NJS(JT)
66625 IF(NS.GT.NR) IRANK(JT)=1
66626 IBARRK(JT)=0
66627 IE(JT)=K(N+1+(JT/2)*(NP-1),3)
66628 IN(3*JT+1)=N+NR+1+4*(JT/2)*(NS-1)
66629 IN(3*JT+2)=IN(3*JT+1)+1
66630 IN(3*JT+3)=N+NR+4*NS+2*JT-1
66631 DO 740 IN1=N+NR+2+JT,N+NR+4*NS-2+JT,4
66632 P(IN1,1)=2-JT
66633 P(IN1,2)=JT-1
66634 P(IN1,3)=1D0
66635 740 CONTINUE
66636 750 CONTINUE
66637
66638C.. MOPS variables and switches
66639 NRVMO=0
66640 XBMO=1D0
66641 MSTU(121)=0
66642 MSTU(122)=0
66643
66644C...Initialize flavour and pT variables for open string.
66645 IF(NS.LT.NR) THEN
66646 PX(1)=0D0
66647 PY(1)=0D0
66648 IF(NS.EQ.1.AND.MJU(1)+MJU(2).EQ.0) CALL PYPTDI(0,PX(1),PY(1))
66649 PX(2)=-PX(1)
66650 PY(2)=-PY(1)
66651 DO 760 JT=1,2
66652 KFL(JT)=K(IE(JT),2)
66653 IF(MJU(JT).NE.0) KFL(JT)=KFJS(JT)
66654 IF(MJU(JT).NE.0.AND.IABS(KFL(JT)).GT.1000) IBARRK(JT)=1
66655 MSTJ(93)=1
66656 PMQ(JT)=PYMASS(KFL(JT))
66657 GAM(JT)=0D0
66658 760 CONTINUE
66659
66660C...Closed string: random initial breakup flavour, pT and vertex.
66661 ELSE
66662 KFL(3)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
66663 IBMO=0
66664 770 CALL PYKFDI(KFL(3),0,KFL(1),KDUMP)
66665C.. Closed string: first vertex diq attempt => enforced second
66666C.. vertex diq
66667 IF(IABS(KFL(1)).GT.10)THEN
66668 IBMO=1
66669 MSTU(121)=0
66670 GOTO 770
66671 ENDIF
66672 IF(IBMO.EQ.1) MSTU(121)=-1
66673 KFL(2)=-KFL(1)
66674 CALL PYPTDI(KFL(1),PX(1),PY(1))
66675 PX(2)=-PX(1)
66676 PY(2)=-PY(1)
66677 PR3=MIN(25D0,0.1D0*P(N+NR+1,5)**2)
66678 780 CALL PYZDIS(KFL(1),KFL(2),PR3,Z)
66679 ZR=PR3/(Z*P(N+NR+1,5)**2)
66680 IF(ZR.GE.1D0) GOTO 780
66681 DO 790 JT=1,2
66682 MSTJ(93)=1
66683 PMQ(JT)=PYMASS(KFL(JT))
66684 GAM(JT)=PR3*(1D0-Z)/Z
66685 IN1=N+NR+3+4*(JT/2)*(NS-1)
66686 P(IN1,JT)=1D0-Z
66687 P(IN1,3-JT)=JT-1
66688 P(IN1,3)=(2-JT)*(1D0-Z)+(JT-1)*Z
66689 P(IN1+1,JT)=ZR
66690 P(IN1+1,3-JT)=2-JT
66691 P(IN1+1,3)=(2-JT)*(1D0-ZR)+(JT-1)*ZR
66692 790 CONTINUE
66693 ENDIF
66694C.. MOPS variables
66695 DO 800 JT=1,2
66696 XTMO(JT)=1D0
66697 PM2QMO(JT)=PMQ(JT)**2
66698 IF(IABS(KFL(JT)).GT.10) PM2QMO(JT)=0D0
66699 800 CONTINUE
66700
66701C...Find initial transverse directions (i.e. spacelike four-vectors).
66702 DO 840 JT=1,2
66703 IF(JT.EQ.1.OR.NS.EQ.NR-1.OR.MJU(1)+MJU(2).NE.0) THEN
66704 IN1=IN(3*JT+1)
66705 IN3=IN(3*JT+3)
66706 DO 810 J=1,4
66707 DP(1,J)=P(IN1,J)
66708 DP(2,J)=P(IN1+1,J)
66709 DP(3,J)=0D0
66710 DP(4,J)=0D0
66711 810 CONTINUE
66712 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66713 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66714 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
66715 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
66716 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
66717 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
66718 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
66719 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
66720 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
66721 DHC12=DFOUR(1,2)
66722 DHCX1=DFOUR(3,1)/DHC12
66723 DHCX2=DFOUR(3,2)/DHC12
66724 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
66725 DHCY1=DFOUR(4,1)/DHC12
66726 DHCY2=DFOUR(4,2)/DHC12
66727 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
66728 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
66729 DO 820 J=1,4
66730 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
66731 P(IN3,J)=DP(3,J)
66732 P(IN3+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
66733 & DHCYX*DP(3,J))
66734 820 CONTINUE
66735 ELSE
66736 DO 830 J=1,4
66737 P(IN3+2,J)=P(IN3,J)
66738 P(IN3+3,J)=P(IN3+1,J)
66739 830 CONTINUE
66740 ENDIF
66741 840 CONTINUE
66742
66743C...Remove energy used up in junction string fragmentation.
66744 IF(MJU(1)+MJU(2).GT.0) THEN
66745 DO 860 JT=1,2
66746 IF(NJS(JT).EQ.0) GOTO 860
66747 DO 850 J=1,4
66748 P(N+NRS,J)=P(N+NRS,J)-PJS(JT+2,J)
66749 850 CONTINUE
66750 860 CONTINUE
66751 PARJST=PARJ(33)
66752 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
66753 WMIN=PARJST+PMQ(1)+PMQ(2)
66754 WREM2=FOUR(N+NRS,N+NRS)
66755 IF(P(N+NRS,4).LT.0D0.OR.WREM2.LT.WMIN**2) THEN
66756 NTRYWR=NTRYWR+1
66757 IF(MOD(NTRYWR,20).NE.0) NTRYR=NTRYR-1
66758 GOTO 140
66759 ENDIF
66760 ENDIF
66761
66762C...Produce new particle: side, origin.
66763 870 I=I+1
66764 IF(2*I-NSAV.GE.MSTU(4)-MSTU(32)-5) THEN
66765 CALL PYERRM(11,'(PYSTRF:) no more memory left in PYJETS')
66766 IF(MSTU(21).GE.1) RETURN
66767 ENDIF
66768C.. New side priority for popcorn systems
66769 IF(MSTU(121).LE.0)THEN
66770 JT=1.5D0+PYR(0)
66771 IF(IABS(KFL(3-JT)).GT.10) JT=3-JT
66772 IF(IABS(KFL(3-JT)).GE.4.AND.IABS(KFL(3-JT)).LE.8) JT=3-JT
66773 ENDIF
66774 JR=3-JT
66775 JS=3-2*JT
66776 IRANK(JT)=IRANK(JT)+1
66777 K(I,1)=1
66778 K(I,4)=0
66779 K(I,5)=0
66780
66781C...Generate flavour, hadron and pT.
66782 880 K(I,3)=IE(JT)
66783 CALL PYKFDI(KFL(JT),0,KFL(3),K(I,2))
66784 IF(K(I,2).EQ.0) GOTO 710
66785 MU90MO=MSTU(90)
66786 IF(MSTU(121).EQ.-1) GOTO 910
66787 IF(IRANK(JT).EQ.1.AND.IABS(KFL(JT)).LE.10.AND.
66788 &IABS(KFL(3)).GT.10) THEN
66789 IF(PYR(0).GT.PARJ(19)) GOTO 880
66790 ENDIF
66791 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
66792 &K(I,3)=IJUORI(JT)
66793 P(I,5)=PYMASS(K(I,2))
66794 CALL PYPTDI(KFL(JT),PX(3),PY(3))
66795 PR(JT)=P(I,5)**2+(PX(JT)+PX(3))**2+(PY(JT)+PY(3))**2
66796
66797C...Final hadrons for small invariant mass.
66798 MSTJ(93)=1
66799 PMQ(3)=PYMASS(KFL(3))
66800 PARJST=PARJ(33)
66801 IF(MSTJ(11).EQ.2) PARJST=PARJ(34)
66802 WMIN=PARJST+PMQ(1)+PMQ(2)+PARJ(36)*PMQ(3)
66803 IF(IABS(KFL(JT)).GT.10.AND.IABS(KFL(3)).GT.10) WMIN=
66804 &WMIN-0.5D0*PARJ(36)*PMQ(3)
66805 WREM2=FOUR(N+NRS,N+NRS)
66806 IF(WREM2.LT.0.10D0) GOTO 710
66807 IF(WREM2.LT.MAX(WMIN*(1D0+(2D0*PYR(0)-1D0)*PARJ(37)),
66808 &PARJ(32)+PMQ(1)+PMQ(2))**2) GOTO 1080
66809
66810C...Choose z, which gives Gamma. Shift z for heavy flavours.
66811 CALL PYZDIS(KFL(JT),KFL(3),PR(JT),Z)
66812 IF(IABS(KFL(JT)).GE.4.AND.IABS(KFL(JT)).LE.8.AND.
66813 &MSTU(90).LT.8) THEN
66814 MSTU(90)=MSTU(90)+1
66815 MSTU(90+MSTU(90))=I
66816 PARU(90+MSTU(90))=Z
66817 ENDIF
66818 KFL1A=IABS(KFL(1))
66819 KFL2A=IABS(KFL(2))
66820 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
66821 &MOD(KFL2A/1000,10)).GE.4) THEN
66822 PR(JR)=(PMQ(JR)+PMQ(3))**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
66823 PW12=SQRT(MAX(0D0,(WREM2-PR(1)-PR(2))**2-4D0*PR(1)*PR(2)))
66824 Z=(WREM2+PR(JT)-PR(JR)+PW12*(2D0*Z-1D0))/(2D0*WREM2)
66825 PR(JR)=(PMQ(JR)+PARJST)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
66826 IF((1D0-Z)*(WREM2-PR(JT)/Z).LT.PR(JR)) GOTO 1080
66827 ENDIF
66828 GAM(3)=(1D0-Z)*(GAM(JT)+PR(JT)/Z)
66829
66830C.. MOPS baryon model modification
66831 XTMO3=(1D0-Z)*XTMO(JT)
66832 IF(IABS(KFL(3)).LE.10) NRVMO=0
66833 IF(IABS(KFL(3)).GT.10.AND.MSTJ(12).GE.4) THEN
66834 GTSTMO=1D0
66835 PTSTMO=1D0
66836 RTSTMO=PYR(0)
66837 IF(IABS(KFL(JT)).LE.10)THEN
66838 XBMO=MIN(XTMO3,1D0-(2D-10))
66839 GBMO=GAM(3)
66840 PMMO=0D0
66841 PGMO=GBMO+LOG(1D0-XBMO)*PM2QMO(JT)
66842 GTSTMO=1D0-PARF(192)**PGMO
66843 ELSE
66844 IF(IRANK(JT).EQ.1) THEN
66845 GBMO=GAM(JT)
66846 PMMO=0D0
66847 XBMO=1D0
66848 ENDIF
66849 IF(XBMO.LT.1D0-(1D-10))THEN
66850 PGNMO=GBMO*XTMO3/XBMO+PM2QMO(JT)*LOG(1D0-XTMO3)
66851 GTSTMO=(1D0-PARF(192)**PGNMO)/(1D0-PARF(192)**PGMO)
66852 PGMO=PGNMO
66853 ENDIF
66854 IF(MSTJ(12).GE.5)THEN
66855 PMNMO=SQRT((XBMO-XTMO3)*(GAM(3)/XTMO3-GBMO/XBMO))
66856 PMMO=PMMO+PMAS(PYCOMP(K(I,2)),1)-PMAS(PYCOMP(K(I,2)),3)
66857 PTSTMO=EXP((PMMO-PMNMO)*PARF(193))
66858 PMMO=PMNMO
66859 ENDIF
66860 ENDIF
66861
66862C.. MOPS Accepting popcorn system hadron.
66863 IF(PTSTMO*GTSTMO.GT.RTSTMO) THEN
66864 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) THEN
66865 NRVMO=I-N-NR
66866 IF(I+NRVMO.GT.MSTU(4)-MSTU(32)-5) THEN
66867 CALL PYERRM(11,
66868 & '(PYSTRF:) no more memory left in PYJETS')
66869 IF(MSTU(21).GE.1) RETURN
66870 ENDIF
66871 IMO=I
66872 KFLMO=KFL(JT)
66873 PMQMO=PMQ(JT)
66874 PXMO=PX(JT)
66875 PYMO=PY(JT)
66876 GAMMO=GAM(JT)
66877 IRMO=IRANK(JT)
66878 XMO=XTMO(JT)
66879 DO 900 J=1,9
66880 IF(J.LE.5) THEN
66881 DO 890 LINE=1,I-N-NR
66882 P(MSTU(4)-MSTU(32)-LINE,J)=P(N+NR+LINE,J)
66883 K(MSTU(4)-MSTU(32)-LINE,J)=K(N+NR+LINE,J)
66884 890 CONTINUE
66885 ENDIF
66886 INMO(J)=IN(J)
66887 900 CONTINUE
66888 ENDIF
66889 ELSE
66890C..Reject popcorn system, flag=-1 if enforcing new one
66891 MSTU(121)=-1
66892 IF(PTSTMO.GT.RTSTMO) MSTU(121)=-2
66893 ENDIF
66894 ENDIF
66895
66896
66897C..Lift restoring string outside MOPS block
66898 910 IF(MSTU(121).LT.0) THEN
66899 IF(MSTU(121).EQ.-2) MSTU(121)=0
66900 MSTU(90)=MU90MO
66901 NRVMO=0
66902 IF(IRANK(JT).EQ.1.OR.IABS(KFL(JT)).LE.10) GOTO 880
66903 I=IMO
66904 KFL(JT)=KFLMO
66905 PMQ(JT)=PMQMO
66906 PX(JT)=PXMO
66907 PY(JT)=PYMO
66908 GAM(JT)=GAMMO
66909 IRANK(JT)=IRMO
66910 XTMO(JT)=XMO
66911 DO 930 J=1,9
66912 IF(J.LE.5) THEN
66913 DO 920 LINE=1,I-N-NR
66914 P(N+NR+LINE,J)=P(MSTU(4)-MSTU(32)-LINE,J)
66915 K(N+NR+LINE,J)=K(MSTU(4)-MSTU(32)-LINE,J)
66916 920 CONTINUE
66917 ENDIF
66918 IN(J)=INMO(J)
66919 930 CONTINUE
66920 GOTO 880
66921 ENDIF
66922 XTMO(JT)=XTMO3
66923C.. MOPS end of modification
66924
66925 DO 940 J=1,3
66926 IN(J)=IN(3*JT+J)
66927 940 CONTINUE
66928
66929C...Stepping within or from 'low' string region easy.
66930 IF(IN(1)+1.EQ.IN(2).AND.Z*P(IN(1)+2,3)*P(IN(2)+2,3)*
66931 &P(IN(1),5)**2.GE.PR(JT)) THEN
66932 P(IN(JT)+2,4)=Z*P(IN(JT)+2,3)
66933 P(IN(JR)+2,4)=PR(JT)/(P(IN(JT)+2,4)*P(IN(1),5)**2)
66934 DO 950 J=1,4
66935 P(I,J)=(PX(JT)+PX(3))*P(IN(3),J)+(PY(JT)+PY(3))*P(IN(3)+1,J)
66936 950 CONTINUE
66937 GOTO 1040
66938 ELSEIF(IN(1)+1.EQ.IN(2)) THEN
66939 P(IN(JR)+2,4)=P(IN(JR)+2,3)
66940 P(IN(JR)+2,JT)=1D0
66941 IN(JR)=IN(JR)+4*JS
66942 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
66943 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
66944 P(IN(JT)+2,4)=P(IN(JT)+2,3)
66945 P(IN(JT)+2,JT)=0D0
66946 IN(JT)=IN(JT)+4*JS
66947 ENDIF
66948 ENDIF
66949
66950C...Find new transverse directions (i.e. spacelike string vectors).
66951 960 IF(JS*IN(1).GT.JS*IN(3*JR+1).OR.JS*IN(2).GT.JS*IN(3*JR+2).OR.
66952 &IN(1).GT.IN(2)) GOTO 710
66953 IF(IN(1).NE.IN(3*JT+1).OR.IN(2).NE.IN(3*JT+2)) THEN
66954 DO 970 J=1,4
66955 DP(1,J)=P(IN(1),J)
66956 DP(2,J)=P(IN(2),J)
66957 DP(3,J)=0D0
66958 DP(4,J)=0D0
66959 970 CONTINUE
66960 DP(1,4)=SQRT(DP(1,1)**2+DP(1,2)**2+DP(1,3)**2)
66961 DP(2,4)=SQRT(DP(2,1)**2+DP(2,2)**2+DP(2,3)**2)
66962 DHC12=DFOUR(1,2)
66963 IF(DHC12.LE.1D-2) THEN
66964 P(IN(JT)+2,4)=P(IN(JT)+2,3)
66965 P(IN(JT)+2,JT)=0D0
66966 IN(JT)=IN(JT)+4*JS
66967 GOTO 960
66968 ENDIF
66969 IN(3)=N+NR+4*NS+5
66970 DP(5,1)=DP(1,1)/DP(1,4)-DP(2,1)/DP(2,4)
66971 DP(5,2)=DP(1,2)/DP(1,4)-DP(2,2)/DP(2,4)
66972 DP(5,3)=DP(1,3)/DP(1,4)-DP(2,3)/DP(2,4)
66973 IF(DP(5,1)**2.LE.DP(5,2)**2+DP(5,3)**2) DP(3,1)=1D0
66974 IF(DP(5,1)**2.GT.DP(5,2)**2+DP(5,3)**2) DP(3,3)=1D0
66975 IF(DP(5,2)**2.LE.DP(5,1)**2+DP(5,3)**2) DP(4,2)=1D0
66976 IF(DP(5,2)**2.GT.DP(5,1)**2+DP(5,3)**2) DP(4,3)=1D0
66977 DHCX1=DFOUR(3,1)/DHC12
66978 DHCX2=DFOUR(3,2)/DHC12
66979 DHCXX=1D0/SQRT(1D0+2D0*DHCX1*DHCX2*DHC12)
66980 DHCY1=DFOUR(4,1)/DHC12
66981 DHCY2=DFOUR(4,2)/DHC12
66982 DHCYX=DHCXX*(DHCX1*DHCY2+DHCX2*DHCY1)*DHC12
66983 DHCYY=1D0/SQRT(1D0+2D0*DHCY1*DHCY2*DHC12-DHCYX**2)
66984 DO 980 J=1,4
66985 DP(3,J)=DHCXX*(DP(3,J)-DHCX2*DP(1,J)-DHCX1*DP(2,J))
66986 P(IN(3),J)=DP(3,J)
66987 P(IN(3)+1,J)=DHCYY*(DP(4,J)-DHCY2*DP(1,J)-DHCY1*DP(2,J)-
66988 & DHCYX*DP(3,J))
66989 980 CONTINUE
66990C...Express pT with respect to new axes, if sensible.
66991 PXP=-(PX(3)*FOUR(IN(3*JT+3),IN(3))+PY(3)*
66992 & FOUR(IN(3*JT+3)+1,IN(3)))
66993 PYP=-(PX(3)*FOUR(IN(3*JT+3),IN(3)+1)+PY(3)*
66994 & FOUR(IN(3*JT+3)+1,IN(3)+1))
66995 IF(ABS(PXP**2+PYP**2-PX(3)**2-PY(3)**2).LT.0.01D0) THEN
66996 PX(3)=PXP
66997 PY(3)=PYP
66998 ENDIF
66999 ENDIF
67000
67001C...Sum up known four-momentum. Gives coefficients for m2 expression.
67002 DO 1010 J=1,4
67003 DHG(J)=0D0
67004 P(I,J)=PX(JT)*P(IN(3*JT+3),J)+PY(JT)*P(IN(3*JT+3)+1,J)+
67005 & PX(3)*P(IN(3),J)+PY(3)*P(IN(3)+1,J)
67006 DO 990 IN1=IN(3*JT+1),IN(1)-4*JS,4*JS
67007 P(I,J)=P(I,J)+P(IN1+2,3)*P(IN1,J)
67008 990 CONTINUE
67009 DO 1000 IN2=IN(3*JT+2),IN(2)-4*JS,4*JS
67010 P(I,J)=P(I,J)+P(IN2+2,3)*P(IN2,J)
67011 1000 CONTINUE
67012 1010 CONTINUE
67013 DHM(1)=FOUR(I,I)
67014 DHM(2)=2D0*FOUR(I,IN(1))
67015 DHM(3)=2D0*FOUR(I,IN(2))
67016 DHM(4)=2D0*FOUR(IN(1),IN(2))
67017
67018C...Find coefficients for Gamma expression.
67019 DO 1030 IN2=IN(1)+1,IN(2),4
67020 DO 1020 IN1=IN(1),IN2-1,4
67021 DHC=2D0*FOUR(IN1,IN2)
67022 DHG(1)=DHG(1)+P(IN1+2,JT)*P(IN2+2,JT)*DHC
67023 IF(IN1.EQ.IN(1)) DHG(2)=DHG(2)-JS*P(IN2+2,JT)*DHC
67024 IF(IN2.EQ.IN(2)) DHG(3)=DHG(3)+JS*P(IN1+2,JT)*DHC
67025 IF(IN1.EQ.IN(1).AND.IN2.EQ.IN(2)) DHG(4)=DHG(4)-DHC
67026 1020 CONTINUE
67027 1030 CONTINUE
67028
67029C...Solve (m2, Gamma) equation system for energies taken.
67030 DHS1=DHM(JR+1)*DHG(4)-DHM(4)*DHG(JR+1)
67031 IF(ABS(DHS1).LT.1D-4) GOTO 710
67032 DHS2=DHM(4)*(GAM(3)-DHG(1))-DHM(JT+1)*DHG(JR+1)-DHG(4)*
67033 &(P(I,5)**2-DHM(1))+DHG(JT+1)*DHM(JR+1)
67034 DHS3=DHM(JT+1)*(GAM(3)-DHG(1))-DHG(JT+1)*(P(I,5)**2-DHM(1))
67035 P(IN(JR)+2,4)=0.5D0*(SQRT(MAX(0D0,DHS2**2-4D0*DHS1*DHS3))/
67036 &ABS(DHS1)-DHS2/DHS1)
67037 IF(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4).LE.0D0) GOTO 710
67038 P(IN(JT)+2,4)=(P(I,5)**2-DHM(1)-DHM(JR+1)*P(IN(JR)+2,4))/
67039 &(DHM(JT+1)+DHM(4)*P(IN(JR)+2,4))
67040
67041C...Step to new region if necessary.
67042 IF(P(IN(JR)+2,4).GT.P(IN(JR)+2,3)) THEN
67043 P(IN(JR)+2,4)=P(IN(JR)+2,3)
67044 P(IN(JR)+2,JT)=1D0
67045 IN(JR)=IN(JR)+4*JS
67046 IF(JS*IN(JR).GT.JS*IN(4*JR)) GOTO 710
67047 IF(FOUR(IN(1),IN(2)).LE.1D-2) THEN
67048 P(IN(JT)+2,4)=P(IN(JT)+2,3)
67049 P(IN(JT)+2,JT)=0D0
67050 IN(JT)=IN(JT)+4*JS
67051 ENDIF
67052 GOTO 960
67053 ELSEIF(P(IN(JT)+2,4).GT.P(IN(JT)+2,3)) THEN
67054 P(IN(JT)+2,4)=P(IN(JT)+2,3)
67055 P(IN(JT)+2,JT)=0D0
67056 IN(JT)=IN(JT)+4*JS
67057 GOTO 960
67058 ENDIF
67059
67060C...Four-momentum of particle. Remaining quantities. Loop back.
67061 1040 DO 1050 J=1,4
67062 P(I,J)=P(I,J)+P(IN(1)+2,4)*P(IN(1),J)+P(IN(2)+2,4)*P(IN(2),J)
67063 P(N+NRS,J)=P(N+NRS,J)-P(I,J)
67064 1050 CONTINUE
67065 IF(P(IN(1)+2,4).GT.1D0+PARU(14).OR.P(IN(1)+2,4).LT.-PARU(14).OR.
67066 &P(IN(2)+2,4).GT.1D0+PARU(14).OR.P(IN(2)+2,4).LT.-PARU(14))
67067 &GOTO 200
67068 IF(P(I,4).LT.P(I,5)) GOTO 710
67069 KFL(JT)=-KFL(3)
67070 PMQ(JT)=PMQ(3)
67071 PX(JT)=-PX(3)
67072 PY(JT)=-PY(3)
67073 GAM(JT)=GAM(3)
67074 IF(IN(3).NE.IN(3*JT+3)) THEN
67075 DO 1060 J=1,4
67076 P(IN(3*JT+3),J)=P(IN(3),J)
67077 P(IN(3*JT+3)+1,J)=P(IN(3)+1,J)
67078 1060 CONTINUE
67079 ENDIF
67080 DO 1070 JQ=1,2
67081 IN(3*JT+JQ)=IN(JQ)
67082 P(IN(JQ)+2,3)=P(IN(JQ)+2,3)-P(IN(JQ)+2,4)
67083 P(IN(JQ)+2,JT)=P(IN(JQ)+2,JT)-JS*(3-2*JQ)*P(IN(JQ)+2,4)
67084 1070 CONTINUE
67085 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
67086 &IBARRK(JT)=0
67087 GOTO 870
67088
67089C...Final hadron: side, flavour, hadron, mass.
67090 1080 I=I+1
67091 K(I,1)=1
67092 K(I,3)=IE(JR)
67093 K(I,4)=0
67094 K(I,5)=0
67095 CALL PYKFDI(KFL(JR),-KFL(3),KFLDMP,K(I,2))
67096 IF(K(I,2).EQ.0) GOTO 710
67097 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I-1,2)),10000).GT.1000)
67098 &IBARRK(JT)=0
67099 IF(IBARRK(JT).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
67100 &K(I,3)=IJUORI(JT)
67101 IF(IBARRK(JR).EQ.1.AND.MOD(IABS(K(I,2)),10000).GT.1000)
67102 &K(I,3)=IJUORI(JR)
67103 P(I,5)=PYMASS(K(I,2))
67104 PR(JR)=P(I,5)**2+(PX(JR)-PX(3))**2+(PY(JR)-PY(3))**2
67105
67106C...Final two hadrons: find common setup of four-vectors.
67107 JQ=1
67108 IF(P(IN(4)+2,3)*P(IN(5)+2,3)*FOUR(IN(4),IN(5)).LT.
67109 &P(IN(7)+2,3)*P(IN(8)+2,3)*FOUR(IN(7),IN(8))) JQ=2
67110 DHC12=FOUR(IN(3*JQ+1),IN(3*JQ+2))
67111 DHR1=FOUR(N+NRS,IN(3*JQ+2))/DHC12
67112 DHR2=FOUR(N+NRS,IN(3*JQ+1))/DHC12
67113 IF(IN(4).NE.IN(7).OR.IN(5).NE.IN(8)) THEN
67114 PX(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3))-PX(JQ)
67115 PY(3-JQ)=-FOUR(N+NRS,IN(3*JQ+3)+1)-PY(JQ)
67116 PR(3-JQ)=P(I+(JT+JQ-3)**2-1,5)**2+(PX(3-JQ)+(2*JQ-3)*JS*
67117 & PX(3))**2+(PY(3-JQ)+(2*JQ-3)*JS*PY(3))**2
67118 ENDIF
67119
67120C...Solve kinematics for final two hadrons, if possible.
67121 WREM2=2D0*DHR1*DHR2*DHC12
67122 FD=(SQRT(PR(1))+SQRT(PR(2)))/SQRT(WREM2)
67123 IF(MJU(1)+MJU(2).NE.0.AND.I.EQ.ISAV+2.AND.FD.GE.1D0) GOTO 200
67124 IF(FD.GE.1D0) GOTO 710
67125 FA=WREM2+PR(JT)-PR(JR)
67126 FB=SQRT(MAX(0D0,FA**2-4D0*WREM2*PR(JT)))
67127 PREVCF=PARJ(42)
67128 IF(MSTJ(11).EQ.2) PREVCF=PARJ(39)
67129 PREV=1D0/(1D0+EXP(MIN(50D0,PREVCF*FB*PARJ(40))))
67130 FB=SIGN(FB,JS*(PYR(0)-PREV))
67131 KFL1A=IABS(KFL(1))
67132 KFL2A=IABS(KFL(2))
67133 IF(MAX(MOD(KFL1A,10),MOD(KFL1A/1000,10),MOD(KFL2A,10),
67134 &MOD(KFL2A/1000,10)).GE.6) FB=SIGN(SQRT(MAX(0D0,FA**2-
67135 &4D0*WREM2*PR(JT))),DBLE(JS))
67136 DO 1090 J=1,4
67137 P(I-1,J)=(PX(JT)+PX(3))*P(IN(3*JQ+3),J)+(PY(JT)+PY(3))*
67138 & P(IN(3*JQ+3)+1,J)+0.5D0*(DHR1*(FA+FB)*P(IN(3*JQ+1),J)+
67139 & DHR2*(FA-FB)*P(IN(3*JQ+2),J))/WREM2
67140 P(I,J)=P(N+NRS,J)-P(I-1,J)
67141 1090 CONTINUE
67142 IF(P(I-1,4).LT.P(I-1,5).OR.P(I,4).LT.P(I,5)) GOTO 710
67143 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
67144 DM2F2=P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2-P(I,5)**2
67145 IF(DM2F1.GT.1D-10*P(I-1,4)**2.OR.DM2F2.GT.1D-10*P(I,4)**2) THEN
67146 NTRYFN=NTRYFN+1
67147 IF(NTRYFN.LT.100) GOTO 140
67148 CALL PYERRM(13,'(PYSTRF:) bad energies for final two hadrons')
67149 ENDIF
67150
67151C...Mark jets as fragmented and give daughter pointers.
67152 N=I-NRS+1
67153 DO 1100 I=NSAV+1,NSAV+NP
67154 IM=K(I,3)
67155 K(IM,1)=K(IM,1)+10
67156 IF(MSTU(16).NE.2) THEN
67157 K(IM,4)=NSAV+1
67158 K(IM,5)=NSAV+1
67159 ELSE
67160 K(IM,4)=NSAV+2
67161 K(IM,5)=N
67162 ENDIF
67163 1100 CONTINUE
67164
67165C...Document string system. Move up particles.
67166 NSAV=NSAV+1
67167 K(NSAV,1)=11
67168 K(NSAV,2)=92
67169 K(NSAV,3)=IP
67170 K(NSAV,4)=NSAV+1
67171 K(NSAV,5)=N
67172 DO 1110 J=1,4
67173 P(NSAV,J)=DPS(J)
67174 V(NSAV,J)=V(IP,J)
67175 1110 CONTINUE
67176 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
67177 V(NSAV,5)=0D0
67178 DO 1130 I=NSAV+1,N
67179 DO 1120 J=1,5
67180 K(I,J)=K(I+NRS-1,J)
67181 P(I,J)=P(I+NRS-1,J)
67182 V(I,J)=0D0
67183 1120 CONTINUE
67184 1130 CONTINUE
67185 MSTU91=MSTU(90)
67186 DO 1140 IZ=MSTU90+1,MSTU91
67187 MSTU9T(IZ)=MSTU(90+IZ)-NRS+1-NSAV+N
67188 PARU9T(IZ)=PARU(90+IZ)
67189 1140 CONTINUE
67190 MSTU(90)=MSTU90
67191
67192C...Order particles in rank along the chain. Update mother pointer.
67193 DO 1160 I=NSAV+1,N
67194 DO 1150 J=1,5
67195 K(I-NSAV+N,J)=K(I,J)
67196 P(I-NSAV+N,J)=P(I,J)
67197 1150 CONTINUE
67198 1160 CONTINUE
67199 I1=NSAV
67200 DO 1190 I=N+1,2*N-NSAV
67201 IF(K(I,3).NE.IE(1).AND.K(I,3).NE.IJUORI(1)) GOTO 1190
67202 I1=I1+1
67203 DO 1170 J=1,5
67204 K(I1,J)=K(I,J)
67205 P(I1,J)=P(I,J)
67206 1170 CONTINUE
67207 IF(MSTU(16).NE.2) K(I1,3)=NSAV
67208 DO 1180 IZ=MSTU90+1,MSTU91
67209 IF(MSTU9T(IZ).EQ.I) THEN
67210 MSTU(90)=MSTU(90)+1
67211 MSTU(90+MSTU(90))=I1
67212 PARU(90+MSTU(90))=PARU9T(IZ)
67213 ENDIF
67214 1180 CONTINUE
67215 1190 CONTINUE
67216 DO 1220 I=2*N-NSAV,N+1,-1
67217 IF(K(I,3).EQ.IE(1).OR.K(I,3).EQ.IJUORI(1)) GOTO 1220
67218 I1=I1+1
67219 DO 1200 J=1,5
67220 K(I1,J)=K(I,J)
67221 P(I1,J)=P(I,J)
67222 1200 CONTINUE
67223 IF(MSTU(16).NE.2) K(I1,3)=NSAV
67224 DO 1210 IZ=MSTU90+1,MSTU91
67225 IF(MSTU9T(IZ).EQ.I) THEN
67226 MSTU(90)=MSTU(90)+1
67227 MSTU(90+MSTU(90))=I1
67228 PARU(90+MSTU(90))=PARU9T(IZ)
67229 ENDIF
67230 1210 CONTINUE
67231 1220 CONTINUE
67232
67233C...Boost back particle system. Set production vertices.
67234 IF(MBST.EQ.0) THEN
67235 MSTU(33)=1
67236 CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),
67237 & DPS(3)/DPS(4))
67238 ELSE
67239 DO 1230 I=NSAV+1,N
67240 HHPMT=P(I,1)**2+P(I,2)**2+P(I,5)**2
67241 IF(P(I,3).GT.0D0) THEN
67242 HHPEZ=(P(I,4)+P(I,3))*HHBZ
67243 P(I,3)=0.5D0*(HHPEZ-HHPMT/HHPEZ)
67244 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
67245 ELSE
67246 HHPEZ=(P(I,4)-P(I,3))/HHBZ
67247 P(I,3)=-0.5D0*(HHPEZ-HHPMT/HHPEZ)
67248 P(I,4)=0.5D0*(HHPEZ+HHPMT/HHPEZ)
67249 ENDIF
67250 1230 CONTINUE
67251 ENDIF
67252 DO 1250 I=NSAV+1,N
67253 DO 1240 J=1,4
67254 V(I,J)=V(IP,J)
67255 1240 CONTINUE
67256 1250 CONTINUE
67257
67258 RETURN
67259 END
67260
67261C*********************************************************************
67262
67263C...PYJURF
67264C...From three given input vectors in PJU the boost VJU from
67265C...the "lab frame" to the junction rest frame is constructed.
67266
67267 SUBROUTINE PYJURF(PJU,VJU)
67268
67269C...Double precision and integer declarations.
67270 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67271 IMPLICIT INTEGER(I-N)
67272
67273C...Input, output and local arrays.
67274 DIMENSION PJU(3,5),VJU(5),PSUM(5),A(3,3),PENEW(3),PCM(5,5)
67275 DATA TWOPI/6.283186D0/
67276
67277C...Calculate masses and other invariants.
67278 DO 100 J=1,4
67279 PSUM(J)=PJU(1,J)+PJU(2,J)+PJU(3,J)
67280 100 CONTINUE
67281 PSUM2=PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2
67282 PSUM(5)=SQRT(PSUM2)
67283 DO 120 I=1,3
67284 DO 110 J=1,3
67285 A(I,J)=PJU(I,4)*PJU(J,4)-PJU(I,1)*PJU(J,1)-
67286 & PJU(I,2)*PJU(J,2)-PJU(I,3)*PJU(J,3)
67287 110 CONTINUE
67288 120 CONTINUE
67289
67290C...Pick I to be most massive parton and J to be the one closest to I.
67291 ITRY=0
67292 I=1
67293 IF(A(2,2).GT.A(1,1)) I=2
67294 IF(A(3,3).GT.MAX(A(1,1),A(2,2))) I=3
67295 130 ITRY=ITRY+1
67296 J=1+MOD(I,3)
67297 K=1+MOD(J,3)
67298 IF(A(I,K)**2*A(J,J).LT.A(I,J)**2*A(K,K)) THEN
67299 K=1+MOD(I,3)
67300 J=1+MOD(K,3)
67301 ENDIF
67302 PMI2=A(I,I)
67303 PMJ2=A(J,J)
67304 PMK2=A(K,K)
67305 AIJ=A(I,J)
67306 AIK=A(I,K)
67307 AJK=A(J,K)
67308
67309C...Trivial find new parton energies if all three partons are massless.
67310 IF(PMI2.LT.1D-4) THEN
67311 PEI=SQRT(2D0*AIK*AIJ/(3D0*AJK))
67312 PEJ=SQRT(2D0*AJK*AIJ/(3D0*AIK))
67313 PEK=SQRT(2D0*AIK*AJK/(3D0*AIJ))
67314
67315C...Else find momentum range for parton I and values at extremes.
67316 ELSE
67317 PAIMIN=0D0
67318 PEIMIN=SQRT(PMI2)
67319 PEJMIN=AIJ/PEIMIN
67320 PEKMIN=AIK/PEIMIN
67321 PAJMIN=SQRT(MAX(0D0,PEJMIN**2-PMJ2))
67322 PAKMIN=SQRT(MAX(0D0,PEKMIN**2-PMK2))
67323 FMIN=PEJMIN*PEKMIN+0.5D0*PAJMIN*PAKMIN-AJK
67324 PEIMAX=(AIJ+AIK)/SQRT(PMJ2+PMK2+2D0*AJK)
67325 IF(PMJ2.GT.1D-4) PEIMAX=AIJ/SQRT(PMJ2)
67326 PAIMAX=SQRT(MAX(0D0,PEIMAX**2-PMI2))
67327 HI=PEIMAX**2-0.25D0*PAIMAX**2
67328 PAJMAX=(PEIMAX*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-
67329 & 0.5D0*PAIMAX*AIJ)/HI
67330 PAKMAX=(PEIMAX*SQRT(MAX(0D0,AIK**2-PMK2*HI))-
67331 & 0.5D0*PAIMAX*AIK)/HI
67332 PEJMAX=SQRT(PAJMAX**2+PMJ2)
67333 PEKMAX=SQRT(PAKMAX**2+PMK2)
67334 FMAX=PEJMAX*PEKMAX+0.5D0*PAJMAX*PAKMAX-AJK
67335
67336C...If unexpected values at upper endpoint then pick another parton.
67337 IF(FMAX.GT.0D0.AND.ITRY.LE.2) THEN
67338 I1=1+MOD(I,3)
67339 IF(A(I1,I1).GE.1D-4) THEN
67340 I=I1
67341 GOTO 130
67342 ENDIF
67343 ITRY=ITRY+1
67344 I1=1+MOD(I,3)
67345 IF(ITRY.LE.2.AND.A(I1,I1).GE.1D-4) THEN
67346 I=I1
67347 GOTO 130
67348 ENDIF
67349 ENDIF
67350
67351C..Start binary + linear search to find solution inside range.
67352 ITER=0
67353 ITMIN=0
67354 ITMAX=0
67355 PAI=0.5D0*(PAIMIN+PAIMAX)
67356 140 ITER=ITER+1
67357
67358C...Derive momentum of other two partons and distance to root.
67359 PEI=SQRT(PAI**2+PMI2)
67360 HI=PEI**2-0.25D0*PAI**2
67361 PAJ=(PEI*SQRT(MAX(0D0,AIJ**2-PMJ2*HI))-0.5D0*PAI*AIJ)/HI
67362 PEJ=SQRT(PAJ**2+PMJ2)
67363 PAK=(PEI*SQRT(MAX(0D0,AIK**2-PMK2*HI))-0.5D0*PAI*AIK)/HI
67364 PEK=SQRT(PAK**2+PMK2)
67365 FNOW=PEJ*PEK+0.5D0*PAJ*PAK-AJK
67366
67367C...Pick next I momentum to explore, hopefully closer to root.
67368 IF(FNOW.GT.0D0) THEN
67369 PAIMIN=PAI
67370 FMIN=FNOW
67371 ITMIN=ITMIN+1
67372 ELSE
67373 PAIMAX=PAI
67374 FMAX=FNOW
67375 ITMAX=ITMAX+1
67376 ENDIF
67377 IF((ITER.LT.10.OR.ITMIN.LE.1.OR.ITMAX.LE.1).AND.ITER.LT.20)
67378 & THEN
67379 PAI=0.5D0*(PAIMIN+PAIMAX)
67380 GOTO 140
67381 ELSEIF(ITER.LT.40.AND.FMIN.GT.0D0.AND.FMAX.LT.0D0.AND.
67382 & ABS(FNOW).GT.1D-12*PSUM2) THEN
67383 PAI=PAIMIN+(PAIMAX-PAIMIN)*FMIN/(FMIN-FMAX)
67384 GOTO 140
67385 ENDIF
67386 ENDIF
67387
67388C...Now know energies in junction rest frame.
67389 PENEW(I)=PEI
67390 PENEW(J)=PEJ
67391 PENEW(K)=PEK
67392
67393C...Boost (copy of) partons to their rest frame.
67394 VXCM=-PSUM(1)/PSUM(5)
67395 VYCM=-PSUM(2)/PSUM(5)
67396 VZCM=-PSUM(3)/PSUM(5)
67397 GAMCM=SQRT(1D0+VXCM**2+VYCM**2+VZCM**2)
67398 DO 150 I=1,3
67399 FAC1=PJU(I,1)*VXCM+PJU(I,2)*VYCM+PJU(I,3)*VZCM
67400 FAC2=FAC1/(1D0+GAMCM)+PJU(I,4)
67401 PCM(I,1)=PJU(I,1)+FAC2*VXCM
67402 PCM(I,2)=PJU(I,2)+FAC2*VYCM
67403 PCM(I,3)=PJU(I,3)+FAC2*VZCM
67404 PCM(I,4)=PJU(I,4)*GAMCM+FAC1
67405 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
67406 150 CONTINUE
67407
67408C...Construct difference vectors and boost to junction rest frame.
67409 DO 160 J=1,3
67410 PCM(4,J)=PCM(1,J)/PCM(1,4)-PCM(2,J)/PCM(2,4)
67411 PCM(5,J)=PCM(1,J)/PCM(1,4)-PCM(3,J)/PCM(3,4)
67412 160 CONTINUE
67413 PCM(4,4)=PENEW(1)/PCM(1,4)-PENEW(2)/PCM(2,4)
67414 PCM(5,4)=PENEW(1)/PCM(1,4)-PENEW(3)/PCM(3,4)
67415 PCM4S=PCM(4,1)**2+PCM(4,2)**2+PCM(4,3)**2
67416 PCM5S=PCM(5,1)**2+PCM(5,2)**2+PCM(5,3)**2
67417 PCM45=PCM(4,1)*PCM(5,1)+PCM(4,2)*PCM(5,2)+PCM(4,3)*PCM(5,3)
67418 C4=(PCM5S*PCM(4,4)-PCM45*PCM(5,4))/(PCM4S*PCM5S-PCM45**2)
67419 C5=(PCM4S*PCM(5,4)-PCM45*PCM(4,4))/(PCM4S*PCM5S-PCM45**2)
67420 VXJU=C4*PCM(4,1)+C5*PCM(5,1)
67421 VYJU=C4*PCM(4,2)+C5*PCM(5,2)
67422 VZJU=C4*PCM(4,3)+C5*PCM(5,3)
67423 GAMJU=SQRT(1D0+VXJU**2+VYJU**2+VZJU**2)
67424
67425C...Add two boosts, giving final result.
67426 FCM=(VXJU*VXCM+VYJU*VYCM+VZJU*VZCM)/(1+GAMCM)+GAMJU
67427 VJU(1)=VXJU+FCM*VXCM
67428 VJU(2)=VYJU+FCM*VYCM
67429 VJU(3)=VZJU+FCM*VZCM
67430 VJU(4)=SQRT(1D0+VJU(1)**2+VJU(2)**2+VJU(3)**2)
67431 VJU(5)=1D0
67432
67433C...In case of error in reconstruction: revert to CM frame of system.
67434 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
67435 &(PCM(1,5)*PCM(2,5))
67436 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
67437 &(PCM(1,5)*PCM(3,5))
67438 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
67439 &(PCM(2,5)*PCM(3,5))
67440 ERRCCM=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
67441 ERRTCM=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
67442 DO 170 I=1,3
67443 FAC1=PJU(I,1)*VJU(1)+PJU(I,2)*VJU(2)+PJU(I,3)*VJU(3)
67444 FAC2=FAC1/(1D0+VJU(4))+PJU(I,4)
67445 PCM(I,1)=PJU(I,1)+FAC2*VJU(1)
67446 PCM(I,2)=PJU(I,2)+FAC2*VJU(2)
67447 PCM(I,3)=PJU(I,3)+FAC2*VJU(3)
67448 PCM(I,4)=PJU(I,4)*VJU(4)+FAC1
67449 PCM(I,5)=SQRT(PCM(I,1)**2+PCM(I,2)**2+PCM(I,3)**2)
67450 170 CONTINUE
67451 CTH12=(PCM(1,1)*PCM(2,1)+PCM(1,2)*PCM(2,2)+PCM(1,3)*PCM(2,3))/
67452 &(PCM(1,5)*PCM(2,5))
67453 CTH13=(PCM(1,1)*PCM(3,1)+PCM(1,2)*PCM(3,2)+PCM(1,3)*PCM(3,3))/
67454 &(PCM(1,5)*PCM(3,5))
67455 CTH23=(PCM(2,1)*PCM(3,1)+PCM(2,2)*PCM(3,2)+PCM(2,3)*PCM(3,3))/
67456 &(PCM(2,5)*PCM(3,5))
67457 ERRCJU=(CTH12+0.5D0)**2+(CTH13+0.5D0)**2+(CTH23+0.5D0)**2
67458 ERRTJU=TWOPI-ACOS(CTH12)-ACOS(CTH13)-ACOS(CTH23)
67459 IF(ERRCJU+ERRTJU.GT.ERRCCM+ERRTCM) THEN
67460 VJU(1)=VXCM
67461 VJU(2)=VYCM
67462 VJU(3)=VZCM
67463 VJU(4)=GAMCM
67464 ENDIF
67465
67466 RETURN
67467 END
67468
67469C*********************************************************************
67470
67471C...PYINDF
67472C...Handles the fragmentation of a jet system (or a single
67473C...jet) according to independent fragmentation models.
67474
67475 SUBROUTINE PYINDF(IP)
67476
67477C...Double precision and integer declarations.
67478 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67479 IMPLICIT INTEGER(I-N)
67480 INTEGER PYK,PYCHGE,PYCOMP
67481C...Commonblocks.
67482 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
67483 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67484 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67485 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
67486C...Local arrays.
67487 DIMENSION DPS(5),PSI(4),NFI(3),NFL(3),IFET(3),KFLF(3),
67488 &KFLO(2),PXO(2),PYO(2),WO(2)
67489
67490C.. MOPS error message
67491 IF(MSTJ(12).GT.3) CALL PYERRM(9,'(PYINDF:) MSTJ(12)>3 options'//
67492 &' are not treated as expected in independent fragmentation')
67493
67494C...Reset counters. Identify parton system and take copy. Check flavour.
67495 NSAV=N
67496 MSTU90=MSTU(90)
67497 NJET=0
67498 KQSUM=0
67499 DO 100 J=1,5
67500 DPS(J)=0D0
67501 100 CONTINUE
67502 I=IP-1
67503 110 I=I+1
67504 IF(I.GT.MIN(N,MSTU(4)-MSTU(32))) THEN
67505 CALL PYERRM(12,'(PYINDF:) failed to reconstruct jet system')
67506 IF(MSTU(21).GE.1) RETURN
67507 ENDIF
67508 IF(K(I,1).NE.1.AND.K(I,1).NE.2) GOTO 110
67509 KC=PYCOMP(K(I,2))
67510 IF(KC.EQ.0) GOTO 110
67511 KQ=KCHG(KC,2)*ISIGN(1,K(I,2))
67512 IF(KQ.EQ.0) GOTO 110
67513 NJET=NJET+1
67514 IF(KQ.NE.2) KQSUM=KQSUM+KQ
67515 DO 120 J=1,5
67516 K(NSAV+NJET,J)=K(I,J)
67517 P(NSAV+NJET,J)=P(I,J)
67518 DPS(J)=DPS(J)+P(I,J)
67519 120 CONTINUE
67520 K(NSAV+NJET,3)=I
67521 IF(K(I,1).EQ.2.OR.(MSTJ(3).LE.5.AND.N.GT.I.AND.
67522 &K(I+1,1).EQ.2)) GOTO 110
67523 IF(NJET.NE.1.AND.KQSUM.NE.0) THEN
67524 CALL PYERRM(12,'(PYINDF:) unphysical flavour combination')
67525 IF(MSTU(21).GE.1) RETURN
67526 ENDIF
67527
67528C...Boost copied system to CM frame. Find CM energy and sum flavours.
67529 IF(NJET.NE.1) THEN
67530 MSTU(33)=1
67531 CALL PYROBO(NSAV+1,NSAV+NJET,0D0,0D0,-DPS(1)/DPS(4),
67532 & -DPS(2)/DPS(4),-DPS(3)/DPS(4))
67533 ENDIF
67534 PECM=0D0
67535 DO 130 J=1,3
67536 NFI(J)=0
67537 130 CONTINUE
67538 DO 140 I=NSAV+1,NSAV+NJET
67539 PECM=PECM+P(I,4)
67540 KFA=IABS(K(I,2))
67541 IF(KFA.LE.3) THEN
67542 NFI(KFA)=NFI(KFA)+ISIGN(1,K(I,2))
67543 ELSEIF(KFA.GT.1000) THEN
67544 KFLA=MOD(KFA/1000,10)
67545 KFLB=MOD(KFA/100,10)
67546 IF(KFLA.LE.3) NFI(KFLA)=NFI(KFLA)+ISIGN(1,K(I,2))
67547 IF(KFLB.LE.3) NFI(KFLB)=NFI(KFLB)+ISIGN(1,K(I,2))
67548 ENDIF
67549 140 CONTINUE
67550
67551C...Loop over attempts made. Reset counters.
67552 NTRY=0
67553 150 NTRY=NTRY+1
67554 IF(NTRY.GT.200) THEN
67555 CALL PYERRM(14,'(PYINDF:) caught in infinite loop')
67556 IF(MSTU(21).GE.1) RETURN
67557 ENDIF
67558 N=NSAV+NJET
67559 MSTU(90)=MSTU90
67560 DO 160 J=1,3
67561 NFL(J)=NFI(J)
67562 IFET(J)=0
67563 KFLF(J)=0
67564 160 CONTINUE
67565
67566C...Loop over jets to be fragmented.
67567 DO 230 IP1=NSAV+1,NSAV+NJET
67568 MSTJ(91)=0
67569 NSAV1=N
67570 MSTU91=MSTU(90)
67571
67572C...Initial flavour and momentum values. Jet along +z axis.
67573 KFLH=IABS(K(IP1,2))
67574 IF(KFLH.GT.10) KFLH=MOD(KFLH/1000,10)
67575 KFLO(2)=0
67576 WF=P(IP1,4)+SQRT(P(IP1,1)**2+P(IP1,2)**2+P(IP1,3)**2)
67577
67578C...Initial values for quark or diquark jet.
67579 170 IF(IABS(K(IP1,2)).NE.21) THEN
67580 NSTR=1
67581 KFLO(1)=K(IP1,2)
67582 CALL PYPTDI(0,PXO(1),PYO(1))
67583 WO(1)=WF
67584
67585C...Initial values for gluon treated like random quark jet.
67586 ELSEIF(MSTJ(2).LE.2) THEN
67587 NSTR=1
67588 IF(MSTJ(2).EQ.2) MSTJ(91)=1
67589 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
67590 CALL PYPTDI(0,PXO(1),PYO(1))
67591 WO(1)=WF
67592
67593C...Initial values for gluon treated like quark-antiquark jet pair,
67594C...sharing energy according to Altarelli-Parisi splitting function.
67595 ELSE
67596 NSTR=2
67597 IF(MSTJ(2).EQ.4) MSTJ(91)=1
67598 KFLO(1)=INT(1D0+(2D0+PARJ(2))*PYR(0))*(-1)**INT(PYR(0)+0.5D0)
67599 KFLO(2)=-KFLO(1)
67600 CALL PYPTDI(0,PXO(1),PYO(1))
67601 PXO(2)=-PXO(1)
67602 PYO(2)=-PYO(1)
67603 WO(1)=WF*PYR(0)**(1D0/3D0)
67604 WO(2)=WF-WO(1)
67605 ENDIF
67606
67607C...Initial values for rank, flavour, pT and W+.
67608 DO 220 ISTR=1,NSTR
67609 180 I=N
67610 MSTU(90)=MSTU91
67611 IRANK=0
67612 KFL1=KFLO(ISTR)
67613 PX1=PXO(ISTR)
67614 PY1=PYO(ISTR)
67615 W=WO(ISTR)
67616
67617C...New hadron. Generate flavour and hadron species.
67618 190 I=I+1
67619 IF(I.GE.MSTU(4)-MSTU(32)-NJET-5) THEN
67620 CALL PYERRM(11,'(PYINDF:) no more memory left in PYJETS')
67621 IF(MSTU(21).GE.1) RETURN
67622 ENDIF
67623 IRANK=IRANK+1
67624 K(I,1)=1
67625 K(I,3)=IP1
67626 K(I,4)=0
67627 K(I,5)=0
67628 200 CALL PYKFDI(KFL1,0,KFL2,K(I,2))
67629 IF(K(I,2).EQ.0) GOTO 180
67630 IF(IRANK.EQ.1.AND.IABS(KFL1).LE.10.AND.IABS(KFL2).GT.10) THEN
67631 IF(PYR(0).GT.PARJ(19)) GOTO 200
67632 ENDIF
67633
67634C...Find hadron mass. Generate four-momentum.
67635 P(I,5)=PYMASS(K(I,2))
67636 CALL PYPTDI(KFL1,PX2,PY2)
67637 P(I,1)=PX1+PX2
67638 P(I,2)=PY1+PY2
67639 PR=P(I,5)**2+P(I,1)**2+P(I,2)**2
67640 CALL PYZDIS(KFL1,KFL2,PR,Z)
67641 MZSAV=0
67642 IF(IABS(KFL1).GE.4.AND.IABS(KFL1).LE.8.AND.MSTU(90).LT.8) THEN
67643 MZSAV=1
67644 MSTU(90)=MSTU(90)+1
67645 MSTU(90+MSTU(90))=I
67646 PARU(90+MSTU(90))=Z
67647 ENDIF
67648 P(I,3)=0.5D0*(Z*W-PR/MAX(1D-4,Z*W))
67649 P(I,4)=0.5D0*(Z*W+PR/MAX(1D-4,Z*W))
67650 IF(MSTJ(3).GE.1.AND.IRANK.EQ.1.AND.KFLH.GE.4.AND.
67651 & P(I,3).LE.0.001D0) THEN
67652 IF(W.GE.P(I,5)+0.5D0*PARJ(32)) GOTO 180
67653 P(I,3)=0.0001D0
67654 P(I,4)=SQRT(PR)
67655 Z=P(I,4)/W
67656 ENDIF
67657
67658C...Remaining flavour and momentum.
67659 KFL1=-KFL2
67660 PX1=-PX2
67661 PY1=-PY2
67662 W=(1D0-Z)*W
67663 DO 210 J=1,5
67664 V(I,J)=0D0
67665 210 CONTINUE
67666
67667C...Check if pL acceptable. Go back for new hadron if enough energy.
67668 IF(MSTJ(3).GE.0.AND.P(I,3).LT.0D0) THEN
67669 I=I-1
67670 IF(MZSAV.EQ.1) MSTU(90)=MSTU(90)-1
67671 ENDIF
67672 IF(W.GT.PARJ(31)) GOTO 190
67673 N=I
67674 220 CONTINUE
67675 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) WF=WF+0.1D0*PARJ(32)
67676 IF(MOD(MSTJ(3),5).EQ.4.AND.N.EQ.NSAV1) GOTO 170
67677
67678C...Rotate jet to new direction.
67679 THE=PYANGL(P(IP1,3),SQRT(P(IP1,1)**2+P(IP1,2)**2))
67680 PHI=PYANGL(P(IP1,1),P(IP1,2))
67681 MSTU(33)=1
67682 CALL PYROBO(NSAV1+1,N,THE,PHI,0D0,0D0,0D0)
67683 K(K(IP1,3),4)=NSAV1+1
67684 K(K(IP1,3),5)=N
67685
67686C...End of jet generation loop. Skip conservation in some cases.
67687 230 CONTINUE
67688 IF(NJET.EQ.1.OR.MSTJ(3).LE.0) GOTO 490
67689 IF(MOD(MSTJ(3),5).NE.0.AND.N-NSAV-NJET.LT.2) GOTO 150
67690
67691C...Subtract off produced hadron flavours, finished if zero.
67692 DO 240 I=NSAV+NJET+1,N
67693 KFA=IABS(K(I,2))
67694 KFLA=MOD(KFA/1000,10)
67695 KFLB=MOD(KFA/100,10)
67696 KFLC=MOD(KFA/10,10)
67697 IF(KFLA.EQ.0) THEN
67698 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))*(-1)**KFLB
67699 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(I,2))*(-1)**KFLB
67700 ELSE
67701 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)-ISIGN(1,K(I,2))
67702 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)-ISIGN(1,K(I,2))
67703 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISIGN(1,K(I,2))
67704 ENDIF
67705 240 CONTINUE
67706 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
67707 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
67708 IF(NREQ.EQ.0) GOTO 320
67709
67710C...Take away flavour of low-momentum particles until enough freedom.
67711 NREM=0
67712 250 IREM=0
67713 P2MIN=PECM**2
67714 DO 260 I=NSAV+NJET+1,N
67715 P2=P(I,1)**2+P(I,2)**2+P(I,3)**2
67716 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) IREM=I
67717 IF(K(I,1).EQ.1.AND.P2.LT.P2MIN) P2MIN=P2
67718 260 CONTINUE
67719 IF(IREM.EQ.0) GOTO 150
67720 K(IREM,1)=7
67721 KFA=IABS(K(IREM,2))
67722 KFLA=MOD(KFA/1000,10)
67723 KFLB=MOD(KFA/100,10)
67724 KFLC=MOD(KFA/10,10)
67725 IF(KFLA.GE.4.OR.KFLB.GE.4) K(IREM,1)=8
67726 IF(K(IREM,1).EQ.8) GOTO 250
67727 IF(KFLA.EQ.0) THEN
67728 ISGN=ISIGN(1,K(IREM,2))*(-1)**KFLB
67729 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISGN
67730 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)-ISGN
67731 ELSE
67732 IF(KFLA.LE.3) NFL(KFLA)=NFL(KFLA)+ISIGN(1,K(IREM,2))
67733 IF(KFLB.LE.3) NFL(KFLB)=NFL(KFLB)+ISIGN(1,K(IREM,2))
67734 IF(KFLC.LE.3) NFL(KFLC)=NFL(KFLC)+ISIGN(1,K(IREM,2))
67735 ENDIF
67736 NREM=NREM+1
67737 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
67738 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
67739 IF(NREQ.GT.NREM) GOTO 250
67740 DO 270 I=NSAV+NJET+1,N
67741 IF(K(I,1).EQ.8) K(I,1)=1
67742 270 CONTINUE
67743
67744C...Find combination of existing and new flavours for hadron.
67745 280 NFET=2
67746 IF(NFL(1)+NFL(2)+NFL(3).NE.0) NFET=3
67747 IF(NREQ.LT.NREM) NFET=1
67748 IF(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)).EQ.0) NFET=0
67749 DO 290 J=1,NFET
67750 IFET(J)=1+(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3)))*PYR(0)
67751 KFLF(J)=ISIGN(1,NFL(1))
67752 IF(IFET(J).GT.IABS(NFL(1))) KFLF(J)=ISIGN(2,NFL(2))
67753 IF(IFET(J).GT.IABS(NFL(1))+IABS(NFL(2))) KFLF(J)=ISIGN(3,NFL(3))
67754 290 CONTINUE
67755 IF(NFET.EQ.2.AND.(IFET(1).EQ.IFET(2).OR.KFLF(1)*KFLF(2).GT.0))
67756 &GOTO 280
67757 IF(NFET.EQ.3.AND.(IFET(1).EQ.IFET(2).OR.IFET(1).EQ.IFET(3).OR.
67758 &IFET(2).EQ.IFET(3).OR.KFLF(1)*KFLF(2).LT.0.OR.KFLF(1)*KFLF(3)
67759 &.LT.0.OR.KFLF(1)*(NFL(1)+NFL(2)+NFL(3)).LT.0)) GOTO 280
67760 IF(NFET.EQ.0) KFLF(1)=1+INT((2D0+PARJ(2))*PYR(0))
67761 IF(NFET.EQ.0) KFLF(2)=-KFLF(1)
67762 IF(NFET.EQ.1) KFLF(2)=ISIGN(1+INT((2D0+PARJ(2))*PYR(0)),-KFLF(1))
67763 IF(NFET.LE.2) KFLF(3)=0
67764 IF(KFLF(3).NE.0) THEN
67765 KFLFC=ISIGN(1000*MAX(IABS(KFLF(1)),IABS(KFLF(3)))+
67766 & 100*MIN(IABS(KFLF(1)),IABS(KFLF(3)))+1,KFLF(1))
67767 IF(KFLF(1).EQ.KFLF(3).OR.(1D0+3D0*PARJ(4))*PYR(0).GT.1D0)
67768 & KFLFC=KFLFC+ISIGN(2,KFLFC)
67769 ELSE
67770 KFLFC=KFLF(1)
67771 ENDIF
67772 CALL PYKFDI(KFLFC,KFLF(2),KFLDMP,KF)
67773 IF(KF.EQ.0) GOTO 280
67774 DO 300 J=1,MAX(2,NFET)
67775 NFL(IABS(KFLF(J)))=NFL(IABS(KFLF(J)))-ISIGN(1,KFLF(J))
67776 300 CONTINUE
67777
67778C...Store hadron at random among free positions.
67779 NPOS=MIN(1+INT(PYR(0)*NREM),NREM)
67780 DO 310 I=NSAV+NJET+1,N
67781 IF(K(I,1).EQ.7) NPOS=NPOS-1
67782 IF(K(I,1).EQ.1.OR.NPOS.NE.0) GOTO 310
67783 K(I,1)=1
67784 K(I,2)=KF
67785 P(I,5)=PYMASS(K(I,2))
67786 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
67787 310 CONTINUE
67788 NREM=NREM-1
67789 NREQ=(IABS(NFL(1))+IABS(NFL(2))+IABS(NFL(3))-IABS(NFL(1)+
67790 &NFL(2)+NFL(3)))/2+IABS(NFL(1)+NFL(2)+NFL(3))/3
67791 IF(NREM.GT.0) GOTO 280
67792
67793C...Compensate for missing momentum in global scheme (3 options).
67794 320 IF(MOD(MSTJ(3),5).NE.0.AND.MOD(MSTJ(3),5).NE.4) THEN
67795 DO 340 J=1,3
67796 PSI(J)=0D0
67797 DO 330 I=NSAV+NJET+1,N
67798 PSI(J)=PSI(J)+P(I,J)
67799 330 CONTINUE
67800 340 CONTINUE
67801 PSI(4)=PSI(1)**2+PSI(2)**2+PSI(3)**2
67802 PWS=0D0
67803 DO 350 I=NSAV+NJET+1,N
67804 IF(MOD(MSTJ(3),5).EQ.1) PWS=PWS+P(I,4)
67805 IF(MOD(MSTJ(3),5).EQ.2) PWS=PWS+SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
67806 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
67807 IF(MOD(MSTJ(3),5).EQ.3) PWS=PWS+1D0
67808 350 CONTINUE
67809 DO 370 I=NSAV+NJET+1,N
67810 IF(MOD(MSTJ(3),5).EQ.1) PW=P(I,4)
67811 IF(MOD(MSTJ(3),5).EQ.2) PW=SQRT(P(I,5)**2+(PSI(1)*P(I,1)+
67812 & PSI(2)*P(I,2)+PSI(3)*P(I,3))**2/PSI(4))
67813 IF(MOD(MSTJ(3),5).EQ.3) PW=1D0
67814 DO 360 J=1,3
67815 P(I,J)=P(I,J)-PSI(J)*PW/PWS
67816 360 CONTINUE
67817 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
67818 370 CONTINUE
67819
67820C...Compensate for missing momentum withing each jet separately.
67821 ELSEIF(MOD(MSTJ(3),5).EQ.4) THEN
67822 DO 390 I=N+1,N+NJET
67823 K(I,1)=0
67824 DO 380 J=1,5
67825 P(I,J)=0D0
67826 380 CONTINUE
67827 390 CONTINUE
67828 DO 410 I=NSAV+NJET+1,N
67829 IR1=K(I,3)
67830 IR2=N+IR1-NSAV
67831 K(IR2,1)=K(IR2,1)+1
67832 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
67833 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
67834 DO 400 J=1,3
67835 P(IR2,J)=P(IR2,J)+P(I,J)-PLS*P(IR1,J)
67836 400 CONTINUE
67837 P(IR2,4)=P(IR2,4)+P(I,4)
67838 P(IR2,5)=P(IR2,5)+PLS
67839 410 CONTINUE
67840 PSS=0D0
67841 DO 420 I=N+1,N+NJET
67842 IF(K(I,1).NE.0) PSS=PSS+P(I,4)/(PECM*(0.8D0*P(I,5)+0.2D0))
67843 420 CONTINUE
67844 DO 440 I=NSAV+NJET+1,N
67845 IR1=K(I,3)
67846 IR2=N+IR1-NSAV
67847 PLS=(P(I,1)*P(IR1,1)+P(I,2)*P(IR1,2)+P(I,3)*P(IR1,3))/
67848 & (P(IR1,1)**2+P(IR1,2)**2+P(IR1,3)**2)
67849 DO 430 J=1,3
67850 P(I,J)=P(I,J)-P(IR2,J)/K(IR2,1)+(1D0/(P(IR2,5)*PSS)-1D0)*
67851 & PLS*P(IR1,J)
67852 430 CONTINUE
67853 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
67854 440 CONTINUE
67855 ENDIF
67856
67857C...Scale momenta for energy conservation.
67858 IF(MOD(MSTJ(3),5).NE.0) THEN
67859 PMS=0D0
67860 PES=0D0
67861 PQS=0D0
67862 DO 450 I=NSAV+NJET+1,N
67863 PMS=PMS+P(I,5)
67864 PES=PES+P(I,4)
67865 PQS=PQS+P(I,5)**2/P(I,4)
67866 450 CONTINUE
67867 IF(PMS.GE.PECM) GOTO 150
67868 NECO=0
67869 460 NECO=NECO+1
67870 PFAC=(PECM-PQS)/(PES-PQS)
67871 PES=0D0
67872 PQS=0D0
67873 DO 480 I=NSAV+NJET+1,N
67874 DO 470 J=1,3
67875 P(I,J)=PFAC*P(I,J)
67876 470 CONTINUE
67877 P(I,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2+P(I,5)**2)
67878 PES=PES+P(I,4)
67879 PQS=PQS+P(I,5)**2/P(I,4)
67880 480 CONTINUE
67881 IF(NECO.LT.10.AND.ABS(PECM-PES).GT.2D-6*PECM) GOTO 460
67882 ENDIF
67883
67884C...Origin of produced particles and parton daughter pointers.
67885 490 DO 500 I=NSAV+NJET+1,N
67886 IF(MSTU(16).NE.2) K(I,3)=NSAV+1
67887 IF(MSTU(16).EQ.2) K(I,3)=K(K(I,3),3)
67888 500 CONTINUE
67889 DO 510 I=NSAV+1,NSAV+NJET
67890 I1=K(I,3)
67891 K(I1,1)=K(I1,1)+10
67892 IF(MSTU(16).NE.2) THEN
67893 K(I1,4)=NSAV+1
67894 K(I1,5)=NSAV+1
67895 ELSE
67896 K(I1,4)=K(I1,4)-NJET+1
67897 K(I1,5)=K(I1,5)-NJET+1
67898 IF(K(I1,5).LT.K(I1,4)) THEN
67899 K(I1,4)=0
67900 K(I1,5)=0
67901 ENDIF
67902 ENDIF
67903 510 CONTINUE
67904
67905C...Document independent fragmentation system. Remove copy of jets.
67906 NSAV=NSAV+1
67907 K(NSAV,1)=11
67908 K(NSAV,2)=93
67909 K(NSAV,3)=IP
67910 K(NSAV,4)=NSAV+1
67911 K(NSAV,5)=N-NJET+1
67912 DO 520 J=1,4
67913 P(NSAV,J)=DPS(J)
67914 V(NSAV,J)=V(IP,J)
67915 520 CONTINUE
67916 P(NSAV,5)=SQRT(MAX(0D0,DPS(4)**2-DPS(1)**2-DPS(2)**2-DPS(3)**2))
67917 V(NSAV,5)=0D0
67918 DO 540 I=NSAV+NJET,N
67919 DO 530 J=1,5
67920 K(I-NJET+1,J)=K(I,J)
67921 P(I-NJET+1,J)=P(I,J)
67922 V(I-NJET+1,J)=V(I,J)
67923 530 CONTINUE
67924 540 CONTINUE
67925 N=N-NJET+1
67926 DO 550 IZ=MSTU90+1,MSTU(90)
67927 MSTU(90+IZ)=MSTU(90+IZ)-NJET+1
67928 550 CONTINUE
67929
67930C...Boost back particle system. Set production vertices.
67931 IF(NJET.NE.1) CALL PYROBO(NSAV+1,N,0D0,0D0,DPS(1)/DPS(4),
67932 &DPS(2)/DPS(4),DPS(3)/DPS(4))
67933 DO 570 I=NSAV+1,N
67934 DO 560 J=1,4
67935 V(I,J)=V(IP,J)
67936 560 CONTINUE
67937 570 CONTINUE
67938
67939 RETURN
67940 END
67941
67942C*********************************************************************
67943
67944C...PYDECY
67945C...Handles the decay of unstable particles.
67946
67947 SUBROUTINE PYDECY(IP)
67948
67949C...Double precision and integer declarations.
67950 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
67951 IMPLICIT INTEGER(I-N)
67952 INTEGER PYK,PYCHGE,PYCOMP
67953C...Commonblocks.
67954 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
67955 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
67956 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
67957 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
67958 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
67959C...Local arrays.
67960 DIMENSION VDCY(4),KFLO(4),KFL1(4),PV(10,5),RORD(10),UE(3),BE(3),
67961 &WTCOR(10),PTAU(4),PCMTAU(4),DBETAU(3)
67962 CHARACTER CIDC*4
67963 DATA WTCOR/2D0,5D0,15D0,60D0,250D0,1500D0,1.2D4,1.2D5,150D0,16D0/
67964
67965C...Functions: momentum in two-particle decays and four-product.
67966 PAWT(A,B,C)=SQRT((A**2-(B+C)**2)*(A**2-(B-C)**2))/(2D0*A)
67967 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)
67968
67969C...Initial values.
67970 NTRY=0
67971 NSAV=N
67972 KFA=IABS(K(IP,2))
67973 KFS=ISIGN(1,K(IP,2))
67974 KC=PYCOMP(KFA)
67975 MSTJ(92)=0
67976
67977C...Choose lifetime and determine decay vertex.
67978 IF(K(IP,1).EQ.5) THEN
67979 V(IP,5)=0D0
67980 ELSEIF(K(IP,1).NE.4) THEN
67981 V(IP,5)=-PMAS(KC,4)*LOG(PYR(0))
67982 ENDIF
67983 DO 100 J=1,4
67984 VDCY(J)=V(IP,J)+V(IP,5)*P(IP,J)/P(IP,5)
67985 100 CONTINUE
67986
67987C...Determine whether decay allowed or not.
67988 MOUT=0
67989 IF(MSTJ(22).EQ.2) THEN
67990 IF(PMAS(KC,4).GT.PARJ(71)) MOUT=1
67991 ELSEIF(MSTJ(22).EQ.3) THEN
67992 IF(VDCY(1)**2+VDCY(2)**2+VDCY(3)**2.GT.PARJ(72)**2) MOUT=1
67993 ELSEIF(MSTJ(22).EQ.4) THEN
67994 IF(VDCY(1)**2+VDCY(2)**2.GT.PARJ(73)**2) MOUT=1
67995 IF(ABS(VDCY(3)).GT.PARJ(74)) MOUT=1
67996 ENDIF
67997 IF(MOUT.EQ.1.AND.K(IP,1).NE.5) THEN
67998 K(IP,1)=4
67999 RETURN
68000 ENDIF
68001
68002C...Interface to external tau decay library (for tau polarization).
68003 IF(KFA.EQ.15.AND.MSTJ(28).GE.1) THEN
68004
68005C...Starting values for pointers and momenta.
68006 ITAU=IP
68007 DO 110 J=1,4
68008 PTAU(J)=P(ITAU,J)
68009 PCMTAU(J)=P(ITAU,J)
68010 110 CONTINUE
68011
68012C...Iterate to find position and code of mother of tau.
68013 IMTAU=ITAU
68014 120 IMTAU=K(IMTAU,3)
68015
68016 IF(IMTAU.EQ.0) THEN
68017C...If no known origin then impossible to do anything further.
68018 KFORIG=0
68019 IORIG=0
68020
68021 ELSEIF(K(IMTAU,2).EQ.K(ITAU,2)) THEN
68022C...If tau -> tau + gamma then add gamma energy and loop.
68023 IF(K(K(IMTAU,4),2).EQ.22) THEN
68024 DO 130 J=1,4
68025 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,4),J)
68026 130 CONTINUE
68027 ELSEIF(K(K(IMTAU,5),2).EQ.22) THEN
68028 DO 140 J=1,4
68029 PCMTAU(J)=PCMTAU(J)+P(K(IMTAU,5),J)
68030 140 CONTINUE
68031 ENDIF
68032 GOTO 120
68033
68034 ELSEIF(IABS(K(IMTAU,2)).GT.100) THEN
68035C...If coming from weak decay of hadron then W is not stored in record,
68036C...but can be reconstructed by adding neutrino momentum.
68037 KFORIG=-ISIGN(24,K(ITAU,2))
68038 IORIG=0
68039 DO 160 II=K(IMTAU,4),K(IMTAU,5)
68040 IF(K(II,2)*ISIGN(1,K(ITAU,2)).EQ.-16) THEN
68041 DO 150 J=1,4
68042 PCMTAU(J)=PCMTAU(J)+P(II,J)
68043 150 CONTINUE
68044 ENDIF
68045 160 CONTINUE
68046
68047 ELSE
68048C...If coming from resonance decay then find latest copy of this
68049C...resonance (may not completely agree).
68050 KFORIG=K(IMTAU,2)
68051 IORIG=IMTAU
68052 DO 170 II=IMTAU+1,IP-1
68053 IF(K(II,2).EQ.KFORIG.AND.K(II,3).EQ.IORIG.AND.
68054 & ABS(P(II,5)-P(IORIG,5)).LT.1D-5*P(IORIG,5)) IORIG=II
68055 170 CONTINUE
68056 DO 180 J=1,4
68057 PCMTAU(J)=P(IORIG,J)
68058 180 CONTINUE
68059 ENDIF
68060
68061C...Boost tau to rest frame of production process (where known)
68062C...and rotate it to sit along +z axis.
68063 DO 190 J=1,3
68064 DBETAU(J)=PCMTAU(J)/PCMTAU(4)
68065 190 CONTINUE
68066 IF(KFORIG.NE.0) CALL PYROBO(ITAU,ITAU,0D0,0D0,-DBETAU(1),
68067 & -DBETAU(2),-DBETAU(3))
68068 PHITAU=PYANGL(P(ITAU,1),P(ITAU,2))
68069 CALL PYROBO(ITAU,ITAU,0D0,-PHITAU,0D0,0D0,0D0)
68070 THETAU=PYANGL(P(ITAU,3),P(ITAU,1))
68071 CALL PYROBO(ITAU,ITAU,-THETAU,0D0,0D0,0D0,0D0)
68072
68073C...Call tau decay routine (if meaningful) and fill extra info.
68074 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
68075 CALL PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
68076 DO 200 II=NSAV+1,NSAV+NDECAY
68077 K(II,1)=1
68078 K(II,3)=IP
68079 K(II,4)=0
68080 K(II,5)=0
68081 200 CONTINUE
68082 N=NSAV+NDECAY
68083 ENDIF
68084
68085C...Boost back decay tau and decay products.
68086 DO 210 J=1,4
68087 P(ITAU,J)=PTAU(J)
68088 210 CONTINUE
68089 IF(KFORIG.NE.0.OR.MSTJ(28).EQ.2) THEN
68090 CALL PYROBO(NSAV+1,N,THETAU,PHITAU,0D0,0D0,0D0)
68091 IF(KFORIG.NE.0) CALL PYROBO(NSAV+1,N,0D0,0D0,DBETAU(1),
68092 & DBETAU(2),DBETAU(3))
68093
68094C...Skip past ordinary tau decay treatment.
68095 MMAT=0
68096 MBST=0
68097 ND=0
68098 GOTO 630
68099 ENDIF
68100 ENDIF
68101
68102C...B-Bbar mixing: flip sign of meson appropriately.
68103 MMIX=0
68104 IF((KFA.EQ.511.OR.KFA.EQ.531).AND.MSTJ(26).GE.1) THEN
68105 XBBMIX=PARJ(76)
68106 IF(KFA.EQ.531) XBBMIX=PARJ(77)
68107 IF(SIN(0.5D0*XBBMIX*V(IP,5)/PMAS(KC,4))**2.GT.PYR(0)) MMIX=1
68108 IF(MMIX.EQ.1) KFS=-KFS
68109 ENDIF
68110
68111C...Check existence of decay channels. Particle/antiparticle rules.
68112 KCA=KC
68113 IF(MDCY(KC,2).GT.0) THEN
68114 MDMDCY=MDME(MDCY(KC,2),2)
68115 IF(MDMDCY.GT.80.AND.MDMDCY.LE.90) KCA=MDMDCY
68116 ENDIF
68117 IF(MDCY(KCA,2).LE.0.OR.MDCY(KCA,3).LE.0) THEN
68118 CALL PYERRM(9,'(PYDECY:) no decay channel defined')
68119 RETURN
68120 ENDIF
68121 IF(MOD(KFA/1000,10).EQ.0.AND.KCA.EQ.85) KFS=-KFS
68122 IF(KCHG(KC,3).EQ.0) THEN
68123 KFSP=1
68124 KFSN=0
68125 IF(PYR(0).GT.0.5D0) KFS=-KFS
68126 ELSEIF(KFS.GT.0) THEN
68127 KFSP=1
68128 KFSN=0
68129 ELSE
68130 KFSP=0
68131 KFSN=1
68132 ENDIF
68133
68134C...Sum branching ratios of allowed decay channels.
68135 220 NOPE=0
68136 BRSU=0D0
68137 DO 230 IDL=MDCY(KCA,2),MDCY(KCA,2)+MDCY(KCA,3)-1
68138 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
68139 & KFSN*MDME(IDL,1).NE.3) GOTO 230
68140 IF(MDME(IDL,2).GT.100) GOTO 230
68141 NOPE=NOPE+1
68142 BRSU=BRSU+BRAT(IDL)
68143 230 CONTINUE
68144 IF(NOPE.EQ.0) THEN
68145 CALL PYERRM(2,'(PYDECY:) all decay channels closed by user')
68146 RETURN
68147 ENDIF
68148
68149C...Select decay channel among allowed ones.
68150 240 RBR=BRSU*PYR(0)
68151 IDL=MDCY(KCA,2)-1
68152 250 IDL=IDL+1
68153 IF(MDME(IDL,1).NE.1.AND.KFSP*MDME(IDL,1).NE.2.AND.
68154 &KFSN*MDME(IDL,1).NE.3) THEN
68155 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
68156 ELSEIF(MDME(IDL,2).GT.100) THEN
68157 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1) GOTO 250
68158 ELSE
68159 IDC=IDL
68160 RBR=RBR-BRAT(IDL)
68161 IF(IDL.LT.MDCY(KCA,2)+MDCY(KCA,3)-1.AND.RBR.GT.0D0) GOTO 250
68162 ENDIF
68163
68164C...Start readout of decay channel: matrix element, reset counters.
68165 MMAT=MDME(IDC,2)
68166 260 NTRY=NTRY+1
68167 IF(MOD(NTRY,200).EQ.0) THEN
68168 WRITE(CIDC,'(I4)') IDC
68169C...Do not print warning for some well-known special cases.
68170 IF(KFA.NE.113.AND.KFA.NE.115.AND.KFA.NE.215)
68171 & CALL PYERRM(4,'(PYDECY:) caught in loop for decay channel'//
68172 & CIDC)
68173 GOTO 240
68174 ENDIF
68175 IF(NTRY.GT.1000) THEN
68176 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
68177 IF(MSTU(21).GE.1) RETURN
68178 ENDIF
68179 I=N
68180 NP=0
68181 NQ=0
68182 MBST=0
68183 IF(MMAT.GE.11.AND.P(IP,4).GT.20D0*P(IP,5)) MBST=1
68184 DO 270 J=1,4
68185 PV(1,J)=0D0
68186 IF(MBST.EQ.0) PV(1,J)=P(IP,J)
68187 270 CONTINUE
68188 IF(MBST.EQ.1) PV(1,4)=P(IP,5)
68189 PV(1,5)=P(IP,5)
68190 PS=0D0
68191 PSQ=0D0
68192 MREM=0
68193 MHADDY=0
68194 IF(KFA.GT.80) MHADDY=1
68195C.. Random flavour and popcorn system memory.
68196 IRNDMO=0
68197 JTMO=0
68198 MSTU(121)=0
68199 MSTU(125)=10
68200
68201C...Read out decay products. Convert to standard flavour code.
68202 JTMAX=5
68203 IF(MDME(IDC+1,2).EQ.101) JTMAX=10
68204 DO 280 JT=1,JTMAX
68205 IF(JT.LE.5) KP=KFDP(IDC,JT)
68206 IF(JT.GE.6) KP=KFDP(IDC+1,JT-5)
68207 IF(KP.EQ.0) GOTO 280
68208 KPA=IABS(KP)
68209 KCP=PYCOMP(KPA)
68210 IF(KPA.GT.80) MHADDY=1
68211 IF(KCHG(KCP,3).EQ.0.AND.KPA.NE.81.AND.KPA.NE.82) THEN
68212 KFP=KP
68213 ELSEIF(KPA.NE.81.AND.KPA.NE.82) THEN
68214 KFP=KFS*KP
68215 ELSEIF(KPA.EQ.81.AND.MOD(KFA/1000,10).EQ.0) THEN
68216 KFP=-KFS*MOD(KFA/10,10)
68217 ELSEIF(KPA.EQ.81.AND.MOD(KFA/100,10).GE.MOD(KFA/10,10)) THEN
68218 KFP=KFS*(100*MOD(KFA/10,100)+3)
68219 ELSEIF(KPA.EQ.81) THEN
68220 KFP=KFS*(1000*MOD(KFA/10,10)+100*MOD(KFA/100,10)+1)
68221 ELSEIF(KP.EQ.82) THEN
68222 CALL PYDCYK(-KFS*INT(1D0+(2D0+PARJ(2))*PYR(0)),0,KFP,KDUMP)
68223 IF(KFP.EQ.0) GOTO 260
68224 KFP=-KFP
68225 IRNDMO=1
68226 MSTJ(93)=1
68227 IF(PV(1,5).LT.PARJ(32)+2D0*PYMASS(KFP)) GOTO 260
68228 ELSEIF(KP.EQ.-82) THEN
68229 KFP=MSTU(124)
68230 ENDIF
68231 IF(KPA.EQ.81.OR.KPA.EQ.82) KCP=PYCOMP(KFP)
68232
68233C...Add decay product to event record or to quark flavour list.
68234 KFPA=IABS(KFP)
68235 KQP=KCHG(KCP,2)
68236 IF(MMAT.GE.11.AND.MMAT.LE.30.AND.KQP.NE.0) THEN
68237 NQ=NQ+1
68238 KFLO(NQ)=KFP
68239C...set rndmflav popcorn system pointer
68240 IF(KP.EQ.82.AND.MSTU(121).GT.0) JTMO=NQ
68241 MSTJ(93)=2
68242 PSQ=PSQ+PYMASS(KFLO(NQ))
68243 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.48).AND.NP.EQ.3.AND.
68244 & MOD(NQ,2).EQ.1) THEN
68245 NQ=NQ-1
68246 PS=PS-P(I,5)
68247 K(I,1)=1
68248 KFI=K(I,2)
68249 CALL PYKFDI(KFP,KFI,KFLDMP,K(I,2))
68250 IF(K(I,2).EQ.0) GOTO 260
68251 MSTJ(93)=1
68252 P(I,5)=PYMASS(K(I,2))
68253 PS=PS+P(I,5)
68254 ELSE
68255 I=I+1
68256 NP=NP+1
68257 IF(MMAT.NE.33.AND.KQP.NE.0) NQ=NQ+1
68258 IF(MMAT.EQ.33.AND.KQP.NE.0.AND.KQP.NE.2) NQ=NQ+1
68259 K(I,1)=1+MOD(NQ,2)
68260 IF(MMAT.EQ.4.AND.JT.LE.2.AND.KFP.EQ.21) K(I,1)=2
68261 IF(MMAT.EQ.4.AND.JT.EQ.3) K(I,1)=1
68262 K(I,2)=KFP
68263 K(I,3)=IP
68264 K(I,4)=0
68265 K(I,5)=0
68266 P(I,5)=PYMASS(KFP)
68267 PS=PS+P(I,5)
68268 ENDIF
68269 280 CONTINUE
68270
68271C...Check masses for resonance decays.
68272 IF(MHADDY.EQ.0) THEN
68273 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 240
68274 ENDIF
68275
68276C...Choose decay multiplicity in phase space model.
68277 290 IF(MMAT.GE.11.AND.MMAT.LE.30) THEN
68278 PSP=PS
68279 CNDE=PARJ(61)*LOG(MAX((PV(1,5)-PS-PSQ)/PARJ(62),1.1D0))
68280 IF(MMAT.EQ.12) CNDE=CNDE+PARJ(63)
68281 300 NTRY=NTRY+1
68282C...Reset popcorn flags if new attempt. Re-select rndmflav if failed.
68283 IF(IRNDMO.EQ.0) THEN
68284 MSTU(121)=0
68285 JTMO=0
68286 ELSEIF(IRNDMO.EQ.1) THEN
68287 IRNDMO=2
68288 ELSE
68289 GOTO 260
68290 ENDIF
68291 IF(NTRY.GT.1000) THEN
68292 CALL PYERRM(14,'(PYDECY:) caught in infinite loop')
68293 IF(MSTU(21).GE.1) RETURN
68294 ENDIF
68295 IF(MMAT.LE.20) THEN
68296 GAUSS=SQRT(-2D0*CNDE*LOG(MAX(1D-10,PYR(0))))*
68297 & SIN(PARU(2)*PYR(0))
68298 ND=0.5D0+0.5D0*NP+0.25D0*NQ+CNDE+GAUSS
68299 IF(ND.LT.NP+NQ/2.OR.ND.LT.2.OR.ND.GT.10) GOTO 300
68300 IF(MMAT.EQ.13.AND.ND.EQ.2) GOTO 300
68301 IF(MMAT.EQ.14.AND.ND.LE.3) GOTO 300
68302 IF(MMAT.EQ.15.AND.ND.LE.4) GOTO 300
68303 ELSE
68304 ND=MMAT-20
68305 ENDIF
68306C.. Set maximum popcorn meson number. Test rndmflav popcorn size.
68307 MSTU(125)=ND-NQ/2
68308 IF(MSTU(121).GT.MSTU(125)) GOTO 300
68309
68310C...Form hadrons from flavour content.
68311 DO 310 JT=1,NQ
68312 KFL1(JT)=KFLO(JT)
68313 310 CONTINUE
68314 IF(ND.EQ.NP+NQ/2) GOTO 330
68315 DO 320 I=N+NP+1,N+ND-NQ/2
68316C.. Stick to started popcorn system, else pick side at random
68317 JT=JTMO
68318 IF(JT.EQ.0) JT=1+INT((NQ-1)*PYR(0))
68319 CALL PYDCYK(KFL1(JT),0,KFL2,K(I,2))
68320 IF(K(I,2).EQ.0) GOTO 300
68321 MSTU(125)=MSTU(125)-1
68322 JTMO=0
68323 IF(MSTU(121).GT.0) JTMO=JT
68324 KFL1(JT)=-KFL2
68325 320 CONTINUE
68326 330 JT=2
68327 JT2=3
68328 JT3=4
68329 IF(NQ.EQ.4.AND.PYR(0).LT.PARJ(66)) JT=4
68330 IF(JT.EQ.4.AND.ISIGN(1,KFL1(1)*(10-IABS(KFL1(1))))*
68331 & ISIGN(1,KFL1(JT)*(10-IABS(KFL1(JT)))).GT.0) JT=3
68332 IF(JT.EQ.3) JT2=2
68333 IF(JT.EQ.4) JT3=2
68334 CALL PYDCYK(KFL1(1),KFL1(JT),KFLDMP,K(N+ND-NQ/2+1,2))
68335 IF(K(N+ND-NQ/2+1,2).EQ.0) GOTO 300
68336 IF(NQ.EQ.4) CALL PYDCYK(KFL1(JT2),KFL1(JT3),KFLDMP,K(N+ND,2))
68337 IF(NQ.EQ.4.AND.K(N+ND,2).EQ.0) GOTO 300
68338
68339C...Check that sum of decay product masses not too large.
68340 PS=PSP
68341 DO 340 I=N+NP+1,N+ND
68342 K(I,1)=1
68343 K(I,3)=IP
68344 K(I,4)=0
68345 K(I,5)=0
68346 P(I,5)=PYMASS(K(I,2))
68347 PS=PS+P(I,5)
68348 340 CONTINUE
68349 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 300
68350
68351C...Rescale energy to subtract off spectator quark mass.
68352 ELSEIF((MMAT.EQ.31.OR.MMAT.EQ.33.OR.MMAT.EQ.44)
68353 & .AND.NP.GE.3) THEN
68354 PS=PS-P(N+NP,5)
68355 PQT=(P(N+NP,5)+PARJ(65))/PV(1,5)
68356 DO 350 J=1,5
68357 P(N+NP,J)=PQT*PV(1,J)
68358 PV(1,J)=(1D0-PQT)*PV(1,J)
68359 350 CONTINUE
68360 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
68361 ND=NP-1
68362 MREM=1
68363
68364C...Fully specified final state: check mass broadening effects.
68365 ELSE
68366 IF(NP.GE.2.AND.PS+PARJ(64).GT.PV(1,5)) GOTO 260
68367 ND=NP
68368 ENDIF
68369
68370C...Determine position of grandmother, number of sisters.
68371 NM=0
68372 KFAS=0
68373 MSGN=0
68374 IF(MMAT.EQ.3) THEN
68375 IM=K(IP,3)
68376 IF(IM.LT.0.OR.IM.GE.IP) IM=0
68377 IF(IM.NE.0) KFAM=IABS(K(IM,2))
68378 IF(IM.NE.0) THEN
68379 DO 360 IL=MAX(IP-2,IM+1),MIN(IP+2,N)
68380 IF(K(IL,3).EQ.IM) NM=NM+1
68381 IF(K(IL,3).EQ.IM.AND.IL.NE.IP) ISIS=IL
68382 360 CONTINUE
68383 IF(NM.NE.2.OR.KFAM.LE.100.OR.MOD(KFAM,10).NE.1.OR.
68384 & MOD(KFAM/1000,10).NE.0) NM=0
68385 IF(NM.EQ.2) THEN
68386 KFAS=IABS(K(ISIS,2))
68387 IF((KFAS.LE.100.OR.MOD(KFAS,10).NE.1.OR.
68388 & MOD(KFAS/1000,10).NE.0).AND.KFAS.NE.22) NM=0
68389 ENDIF
68390 ENDIF
68391 ENDIF
68392
68393C...Kinematics of one-particle decays.
68394 IF(ND.EQ.1) THEN
68395 DO 370 J=1,4
68396 P(N+1,J)=P(IP,J)
68397 370 CONTINUE
68398 GOTO 630
68399 ENDIF
68400
68401C...Calculate maximum weight ND-particle decay.
68402 PV(ND,5)=P(N+ND,5)
68403 IF(ND.GE.3) THEN
68404 WTMAX=1D0/WTCOR(ND-2)
68405 PMAX=PV(1,5)-PS+P(N+ND,5)
68406 PMIN=0D0
68407 DO 380 IL=ND-1,1,-1
68408 PMAX=PMAX+P(N+IL,5)
68409 PMIN=PMIN+P(N+IL+1,5)
68410 WTMAX=WTMAX*PAWT(PMAX,PMIN,P(N+IL,5))
68411 380 CONTINUE
68412 ENDIF
68413
68414C...Find virtual gamma mass in Dalitz decay.
68415 390 IF(ND.EQ.2) THEN
68416 ELSEIF(MMAT.EQ.2) THEN
68417 PMES=4D0*PMAS(11,1)**2
68418 PMRHO2=PMAS(131,1)**2
68419 PGRHO2=PMAS(131,2)**2
68420 400 PMST=PMES*(P(IP,5)**2/PMES)**PYR(0)
68421 WT=(1+0.5D0*PMES/PMST)*SQRT(MAX(0D0,1D0-PMES/PMST))*
68422 & (1D0-PMST/P(IP,5)**2)**3*(1D0+PGRHO2/PMRHO2)/
68423 & ((1D0-PMST/PMRHO2)**2+PGRHO2/PMRHO2)
68424 IF(WT.LT.PYR(0)) GOTO 400
68425 PV(2,5)=MAX(2.00001D0*PMAS(11,1),SQRT(PMST))
68426
68427C...M-generator gives weight. If rejected, try again.
68428 ELSE
68429 410 RORD(1)=1D0
68430 DO 440 IL1=2,ND-1
68431 RSAV=PYR(0)
68432 DO 420 IL2=IL1-1,1,-1
68433 IF(RSAV.LE.RORD(IL2)) GOTO 430
68434 RORD(IL2+1)=RORD(IL2)
68435 420 CONTINUE
68436 430 RORD(IL2+1)=RSAV
68437 440 CONTINUE
68438 RORD(ND)=0D0
68439 WT=1D0
68440 DO 450 IL=ND-1,1,-1
68441 PV(IL,5)=PV(IL+1,5)+P(N+IL,5)+(RORD(IL)-RORD(IL+1))*
68442 & (PV(1,5)-PS)
68443 WT=WT*PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
68444 450 CONTINUE
68445 IF(WT.LT.PYR(0)*WTMAX) GOTO 410
68446 ENDIF
68447
68448C...Perform two-particle decays in respective CM frame.
68449 460 DO 480 IL=1,ND-1
68450 PA=PAWT(PV(IL,5),PV(IL+1,5),P(N+IL,5))
68451 UE(3)=2D0*PYR(0)-1D0
68452 PHI=PARU(2)*PYR(0)
68453 UE(1)=SQRT(1D0-UE(3)**2)*COS(PHI)
68454 UE(2)=SQRT(1D0-UE(3)**2)*SIN(PHI)
68455 DO 470 J=1,3
68456 P(N+IL,J)=PA*UE(J)
68457 PV(IL+1,J)=-PA*UE(J)
68458 470 CONTINUE
68459 P(N+IL,4)=SQRT(PA**2+P(N+IL,5)**2)
68460 PV(IL+1,4)=SQRT(PA**2+PV(IL+1,5)**2)
68461 480 CONTINUE
68462
68463C...Lorentz transform decay products to lab frame.
68464 DO 490 J=1,4
68465 P(N+ND,J)=PV(ND,J)
68466 490 CONTINUE
68467 DO 530 IL=ND-1,1,-1
68468 DO 500 J=1,3
68469 BE(J)=PV(IL,J)/PV(IL,4)
68470 500 CONTINUE
68471 GA=PV(IL,4)/PV(IL,5)
68472 DO 520 I=N+IL,N+ND
68473 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
68474 DO 510 J=1,3
68475 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
68476 510 CONTINUE
68477 P(I,4)=GA*(P(I,4)+BEP)
68478 520 CONTINUE
68479 530 CONTINUE
68480
68481C...Check that no infinite loop in matrix element weight.
68482 NTRY=NTRY+1
68483 IF(NTRY.GT.800) GOTO 560
68484
68485C...Matrix elements for omega and phi decays.
68486 IF(MMAT.EQ.1) THEN
68487 WT=(P(N+1,5)*P(N+2,5)*P(N+3,5))**2-(P(N+1,5)*FOUR(N+2,N+3))**2
68488 & -(P(N+2,5)*FOUR(N+1,N+3))**2-(P(N+3,5)*FOUR(N+1,N+2))**2
68489 & +2D0*FOUR(N+1,N+2)*FOUR(N+1,N+3)*FOUR(N+2,N+3)
68490 IF(MAX(WT*WTCOR(9)/P(IP,5)**6,0.001D0).LT.PYR(0)) GOTO 390
68491
68492C...Matrix elements for pi0 or eta Dalitz decay to gamma e+ e-.
68493 ELSEIF(MMAT.EQ.2) THEN
68494 FOUR12=FOUR(N+1,N+2)
68495 FOUR13=FOUR(N+1,N+3)
68496 WT=(PMST-0.5D0*PMES)*(FOUR12**2+FOUR13**2)+
68497 & PMES*(FOUR12*FOUR13+FOUR12**2+FOUR13**2)
68498 IF(WT.LT.PYR(0)*0.25D0*PMST*(P(IP,5)**2-PMST)**2) GOTO 460
68499
68500C...Matrix element for S0 -> S1 + V1 -> S1 + S2 + S3 (S scalar,
68501C...V vector), of form cos**2(theta02) in V1 rest frame, and for
68502C...S0 -> gamma + V1 -> gamma + S2 + S3, of form sin**2(theta02).
68503 ELSEIF(MMAT.EQ.3.AND.NM.EQ.2) THEN
68504 FOUR10=FOUR(IP,IM)
68505 FOUR12=FOUR(IP,N+1)
68506 FOUR02=FOUR(IM,N+1)
68507 PMS1=P(IP,5)**2
68508 PMS0=P(IM,5)**2
68509 PMS2=P(N+1,5)**2
68510 IF(KFAS.NE.22) HNUM=(FOUR10*FOUR12-PMS1*FOUR02)**2
68511 IF(KFAS.EQ.22) HNUM=PMS1*(2D0*FOUR10*FOUR12*FOUR02-
68512 & PMS1*FOUR02**2-PMS0*FOUR12**2-PMS2*FOUR10**2+PMS1*PMS0*PMS2)
68513 HNUM=MAX(1D-6*PMS1**2*PMS0*PMS2,HNUM)
68514 HDEN=(FOUR10**2-PMS1*PMS0)*(FOUR12**2-PMS1*PMS2)
68515 IF(HNUM.LT.PYR(0)*HDEN) GOTO 460
68516
68517C...Matrix element for "onium" -> g + g + g or gamma + g + g.
68518 ELSEIF(MMAT.EQ.4) THEN
68519 HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
68520 HX2=2D0*FOUR(IP,N+2)/P(IP,5)**2
68521 HX3=2D0*FOUR(IP,N+3)/P(IP,5)**2
68522 WT=((1D0-HX1)/(HX2*HX3))**2+((1D0-HX2)/(HX1*HX3))**2+
68523 & ((1D0-HX3)/(HX1*HX2))**2
68524 IF(WT.LT.2D0*PYR(0)) GOTO 390
68525 IF(K(IP+1,2).EQ.22.AND.(1D0-HX1)*P(IP,5)**2.LT.4D0*PARJ(32)**2)
68526 & GOTO 390
68527
68528C...Effective matrix element for nu spectrum in tau -> nu + hadrons.
68529 ELSEIF(MMAT.EQ.41) THEN
68530 IF(MBST.EQ.0) HX1=2D0*FOUR(IP,N+1)/P(IP,5)**2
68531 IF(MBST.EQ.1) HX1=2D0*P(N+1,4)/P(IP,5)
68532 HXM=MIN(0.75D0,2D0*(1D0-PS/P(IP,5)))
68533 IF(HX1*(3D0-2D0*HX1).LT.PYR(0)*HXM*(3D0-2D0*HXM)) GOTO 390
68534
68535C...Matrix elements for weak decays (only semileptonic for c and b)
68536 ELSEIF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
68537 & .AND.ND.EQ.3) THEN
68538 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+3)
68539 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+3)
68540 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
68541 ELSEIF(MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48) THEN
68542 DO 550 J=1,4
68543 P(N+NP+1,J)=0D0
68544 DO 540 IS=N+3,N+NP
68545 P(N+NP+1,J)=P(N+NP+1,J)+P(IS,J)
68546 540 CONTINUE
68547 550 CONTINUE
68548 IF(MBST.EQ.0) WT=FOUR(IP,N+1)*FOUR(N+2,N+NP+1)
68549 IF(MBST.EQ.1) WT=P(IP,5)*P(N+1,4)*FOUR(N+2,N+NP+1)
68550 IF(WT.LT.PYR(0)*P(IP,5)*PV(1,5)**3/WTCOR(10)) GOTO 390
68551 ENDIF
68552
68553C...Scale back energy and reattach spectator.
68554 560 IF(MREM.EQ.1) THEN
68555 DO 570 J=1,5
68556 PV(1,J)=PV(1,J)/(1D0-PQT)
68557 570 CONTINUE
68558 ND=ND+1
68559 MREM=0
68560 ENDIF
68561
68562C...Low invariant mass for system with spectator quark gives particle,
68563C...not two jets. Readjust momenta accordingly.
68564 IF(MMAT.EQ.31.AND.ND.EQ.3) THEN
68565 MSTJ(93)=1
68566 PM2=PYMASS(K(N+2,2))
68567 MSTJ(93)=1
68568 PM3=PYMASS(K(N+3,2))
68569 IF(P(N+2,5)**2+P(N+3,5)**2+2D0*FOUR(N+2,N+3).GE.
68570 & (PARJ(32)+PM2+PM3)**2) GOTO 630
68571 K(N+2,1)=1
68572 KFTEMP=K(N+2,2)
68573 CALL PYKFDI(KFTEMP,K(N+3,2),KFLDMP,K(N+2,2))
68574 IF(K(N+2,2).EQ.0) GOTO 260
68575 P(N+2,5)=PYMASS(K(N+2,2))
68576 PS=P(N+1,5)+P(N+2,5)
68577 PV(2,5)=P(N+2,5)
68578 MMAT=0
68579 ND=2
68580 GOTO 460
68581 ELSEIF(MMAT.EQ.44) THEN
68582 MSTJ(93)=1
68583 PM3=PYMASS(K(N+3,2))
68584 MSTJ(93)=1
68585 PM4=PYMASS(K(N+4,2))
68586 IF(P(N+3,5)**2+P(N+4,5)**2+2D0*FOUR(N+3,N+4).GE.
68587 & (PARJ(32)+PM3+PM4)**2) GOTO 600
68588 K(N+3,1)=1
68589 KFTEMP=K(N+3,2)
68590 CALL PYKFDI(KFTEMP,K(N+4,2),KFLDMP,K(N+3,2))
68591 IF(K(N+3,2).EQ.0) GOTO 260
68592 P(N+3,5)=PYMASS(K(N+3,2))
68593 DO 580 J=1,3
68594 P(N+3,J)=P(N+3,J)+P(N+4,J)
68595 580 CONTINUE
68596 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)
68597 HA=P(N+1,4)**2-P(N+2,4)**2
68598 HB=HA-(P(N+1,5)**2-P(N+2,5)**2)
68599 HC=(P(N+1,1)-P(N+2,1))**2+(P(N+1,2)-P(N+2,2))**2+
68600 & (P(N+1,3)-P(N+2,3))**2
68601 HD=(PV(1,4)-P(N+3,4))**2
68602 HE=HA**2-2D0*HD*(P(N+1,4)**2+P(N+2,4)**2)+HD**2
68603 HF=HD*HC-HB**2
68604 HG=HD*HC-HA*HB
68605 HH=(SQRT(HG**2+HE*HF)-HG)/(2D0*HF)
68606 DO 590 J=1,3
68607 PCOR=HH*(P(N+1,J)-P(N+2,J))
68608 P(N+1,J)=P(N+1,J)+PCOR
68609 P(N+2,J)=P(N+2,J)-PCOR
68610 590 CONTINUE
68611 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)
68612 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)
68613 ND=ND-1
68614 ENDIF
68615
68616C...Check invariant mass of W jets. May give one particle or start over.
68617 600 IF((MMAT.EQ.42.OR.MMAT.EQ.43.OR.MMAT.EQ.44.OR.MMAT.EQ.48)
68618 &.AND.IABS(K(N+1,2)).LT.10) THEN
68619 PMR=SQRT(MAX(0D0,P(N+1,5)**2+P(N+2,5)**2+2D0*FOUR(N+1,N+2)))
68620 MSTJ(93)=1
68621 PM1=PYMASS(K(N+1,2))
68622 MSTJ(93)=1
68623 PM2=PYMASS(K(N+2,2))
68624 IF(PMR.GT.PARJ(32)+PM1+PM2) GOTO 610
68625 KFLDUM=INT(1.5D0+PYR(0))
68626 CALL PYKFDI(K(N+1,2),-ISIGN(KFLDUM,K(N+1,2)),KFLDMP,KF1)
68627 CALL PYKFDI(K(N+2,2),-ISIGN(KFLDUM,K(N+2,2)),KFLDMP,KF2)
68628 IF(KF1.EQ.0.OR.KF2.EQ.0) GOTO 260
68629 PSM=PYMASS(KF1)+PYMASS(KF2)
68630 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.PMR.GT.PARJ(64)+PSM) GOTO 610
68631 IF(MMAT.GE.43.AND.PMR.GT.0.2D0*PARJ(32)+PSM) GOTO 610
68632 IF(MMAT.EQ.48) GOTO 390
68633 IF(ND.EQ.4.OR.KFA.EQ.15) GOTO 260
68634 K(N+1,1)=1
68635 KFTEMP=K(N+1,2)
68636 CALL PYKFDI(KFTEMP,K(N+2,2),KFLDMP,K(N+1,2))
68637 IF(K(N+1,2).EQ.0) GOTO 260
68638 P(N+1,5)=PYMASS(K(N+1,2))
68639 K(N+2,2)=K(N+3,2)
68640 P(N+2,5)=P(N+3,5)
68641 PS=P(N+1,5)+P(N+2,5)
68642 IF(PS+PARJ(64).GT.PV(1,5)) GOTO 260
68643 PV(2,5)=P(N+3,5)
68644 MMAT=0
68645 ND=2
68646 GOTO 460
68647 ENDIF
68648
68649C...Phase space decay of partons from W decay.
68650 610 IF((MMAT.EQ.42.OR.MMAT.EQ.48).AND.IABS(K(N+1,2)).LT.10) THEN
68651 KFLO(1)=K(N+1,2)
68652 KFLO(2)=K(N+2,2)
68653 K(N+1,1)=K(N+3,1)
68654 K(N+1,2)=K(N+3,2)
68655 DO 620 J=1,5
68656 PV(1,J)=P(N+1,J)+P(N+2,J)
68657 P(N+1,J)=P(N+3,J)
68658 620 CONTINUE
68659 PV(1,5)=PMR
68660 N=N+1
68661 NP=0
68662 NQ=2
68663 PS=0D0
68664 MSTJ(93)=2
68665 PSQ=PYMASS(KFLO(1))
68666 MSTJ(93)=2
68667 PSQ=PSQ+PYMASS(KFLO(2))
68668 MMAT=11
68669 GOTO 290
68670 ENDIF
68671
68672C...Boost back for rapidly moving particle.
68673 630 N=N+ND
68674 IF(MBST.EQ.1) THEN
68675 DO 640 J=1,3
68676 BE(J)=P(IP,J)/P(IP,4)
68677 640 CONTINUE
68678 GA=P(IP,4)/P(IP,5)
68679 DO 660 I=NSAV+1,N
68680 BEP=BE(1)*P(I,1)+BE(2)*P(I,2)+BE(3)*P(I,3)
68681 DO 650 J=1,3
68682 P(I,J)=P(I,J)+GA*(GA*BEP/(1D0+GA)+P(I,4))*BE(J)
68683 650 CONTINUE
68684 P(I,4)=GA*(P(I,4)+BEP)
68685 660 CONTINUE
68686 ENDIF
68687
68688C...Fill in position of decay vertex.
68689 DO 680 I=NSAV+1,N
68690 DO 670 J=1,4
68691 V(I,J)=VDCY(J)
68692 670 CONTINUE
68693 V(I,5)=0D0
68694 680 CONTINUE
68695
68696C...Set up for parton shower evolution from jets.
68697 IF(MSTJ(23).GE.1.AND.MMAT.EQ.4.AND.K(NSAV+1,2).EQ.21) THEN
68698 K(NSAV+1,1)=3
68699 K(NSAV+2,1)=3
68700 K(NSAV+3,1)=3
68701 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
68702 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
68703 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
68704 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
68705 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
68706 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
68707 MSTJ(92)=-(NSAV+1)
68708 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.4) THEN
68709 K(NSAV+2,1)=3
68710 K(NSAV+3,1)=3
68711 K(NSAV+2,4)=MSTU(5)*(NSAV+3)
68712 K(NSAV+2,5)=MSTU(5)*(NSAV+3)
68713 K(NSAV+3,4)=MSTU(5)*(NSAV+2)
68714 K(NSAV+3,5)=MSTU(5)*(NSAV+2)
68715 MSTJ(92)=NSAV+2
68716 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
68717 & IABS(K(NSAV+1,2)).LE.10.AND.IABS(K(NSAV+2,2)).LE.10) THEN
68718 K(NSAV+1,1)=3
68719 K(NSAV+2,1)=3
68720 K(NSAV+1,4)=MSTU(5)*(NSAV+2)
68721 K(NSAV+1,5)=MSTU(5)*(NSAV+2)
68722 K(NSAV+2,4)=MSTU(5)*(NSAV+1)
68723 K(NSAV+2,5)=MSTU(5)*(NSAV+1)
68724 MSTJ(92)=NSAV+1
68725 ELSEIF(MSTJ(23).GE.1.AND.(MMAT.EQ.32.OR.MMAT.EQ.44).AND.
68726 & IABS(K(NSAV+1,2)).LE.20.AND.IABS(K(NSAV+2,2)).LE.20) THEN
68727 MSTJ(92)=NSAV+1
68728 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33.AND.IABS(K(NSAV+2,2)).EQ.21)
68729 & THEN
68730 K(NSAV+1,1)=3
68731 K(NSAV+2,1)=3
68732 K(NSAV+3,1)=3
68733 KCP=PYCOMP(K(NSAV+1,2))
68734 KQP=KCHG(KCP,2)*ISIGN(1,K(NSAV+1,2))
68735 JCON=4
68736 IF(KQP.LT.0) JCON=5
68737 K(NSAV+1,JCON)=MSTU(5)*(NSAV+2)
68738 K(NSAV+2,9-JCON)=MSTU(5)*(NSAV+1)
68739 K(NSAV+2,JCON)=MSTU(5)*(NSAV+3)
68740 K(NSAV+3,9-JCON)=MSTU(5)*(NSAV+2)
68741 MSTJ(92)=NSAV+1
68742 ELSEIF(MSTJ(23).GE.1.AND.MMAT.EQ.33) THEN
68743 K(NSAV+1,1)=3
68744 K(NSAV+3,1)=3
68745 K(NSAV+1,4)=MSTU(5)*(NSAV+3)
68746 K(NSAV+1,5)=MSTU(5)*(NSAV+3)
68747 K(NSAV+3,4)=MSTU(5)*(NSAV+1)
68748 K(NSAV+3,5)=MSTU(5)*(NSAV+1)
68749 MSTJ(92)=NSAV+1
68750 ENDIF
68751
68752C...Mark decayed particle; special option for B-Bbar mixing.
68753 IF(K(IP,1).EQ.5) K(IP,1)=15
68754 IF(K(IP,1).LE.10) K(IP,1)=11
68755 IF(MMIX.EQ.1.AND.MSTJ(26).EQ.2.AND.K(IP,1).EQ.11) K(IP,1)=12
68756 K(IP,4)=NSAV+1
68757 K(IP,5)=N
68758
68759 RETURN
68760 END
68761
68762
68763C*********************************************************************
68764
68765C...PYDCYK
68766C...Handles flavour production in the decay of unstable particles
68767C...and small string clusters.
68768
68769 SUBROUTINE PYDCYK(KFL1,KFL2,KFL3,KF)
68770
68771C...Double precision and integer declarations.
68772 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68773 IMPLICIT INTEGER(I-N)
68774 INTEGER PYK,PYCHGE,PYCOMP
68775C...Commonblocks.
68776 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68777 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68778 SAVE /PYDAT1/,/PYDAT2/
68779
68780
68781C.. Call PYKFDI directly if no popcorn option is on
68782 IF(MSTJ(12).LT.2) THEN
68783 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
68784 MSTU(124)=KFL3
68785 RETURN
68786 ENDIF
68787
68788 KFL3=0
68789 KF=0
68790 IF(KFL1.EQ.0) RETURN
68791 KF1A=IABS(KFL1)
68792 KF2A=IABS(KFL2)
68793
68794 NSTO=130
68795 NMAX=MIN(MSTU(125),10)
68796
68797C.. Identify rank 0 cluster qq
68798 IRANK=1
68799 IF(KF1A.GT.10.AND.KF1A.LT.10000) IRANK=0
68800
68801 IF(KF2A.GT.0)THEN
68802C.. Join jets: Fails if store not empty
68803 IF(MSTU(121).GT.0) THEN
68804 MSTU(121)=0
68805 RETURN
68806 ENDIF
68807 CALL PYKFDI(KFL1,KFL2,KFL3,KF)
68808 ELSEIF(KF1A.GT.10.AND.MSTU(121).GT.0)THEN
68809C.. Pick popcorn meson from store, return same qq, decrease store
68810 KF=MSTU(NSTO+MSTU(121))
68811 KFL3=-KFL1
68812 MSTU(121)=MSTU(121)-1
68813 ELSE
68814C.. Generate new flavour. Then done if no diquark is generated
68815 100 CALL PYKFDI(KFL1,0,KFL3,KF)
68816 IF(MSTU(121).EQ.-1) GOTO 100
68817 MSTU(124)=KFL3
68818 IF(KF.EQ.0.OR.IABS(KFL3).LE.10) RETURN
68819
68820C.. Simple case if no dynamical popcorn suppressions are considered
68821 IF(MSTJ(12).LT.4) THEN
68822 IF(MSTU(121).EQ.0) RETURN
68823 NMES=1
68824 KFPREV=-KFL3
68825 CALL PYKFDI(KFPREV,0,KFL3,KFM)
68826C.. Due to eta+eta' suppr., a qq->M+qq attempt might end as qq->B+q
68827 IF(IABS(KFL3).LE.10)THEN
68828 KFL3=-KFPREV
68829 RETURN
68830 ENDIF
68831 GOTO 120
68832 ENDIF
68833
68834C test output qq against fake Gamma, then return if no popcorn.
68835 GB=2D0
68836 IF(IRANK.NE.0)THEN
68837 CALL PYZDIS(1,2103,5D0,Z)
68838 GB=5D0*(1D0-Z)/Z
68839 IF(1D0-PARF(192)**GB.LT.PYR(0)) THEN
68840 MSTU(121)=0
68841 GOTO 100
68842 ENDIF
68843 ENDIF
68844 IF(MSTU(121).EQ.0) RETURN
68845
68846C..Set store size memory. Pick fake dynamical variables of qq.
68847 NMES=MSTU(121)
68848 CALL PYPTDI(1,PX3,PY3)
68849 X=1D0
68850 POPM=0D0
68851 G=GB
68852 POPG=GB
68853
68854C.. Pick next popcorn meson, test with fake dynamical variables
68855 110 KFPREV=-KFL3
68856 PX1=-PX3
68857 PY1=-PY3
68858 CALL PYKFDI(KFPREV,0,KFL3,KFM)
68859 IF(MSTU(121).EQ.-1) GOTO 100
68860 CALL PYPTDI(KFL3,PX3,PY3)
68861 PM=PYMASS(KFM)**2+(PX1+PX3)**2+(PY1+PY3)**2
68862 CALL PYZDIS(KFPREV,KFL3,PM,Z)
68863 G=(1D0-Z)*(G+PM/Z)
68864 X=(1D0-Z)*X
68865
68866 PTST=1D0
68867 GTST=1D0
68868 RTST=PYR(0)
68869 IF(MSTJ(12).GT.4)THEN
68870 POPMN=SQRT((1D0-X)*(G/X-GB))
68871 POPM=POPM+PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
68872 PTST=EXP((POPM-POPMN)*PARF(193))
68873 POPM=POPMN
68874 ENDIF
68875 IF(IRANK.NE.0)THEN
68876 POPGN=X*GB
68877 GTST=(1D0-PARF(192)**POPGN)/(1D0-PARF(192)**POPG)
68878 POPG=POPGN
68879 ENDIF
68880 IF(RTST.GT.PTST*GTST)THEN
68881 MSTU(121)=0
68882 IF(RTST.GT.PTST) MSTU(121)=-1
68883 GOTO 100
68884 ENDIF
68885
68886C.. Store meson
68887 120 IF(NMES.LE.NMAX) MSTU(NSTO+MSTU(121)+1)=KFM
68888 IF(MSTU(121).GT.0) GOTO 110
68889
68890C.. Test accepted system size. If OK set global popcorn size variable.
68891 IF(NMES.GT.NMAX)THEN
68892 KF=0
68893 KFL3=0
68894 RETURN
68895 ENDIF
68896 MSTU(121)=NMES
68897 ENDIF
68898
68899 RETURN
68900 END
68901
68902C********************************************************************
68903
68904C...PYKFDI
68905C...Generates a new flavour pair and combines off a hadron
68906
68907 SUBROUTINE PYKFDI(KFL1,KFL2,KFL3,KF)
68908
68909C...Double precision and integer declarations.
68910 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
68911 IMPLICIT INTEGER(I-N)
68912 INTEGER PYK,PYCHGE,PYCOMP
68913C...Commonblocks.
68914 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
68915 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
68916 SAVE /PYDAT1/,/PYDAT2/
68917C...Local arrays.
68918 DIMENSION PD(7)
68919
68920 IF(MSTU(123).EQ.0.AND.MSTJ(12).GE.0) CALL PYKFIN
68921
68922C...Default flavour values. Input consistency checks.
68923 KF1A=IABS(KFL1)
68924 KF2A=IABS(KFL2)
68925 KFL3=0
68926 KF=0
68927 IF(KF1A.EQ.0) RETURN
68928 IF(KF2A.NE.0)THEN
68929 IF(KF1A.LE.10.AND.KF2A.LE.10.AND.KFL1*KFL2.GT.0) RETURN
68930 IF(KF1A.GT.10.AND.KF2A.GT.10) RETURN
68931 IF((KF1A.GT.10.OR.KF2A.GT.10).AND.KFL1*KFL2.LT.0) RETURN
68932 ENDIF
68933
68934C...Check if tabulated flavour probabilities are to be used.
68935 IF(MSTJ(15).EQ.1) THEN
68936 IF(MSTJ(12).GE.5) CALL PYERRM(29,
68937 & '(PYKFDI:) Sorry, option MSTJ(15)=1 not available' //
68938 & ' together with MSTJ(12)>=5 modification')
68939 KTAB1=-1
68940 IF(KF1A.GE.1.AND.KF1A.LE.6) KTAB1=KF1A
68941 KFL1A=MOD(KF1A/1000,10)
68942 KFL1B=MOD(KF1A/100,10)
68943 KFL1S=MOD(KF1A,10)
68944 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1B.GE.1.AND.KFL1B.LE.4)
68945 & KTAB1=6+KFL1A*(KFL1A-2)+2*KFL1B+(KFL1S-1)/2
68946 IF(KFL1A.GE.1.AND.KFL1A.LE.4.AND.KFL1A.EQ.KFL1B) KTAB1=KTAB1-1
68947 IF(KF1A.GE.1.AND.KF1A.LE.6) KFL1A=KF1A
68948 KTAB2=0
68949 IF(KF2A.NE.0) THEN
68950 KTAB2=-1
68951 IF(KF2A.GE.1.AND.KF2A.LE.6) KTAB2=KF2A
68952 KFL2A=MOD(KF2A/1000,10)
68953 KFL2B=MOD(KF2A/100,10)
68954 KFL2S=MOD(KF2A,10)
68955 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2B.GE.1.AND.KFL2B.LE.4)
68956 & KTAB2=6+KFL2A*(KFL2A-2)+2*KFL2B+(KFL2S-1)/2
68957 IF(KFL2A.GE.1.AND.KFL2A.LE.4.AND.KFL2A.EQ.KFL2B) KTAB2=KTAB2-1
68958 ENDIF
68959 IF(KTAB1.GE.0.AND.KTAB2.GE.0) GOTO 140
68960 ENDIF
68961
68962C.. Recognize rank 0 diquark case
68963 100 IRANK=1
68964 KFDIQ=MAX(KF1A,KF2A)
68965 IF(KFDIQ.GT.10.AND.KFDIQ.LT.10000) IRANK=0
68966
68967C.. Join two flavours to meson or baryon. Test for popcorn.
68968 IF(KF2A.GT.0)THEN
68969 MBARY=0
68970 IF(KFDIQ.GT.10) THEN
68971 IF(IRANK.EQ.0.AND.MSTJ(12).LT.5)
68972 & CALL PYNMES(KFDIQ)
68973 IF(MSTU(121).NE.0) THEN
68974 MSTU(121)=0
68975 RETURN
68976 ENDIF
68977 MBARY=2
68978 ENDIF
68979 KFQOLD=KF1A
68980 KFQVER=KF2A
68981 GOTO 130
68982 ENDIF
68983
68984C.. Separate incoming flavours, curtain flavour consistency check
68985 KFIN=KFL1
68986 KFQOLD=KF1A
68987 KFQPOP=KF1A/10000
68988 IF(KF1A.GT.10)THEN
68989 KFIN=-KFL1
68990 KFL1A=MOD(KF1A/1000,10)
68991 KFL1B=MOD(KF1A/100,10)
68992 IF(IRANK.EQ.0)THEN
68993 QAWT=1D0
68994 IF(KFL1A.GE.3) QAWT=PARF(136+KFL1A/4)
68995 IF(KFL1B.GE.3) QAWT=QAWT/PARF(136+KFL1B/4)
68996 KFQPOP=KFL1A+(KFL1B-KFL1A)*INT(1D0/(QAWT+1D0)+PYR(0))
68997 ENDIF
68998 IF(KFQPOP.NE.KFL1B.AND.KFQPOP.NE.KFL1A) THEN
68999 MSTU(121)=0
69000 RETURN
69001 ENDIF
69002 KFQOLD=KFL1A+KFL1B-KFQPOP
69003 ENDIF
69004
69005C...Meson/baryon choice. Set number of mesons if starting a popcorn
69006C...system.
69007 110 MBARY=0
69008 IF(KF1A.LE.10.AND.MSTJ(12).GT.0)THEN
69009 IF(MSTU(121).EQ.-1.OR.(1D0+PARJ(1))*PYR(0).GT.1D0)THEN
69010 MBARY=1
69011 CALL PYNMES(0)
69012 ENDIF
69013 ELSEIF(KF1A.GT.10)THEN
69014 MBARY=2
69015 IF(IRANK.EQ.0) CALL PYNMES(KF1A)
69016 IF(MSTU(121).GT.0) MBARY=-1
69017 ENDIF
69018
69019C..x->H+q: Choose single vertex quark. Jump to form hadron.
69020 IF(MBARY.EQ.0.OR.MBARY.EQ.2)THEN
69021 KFQVER=1+INT((2D0+PARJ(2))*PYR(0))
69022 KFL3=ISIGN(KFQVER,-KFIN)
69023 GOTO 130
69024 ENDIF
69025
69026C..x->H+qq: (IDW=proper PARF position for diquark weights)
69027 IDW=160
69028 IF(MBARY.EQ.1)THEN
69029 IF(MSTU(121).EQ.0) IDW=150
69030 SQWT=PARF(IDW+1)
69031 IF(MSTU(121).GT.0) SQWT=SQWT*PARF(135)*PARF(138)**MSTU(121)
69032 KFQPOP=1+INT((2D0+SQWT)*PYR(0))
69033C.. Shift to s-curtain parameters if needed
69034 IF(KFQPOP.GE.3.AND.MSTJ(12).GE.5)THEN
69035 PARF(194)=PARF(138)*PARF(139)
69036 PARF(193)=PARJ(8)+PARJ(9)
69037 ENDIF
69038 ENDIF
69039
69040C.. x->H+qq: Get vertex quark
69041 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
69042 IDW=MSTU(122)
69043 MSTU(121)=MSTU(121)-1
69044 IF(IDW.EQ.170) THEN
69045 IF(MSTU(121).EQ.0)THEN
69046 IPOS=3*MIN(KFQPOP-1,2)+MIN(KFQOLD-1,2)
69047 ELSE
69048 IPOS=3*3+3*MAX(0,MIN(KFQPOP-2,1))+MIN(KFQOLD-1,2)
69049 ENDIF
69050 ELSE
69051 IF(MSTU(121).EQ.0)THEN
69052 IPOS=3*5+5*MIN(KFQPOP-1,3)+MIN(KFQOLD-1,4)
69053 ELSE
69054 IPOS=3*5+5*4+MIN(KFQOLD-1,4)
69055 ENDIF
69056 ENDIF
69057 IPOS=200+30*IPOS+1
69058
69059 IMES=-1
69060 RMES=PYR(0)*PARF(194)
69061 120 IMES=IMES+1
69062 RMES=RMES-PARF(IPOS+IMES)
69063 IF(IMES.EQ.30) THEN
69064 MSTU(121)=-1
69065 KF=-111
69066 RETURN
69067 ENDIF
69068 IF(RMES.GT.0D0) GOTO 120
69069 KMUL=IMES/5
69070 KFJ=2*KMUL+1
69071 IF(KMUL.EQ.2) KFJ=10003
69072 IF(KMUL.EQ.3) KFJ=10001
69073 IF(KMUL.EQ.4) KFJ=20003
69074 IF(KMUL.EQ.5) KFJ=5
69075 IDIAG=0
69076 KFQVER=MOD(IMES,5)+1
69077 IF(KFQVER.GE.KFQOLD) KFQVER=KFQVER+1
69078 IF(KFQVER.GT.3)THEN
69079 IDIAG=KFQVER-3
69080 KFQVER=KFQOLD
69081 ENDIF
69082 ELSE
69083 IF(MBARY.EQ.-1) IDW=170
69084 SQWT=PARF(IDW+2)
69085 IF(KFQPOP.EQ.3) SQWT=PARF(IDW+3)
69086 IF(KFQPOP.GT.3) SQWT=PARF(IDW+3)*(1D0/PARF(IDW+5)+1D0)/2D0
69087 KFQVER=MIN(3,1+INT((2D0+SQWT)*PYR(0)))
69088 IF(KFQPOP.LT.3.AND.KFQVER.LT.3)THEN
69089 KFQVER=KFQPOP
69090 IF(PYR(0).GT.PARF(IDW+4)) KFQVER=3-KFQPOP
69091 ENDIF
69092 ENDIF
69093
69094C..x->H+qq: form outgoing diquark with KFQPOP flag at 10000-pos
69095 KFLDS=3
69096 IF(KFQPOP.NE.KFQVER)THEN
69097 SWT=PARF(IDW+7)
69098 IF(KFQVER.EQ.3) SWT=PARF(IDW+6)
69099 IF(KFQPOP.GE.3) SWT=PARF(IDW+5)
69100 IF((1D0+SWT)*PYR(0).LT.1D0) KFLDS=1
69101 ENDIF
69102 KFDIQ=900*MAX(KFQVER,KFQPOP)+100*(KFQVER+KFQPOP)+KFLDS
69103 & +10000*KFQPOP
69104 KFL3=ISIGN(KFDIQ,KFIN)
69105
69106C..x->M+y: flavour for meson.
69107 130 IF(MBARY.LE.0)THEN
69108 KFLA=MAX(KFQOLD,KFQVER)
69109 KFLB=MIN(KFQOLD,KFQVER)
69110 KFS=ISIGN(1,KFL1)
69111 IF(KFLA.NE.KFQOLD) KFS=-KFS
69112C... Form meson, with spin and flavour mixing for diagonal states.
69113 IF(MBARY.EQ.-1.AND.MSTJ(12).GE.5)THEN
69114 IF(IDIAG.GT.0) KF=110*IDIAG+KFJ
69115 IF(IDIAG.EQ.0) KF=(100*KFLA+10*KFLB+KFJ)*KFS*(-1)**KFLA
69116 RETURN
69117 ENDIF
69118 IF(KFLA.LE.2) KMUL=INT(PARJ(11)+PYR(0))
69119 IF(KFLA.EQ.3) KMUL=INT(PARJ(12)+PYR(0))
69120 IF(KFLA.GE.4) KMUL=INT(PARJ(13)+PYR(0))
69121 IF(KMUL.EQ.0.AND.PARJ(14).GT.0D0)THEN
69122 IF(PYR(0).LT.PARJ(14)) KMUL=2
69123 ELSEIF(KMUL.EQ.1.AND.PARJ(15)+PARJ(16)+PARJ(17).GT.0D0)THEN
69124 RMUL=PYR(0)
69125 IF(RMUL.LT.PARJ(15)) KMUL=3
69126 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)) KMUL=4
69127 IF(KMUL.EQ.1.AND.RMUL.LT.PARJ(15)+PARJ(16)+PARJ(17)) KMUL=5
69128 ENDIF
69129 KFLS=3
69130 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
69131 IF(KMUL.EQ.5) KFLS=5
69132 IF(KFLA.NE.KFLB)THEN
69133 KF=(100*KFLA+10*KFLB+KFLS)*KFS*(-1)**KFLA
69134 ELSE
69135 RMIX=PYR(0)
69136 IMIX=2*KFLA+10*KMUL
69137 IF(KFLA.LE.3) KF=110*(1+INT(RMIX+PARF(IMIX-1))+
69138 & INT(RMIX+PARF(IMIX)))+KFLS
69139 IF(KFLA.GE.4) KF=110*KFLA+KFLS
69140 ENDIF
69141 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KF=KF+ISIGN(10000,KF)
69142 IF(KMUL.EQ.4) KF=KF+ISIGN(20000,KF)
69143
69144C..Optional extra suppression of eta and eta'.
69145C..Allow shift to qq->B+q in old version (set IRANK to 0)
69146 IF(KF.EQ.221.OR.KF.EQ.331)THEN
69147 IF(PYR(0).GT.PARJ(25+KF/300))THEN
69148 IF(KF2A.GT.0) GOTO 130
69149 IF(MSTJ(12).LT.4) IRANK=0
69150 GOTO 110
69151 ENDIF
69152 ENDIF
69153 MSTU(121)=0
69154
69155C.. x->B+y: Flavour for baryon
69156 ELSE
69157 KFLA=KFQVER
69158 IF(KF1A.LE.10) KFLA=KFQOLD
69159 KFLB=MOD(KFDIQ/1000,10)
69160 KFLC=MOD(KFDIQ/100,10)
69161 KFLDS=MOD(KFDIQ,10)
69162 KFLD=MAX(KFLA,KFLB,KFLC)
69163 KFLF=MIN(KFLA,KFLB,KFLC)
69164 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
69165
69166C... SU(6) factors for formation of baryon.
69167 KBARY=3
69168 KDMAX=5
69169 KFLG=KFLB
69170 IF(KFLB.NE.KFLC)THEN
69171 KBARY=2*KFLDS-1
69172 KDMAX=1+KFLDS/2
69173 IF(KFLB.GT.2) KDMAX=KDMAX+2
69174 ENDIF
69175 IF(KFLA.NE.KFLB.AND.KFLA.NE.KFLC)THEN
69176 KBARY=KBARY+1
69177 KFLG=KFLA
69178 ENDIF
69179
69180 SU6MAX=PARF(140+KDMAX)
69181 SU6DEC=PARJ(18)
69182 SU6S =PARF(146)
69183 IF(MSTJ(12).GE.5.AND.IRANK.EQ.0) THEN
69184 SU6MAX=1D0
69185 SU6DEC=1D0
69186 SU6S =1D0
69187 ENDIF
69188 SU6OCT=PARF(60+KBARY)
69189 IF(KFLG.GT.MAX(KFLA+KFLB-KFLG,2))THEN
69190 SU6OCT=SU6OCT*4*SU6S/(3*SU6S+1)
69191 IF(KBARY.EQ.2) SU6OCT=PARF(60+KBARY)*4/(3*SU6S+1)
69192 ELSE
69193 IF(KBARY.EQ.6) SU6OCT=SU6OCT*(3+SU6S)/(3*SU6S+1)
69194 ENDIF
69195 SU6WT=SU6OCT+SU6DEC*PARF(70+KBARY)
69196
69197C.. SU(6) test. Old options enforce new baryon if q->B+qq is rejected.
69198 IF(SU6WT.LT.PYR(0)*SU6MAX.AND.KF2A.EQ.0)THEN
69199 MSTU(121)=0
69200 IF(MSTJ(12).LE.2.AND.MBARY.EQ.1) MSTU(121)=-1
69201 GOTO 110
69202 ENDIF
69203
69204C.. Form baryon. Distinguish Lambda- and Sigmalike baryons.
69205 KSIG=1
69206 KFLS=2
69207 IF(SU6WT*PYR(0).GT.SU6OCT) KFLS=4
69208 IF(KFLS.EQ.2.AND.KFLD.GT.KFLE.AND.KFLE.GT.KFLF)THEN
69209 KSIG=KFLDS/3
69210 IF(KFLA.NE.KFLD) KSIG=INT(3*SU6S/(3*SU6S+KFLDS**2)+PYR(0))
69211 ENDIF
69212 KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+KFLS,KFL1)
69213 IF(KSIG.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+KFLS,KFL1)
69214 ENDIF
69215 RETURN
69216
69217C...Use tabulated probabilities to select new flavour and hadron.
69218 140 IF(KTAB2.EQ.0.AND.MSTJ(12).LE.0) THEN
69219 KT3L=1
69220 KT3U=6
69221 ELSEIF(KTAB2.EQ.0.AND.KTAB1.GE.7.AND.MSTJ(12).LE.1) THEN
69222 KT3L=1
69223 KT3U=6
69224 ELSEIF(KTAB2.EQ.0) THEN
69225 KT3L=1
69226 KT3U=22
69227 ELSE
69228 KT3L=KTAB2
69229 KT3U=KTAB2
69230 ENDIF
69231 RFL=0D0
69232 DO 160 KTS=0,2
69233 DO 150 KT3=KT3L,KT3U
69234 RFL=RFL+PARF(120+80*KTAB1+25*KTS+KT3)
69235 150 CONTINUE
69236 160 CONTINUE
69237 RFL=PYR(0)*RFL
69238 DO 180 KTS=0,2
69239 KTABS=KTS
69240 DO 170 KT3=KT3L,KT3U
69241 KTAB3=KT3
69242 RFL=RFL-PARF(120+80*KTAB1+25*KTS+KT3)
69243 IF(RFL.LE.0D0) GOTO 190
69244 170 CONTINUE
69245 180 CONTINUE
69246 190 CONTINUE
69247
69248C...Reconstruct flavour of produced quark/diquark.
69249 IF(KTAB3.LE.6) THEN
69250 KFL3A=KTAB3
69251 KFL3B=0
69252 KFL3=ISIGN(KFL3A,KFL1*(2*KTAB1-13))
69253 ELSE
69254 KFL3A=1
69255 IF(KTAB3.GE.8) KFL3A=2
69256 IF(KTAB3.GE.11) KFL3A=3
69257 IF(KTAB3.GE.16) KFL3A=4
69258 KFL3B=(KTAB3-6-KFL3A*(KFL3A-2))/2
69259 KFL3=1000*KFL3A+100*KFL3B+1
69260 IF(KFL3A.EQ.KFL3B.OR.KTAB3.NE.6+KFL3A*(KFL3A-2)+2*KFL3B) KFL3=
69261 & KFL3+2
69262 KFL3=ISIGN(KFL3,KFL1*(13-2*KTAB1))
69263 ENDIF
69264
69265C...Reconstruct meson code.
69266 IF(KFL3A.EQ.KFL1A.AND.KFL3B.EQ.KFL1B.AND.(KFL3A.LE.3.OR.
69267 &KFL3B.NE.0)) THEN
69268 RFL=PYR(0)*(PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
69269 & 25*KTABS)+PARF(145+80*KTAB1+25*KTABS))
69270 KF=110+2*KTABS+1
69271 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)) KF=220+2*KTABS+1
69272 IF(RFL.GT.PARF(143+80*KTAB1+25*KTABS)+PARF(144+80*KTAB1+
69273 & 25*KTABS)) KF=330+2*KTABS+1
69274 ELSEIF(KTAB1.LE.6.AND.KTAB3.LE.6) THEN
69275 KFLA=MAX(KTAB1,KTAB3)
69276 KFLB=MIN(KTAB1,KTAB3)
69277 KFS=ISIGN(1,KFL1)
69278 IF(KFLA.NE.KF1A) KFS=-KFS
69279 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
69280 ELSEIF(KTAB1.GE.7.AND.KTAB3.GE.7) THEN
69281 KFS=ISIGN(1,KFL1)
69282 IF(KFL1A.EQ.KFL3A) THEN
69283 KFLA=MAX(KFL1B,KFL3B)
69284 KFLB=MIN(KFL1B,KFL3B)
69285 IF(KFLA.NE.KFL1B) KFS=-KFS
69286 ELSEIF(KFL1A.EQ.KFL3B) THEN
69287 KFLA=KFL3A
69288 KFLB=KFL1B
69289 KFS=-KFS
69290 ELSEIF(KFL1B.EQ.KFL3A) THEN
69291 KFLA=KFL1A
69292 KFLB=KFL3B
69293 ELSEIF(KFL1B.EQ.KFL3B) THEN
69294 KFLA=MAX(KFL1A,KFL3A)
69295 KFLB=MIN(KFL1A,KFL3A)
69296 IF(KFLA.NE.KFL1A) KFS=-KFS
69297 ELSE
69298 CALL PYERRM(2,'(PYKFDI:) no matching flavours for qq -> qq')
69299 GOTO 100
69300 ENDIF
69301 KF=(100*KFLA+10*KFLB+2*KTABS+1)*KFS*(-1)**KFLA
69302
69303C...Reconstruct baryon code.
69304 ELSE
69305 IF(KTAB1.GE.7) THEN
69306 KFLA=KFL3A
69307 KFLB=KFL1A
69308 KFLC=KFL1B
69309 ELSE
69310 KFLA=KFL1A
69311 KFLB=KFL3A
69312 KFLC=KFL3B
69313 ENDIF
69314 KFLD=MAX(KFLA,KFLB,KFLC)
69315 KFLF=MIN(KFLA,KFLB,KFLC)
69316 KFLE=KFLA+KFLB+KFLC-KFLD-KFLF
69317 IF(KTABS.EQ.0) KF=ISIGN(1000*KFLD+100*KFLF+10*KFLE+2,KFL1)
69318 IF(KTABS.GE.1) KF=ISIGN(1000*KFLD+100*KFLE+10*KFLF+2*KTABS,KFL1)
69319 ENDIF
69320
69321C...Check that constructed flavour code is an allowed one.
69322 IF(KFL2.NE.0) KFL3=0
69323 KC=PYCOMP(KF)
69324 IF(KC.EQ.0) THEN
69325 CALL PYERRM(2,'(PYKFDI:) user-defined flavour probabilities '//
69326 & 'failed')
69327 GOTO 100
69328 ENDIF
69329
69330 RETURN
69331 END
69332
69333C*********************************************************************
69334
69335C...PYNMES
69336C...Generates number of popcorn mesons and stores some relevant
69337C...parameters.
69338
69339 SUBROUTINE PYNMES(KFDIQ)
69340
69341C...Double precision and integer declarations.
69342 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69343 IMPLICIT INTEGER(I-N)
69344 INTEGER PYK,PYCHGE,PYCOMP
69345C...Commonblocks.
69346 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69347 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69348 SAVE /PYDAT1/,/PYDAT2/
69349
69350 MSTU(121)=0
69351 IF(MSTJ(12).LT.2) RETURN
69352
69353C..Old version: Get 1 or 0 popcorn mesons
69354 IF(MSTJ(12).LT.5)THEN
69355 POPWT=PARF(131)
69356 IF(KFDIQ.NE.0) THEN
69357 KFDIQA=IABS(KFDIQ)
69358 KFA=MOD(KFDIQA/1000,10)
69359 KFB=MOD(KFDIQA/100,10)
69360 KFS=MOD(KFDIQA,10)
69361 POPWT=PARF(132)
69362 IF(KFA.EQ.3) POPWT=PARF(133)
69363 IF(KFB.EQ.3) POPWT=PARF(134)
69364 IF(KFS.EQ.1) POPWT=POPWT*SQRT(PARJ(4))
69365 ENDIF
69366 MSTU(121)=INT(POPWT/(1D0+POPWT)+PYR(0))
69367 RETURN
69368 ENDIF
69369
69370C..New version: Store popcorn- or rank 0 diquark parameters
69371 MSTU(122)=170
69372 PARF(193)=PARJ(8)
69373 PARF(194)=PARF(139)
69374 IF(KFDIQ.NE.0) THEN
69375 MSTU(122)=180
69376 PARF(193)=PARJ(10)
69377 PARF(194)=PARF(140)
69378 ENDIF
69379 IF(PARF(194).LT.1D-5.OR.PARF(194).GT.1D0-1D-5) THEN
69380 IF(PARF(194).GT.1D0-1D-5) CALL PYERRM(9,
69381 & '(PYNMES:) Neglecting too large popcorn possibility')
69382 RETURN
69383 ENDIF
69384
69385C..New version: Get number of popcorn mesons
69386 100 RTST=PYR(0)
69387 MSTU(121)=-1
69388 110 MSTU(121)=MSTU(121)+1
69389 RTST=RTST/PARF(194)
69390 IF(RTST.LT.1D0) GOTO 110
69391 IF(KFDIQ.EQ.0.AND.PYR(0)*(2D0+PARF(135)*PARF(161)).GT.
69392 & (2D0+PARF(135)*PARF(161)*PARF(138)**MSTU(121))) GOTO 100
69393 RETURN
69394 END
69395
69396C***************************************************************
69397
69398C...PYKFIN
69399C...Precalculates a set of diquark and popcorn weights.
69400
69401 SUBROUTINE PYKFIN
69402
69403C...Double precision and integer declarations.
69404 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69405 IMPLICIT INTEGER(I-N)
69406 INTEGER PYK,PYCHGE,PYCOMP
69407C...Commonblocks.
69408 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69409 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69410 SAVE /PYDAT1/,/PYDAT2/
69411
69412 DIMENSION SU6(12),SU6M(7),QBB(7),QBM(7),DMB(14)
69413
69414
69415 MSTU(123)=1
69416C..Diquark indices for dimensional variables
69417 IUD1=1
69418 IUU1=2
69419 IUS0=3
69420 ISU0=4
69421 IUS1=5
69422 ISU1=6
69423 ISS1=7
69424
69425C.. *** SU(6) factors **
69426C..Modify with decuplet- (and Sigma/Lambda-) suppression.
69427 PARF(146)=1D0
69428 IF(MSTJ(12).GE.5) PARF(146)=3D0*PARJ(18)/(2D0*PARJ(18)+1D0)
69429 IF(PARJ(18).LT.1D0-1D-5.AND.MSTJ(12).LT.5) CALL PYERRM(9,
69430 & '(PYKFIN:) PARJ(18)<1 combined with 0<MSTJ(12)<5 option')
69431 DO 100 I=1,6
69432 SU6(I)=PARF(60+I)
69433 SU6(6+I)=SU6(I)*4*PARF(146)/(3*PARF(146)+1)
69434 100 CONTINUE
69435 SU6(8)=SU6(2)*4/(3*PARF(146)+1)
69436 SU6(6)=SU6(6)*(3+PARF(146))/(3*PARF(146)+1)
69437 DO 110 I=1,6
69438 SU6(I)=SU6(I)+PARJ(18)*PARF(70+I)
69439 SU6(6+I)=SU6(6+I)+PARJ(18)*PARF(70+I)
69440 110 CONTINUE
69441
69442C..SU(6)max q q' s,c,b
69443 SU6MUD =MAX(SU6(1) , SU6(8) )
69444 SU6M(IUD1)=MAX(SU6(5) , SU6(12))
69445 SU6M(ISU0)=MAX(SU6(7) ,SU6(2),SU6MUD )
69446 SU6M(IUU1)=MAX(SU6(3) ,SU6(4),SU6(10))
69447 SU6M(ISU1)=MAX(SU6(11),SU6(6),SU6M(IUD1))
69448 SU6M(IUS0)=SU6M(ISU0)
69449 SU6M(ISS1)=SU6M(IUU1)
69450 SU6M(IUS1)=SU6M(ISU1)
69451
69452C..Store SU(6)max, in order UD0,UD1,US0,US1,QQ1
69453 PARF(141)=SU6MUD
69454 PARF(142)=SU6M(IUD1)
69455 PARF(143)=SU6M(ISU0)
69456 PARF(144)=SU6M(ISU1)
69457 PARF(145)=SU6M(ISS1)
69458
69459C..diquark SU(6) survival =
69460C..sum over quark (quark tunnel weight)*(SU(6)).
69461 PUD0=(2D0*SU6(1)+PARJ(2)*SU6(8))
69462 DMB(ISU0)=(SU6(7)+SU6(2)+PARJ(2)*SU6(1))/PUD0
69463 DMB(IUS0)=DMB(ISU0)
69464 DMB(ISS1)=(2D0*SU6(4)+PARJ(2)*SU6(3))/PUD0
69465 DMB(IUU1)=(SU6(3)+SU6(4)+PARJ(2)*SU6(10))/PUD0
69466 DMB(ISU1)=(SU6(11)+SU6(6)+PARJ(2)*SU6(5))/PUD0
69467 DMB(IUS1)=DMB(ISU1)
69468 DMB(IUD1)=(2D0*SU6(5)+PARJ(2)*SU6(12))/PUD0
69469
69470C.. *** Tunneling factors for Diquark production***
69471C.. T: half a curtain pair = sqrt(curtain pair factor)
69472 IF(MSTJ(12).GE.5) THEN
69473 PMUD0=PYMASS(2101)
69474 PMUD1=PYMASS(2103)-PMUD0
69475 PMUS0=PYMASS(3201)-PMUD0
69476 PMUS1=PYMASS(3203)-PMUS0-PMUD0
69477 PMSS1=PYMASS(3303)-PMUS0-PMUD0
69478 QBB(ISU0)=EXP(-(PARJ(9)+PARJ(8))*PMUS0-PARJ(9)*PARF(191))
69479 QBB(IUS0)=EXP(-PARJ(8)*PMUS0)
69480 QBB(ISS1)=EXP(-(PARJ(9)+PARJ(8))*PMSS1)*QBB(ISU0)
69481 QBB(IUU1)=EXP(-PARJ(8)*PMUD1)
69482 QBB(ISU1)=EXP(-(PARJ(9)+PARJ(8))*PMUS1)*QBB(ISU0)
69483 QBB(IUS1)=EXP(-PARJ(8)*PMUS1)*QBB(IUS0)
69484 QBB(IUD1)=QBB(IUU1)
69485 ELSE
69486 PAR2M=SQRT(PARJ(2))
69487 PAR3M=SQRT(PARJ(3))
69488 PAR4M=SQRT(PARJ(4))
69489 QBB(ISU0)=PAR2M*PAR3M
69490 QBB(IUS0)=PAR3M
69491 QBB(ISS1)=PAR2M*PARJ(3)*PAR4M
69492 QBB(IUU1)=PAR4M
69493 QBB(ISU1)=PAR4M*QBB(ISU0)
69494 QBB(IUS1)=PAR4M*QBB(IUS0)
69495 QBB(IUD1)=PAR4M
69496 ENDIF
69497
69498C.. tau: spin*(vertex factor)*(T = half-curtain factor)
69499 QBM(ISU0)=QBB(ISU0)
69500 QBM(IUS0)=PARJ(2)*QBB(IUS0)
69501 QBM(ISS1)=PARJ(2)*6D0*QBB(ISS1)
69502 QBM(IUU1)=6D0*QBB(IUU1)
69503 QBM(ISU1)=3D0*QBB(ISU1)
69504 QBM(IUS1)=PARJ(2)*3D0*QBB(IUS1)
69505 QBM(IUD1)=3D0*QBB(IUD1)
69506
69507C.. Combine T and tau to diquark weight for q-> B+B+..
69508 DO 120 I=1,7
69509 QBB(I)=QBB(I)*QBM(I)
69510 120 CONTINUE
69511
69512 IF(MSTJ(12).GE.5)THEN
69513C..New version: tau for rank 0 diquark.
69514 DMB(7+ISU0)=EXP(-PARJ(10)*PMUS0)
69515 DMB(7+IUS0)=PARJ(2)*DMB(7+ISU0)
69516 DMB(7+ISS1)=6D0*PARJ(2)*EXP(-PARJ(10)*PMSS1)*DMB(7+ISU0)
69517 DMB(7+IUU1)=6D0*EXP(-PARJ(10)*PMUD1)
69518 DMB(7+ISU1)=3D0*EXP(-PARJ(10)*PMUS1)*DMB(7+ISU0)
69519 DMB(7+IUS1)=PARJ(2)*DMB(7+ISU1)
69520 DMB(7+IUD1)=DMB(7+IUU1)/2D0
69521
69522C..New version: curtain flavour ratios.
69523C.. s/u for q->B+M+...
69524C.. s/u for rank 0 diquark: su -> ...M+B+...
69525C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
69526 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
69527 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
69528 WU=1D0+DMB(7+IUD1)+DMB(7+IUS0)+DMB(7+IUS1)+DMB(7+IUU1)
69529 PARF(136)=(2D0*(DMB(7+ISU0)+DMB(7+ISU1))+DMB(7+ISS1))/WU
69530 PARF(137)=(DMB(7+ISU0)+DMB(7+ISU1))*
69531 & (2D0+DMB(7+ISS1)/(2D0*DMB(7+ISU1)))/WU
69532 ELSE
69533C..Old version: reset unused rank 0 diquark weights and
69534C.. unused diquark SU(6) survival weights
69535 DO 130 I=1,7
69536 IF(MSTJ(12).LT.3) DMB(I)=1D0
69537 DMB(7+I)=1D0
69538 130 CONTINUE
69539
69540C..Old version: Shuffle PARJ(7) into tau
69541 QBM(IUS0)=QBM(IUS0)*PARJ(7)
69542 QBM(ISS1)=QBM(ISS1)*PARJ(7)
69543 QBM(IUS1)=QBM(IUS1)*PARJ(7)
69544
69545C..Old version: curtain flavour ratios.
69546C.. s/u for q->B+M+...
69547C.. s/u for rank 0 diquark: su -> ...M+B+...
69548C.. Q/q for heavy rank 0 diquark: Qu -> ...M+B+...
69549 WU=1D0+QBM(IUD1)+QBM(IUS0)+QBM(IUS1)+QBM(IUU1)
69550 PARF(135)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/WU
69551 PARF(136)=PARF(135)*PARJ(6)*QBM(ISU0)/QBM(IUS0)
69552 PARF(137)=(1D0+QBM(IUD1))*(2D0+QBM(IUS0))/WU
69553 ENDIF
69554
69555C..Combine diquark SU(6) survival, SU(6)max, tau and T into factors for:
69556C.. rank0 D->M+B+..; D->M+B+..; q->B+M+..; q->B+B..
69557 DO 140 I=1,7
69558 DMB(7+I)=DMB(7+I)*DMB(I)
69559 DMB(I)=DMB(I)*QBM(I)
69560 QBM(I)=QBM(I)*SU6M(I)/SU6MUD
69561 QBB(I)=QBB(I)*SU6M(I)/SU6MUD
69562 140 CONTINUE
69563
69564C.. *** Popcorn factors ***
69565
69566 IF(MSTJ(12).LT.5)THEN
69567C.. Old version: Resulting popcorn weights.
69568 PARF(138)=PARJ(6)
69569 WS=PARF(135)*PARF(138)
69570 WQ=WU*PARJ(5)/3D0
69571 PARF(132)=WQ*QBM(IUD1)/QBB(IUD1)
69572 PARF(133)=WQ*
69573 & (QBM(IUS1)/QBB(IUS1)+WS*QBM(ISU1)/QBB(ISU1))/2D0
69574 PARF(134)=WQ*WS*QBM(ISS1)/QBB(ISS1)
69575 PARF(131)=WQ*(1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1)+
69576 & WS*(QBM(ISU0)+QBM(ISU1)+QBM(ISS1)/2D0))/
69577 & (1D0+QBB(IUD1)+QBB(IUU1)+
69578 & 2D0*(QBB(IUS0)+QBB(IUS1))+QBB(ISS1)/2D0)
69579 ELSE
69580C..New version: Store weights for popcorn mesons,
69581C..get prel. popcorn weights.
69582 DO 150 IPOS=201,1400
69583 PARF(IPOS)=0D0
69584 150 CONTINUE
69585 DO 160 I=138,140
69586 PARF(I)=0D0
69587 160 CONTINUE
69588 IPOS=200
69589 PARF(193)=PARJ(8)
69590 DO 240 MR=0,7,7
69591 IF(MR.EQ.7) PARF(193)=PARJ(10)
69592 SQWT=2D0*(DMB(MR+IUS0)+DMB(MR+IUS1))/
69593 & (1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
69594 QQWT=DMB(MR+IUU1)/(1D0+DMB(MR+IUD1)+DMB(MR+IUU1))
69595 DO 230 NMES=0,1
69596 IF(NMES.EQ.1) SQWT=PARJ(2)
69597 DO 220 KFQPOP=1,4
69598 IF(MR.EQ.0.AND.KFQPOP.GT.3) GOTO 220
69599 IF(NMES.EQ.0.AND.KFQPOP.GE.3)THEN
69600 SQWT=DMB(MR+ISS1)/(DMB(MR+ISU0)+DMB(MR+ISU1))
69601 QQWT=0.5D0
69602 IF(MR.EQ.0) PARF(193)=PARJ(8)+PARJ(9)
69603 IF(KFQPOP.EQ.4) SQWT=SQWT*(1D0/DMB(7+ISU1)+1D0)/2D0
69604 ENDIF
69605 DO 210 KFQOLD =1,5
69606 IF(MR.EQ.0.AND.KFQOLD.GT.3) GOTO 210
69607 IF(NMES.EQ.1) THEN
69608 IF(MR.EQ.0.AND.KFQPOP.EQ.1) GOTO 210
69609 IF(MR.EQ.7.AND.KFQPOP.NE.1) GOTO 210
69610 ENDIF
69611 WTTOT=0D0
69612 WTFAIL=0D0
69613 DO 190 KMUL=0,5
69614 PJWT=PARJ(12+KMUL)
69615 IF(KMUL.EQ.0) PJWT=1D0-PARJ(14)
69616 IF(KMUL.EQ.1) PJWT=1D0-PARJ(15)-PARJ(16)-PARJ(17)
69617 IF(PJWT.LE.0D0) GOTO 190
69618 IF(PJWT.GT.1D0) PJWT=1D0
69619 IMES=5*KMUL
69620 IMIX=2*KFQOLD+10*KMUL
69621 KFJ=2*KMUL+1
69622 IF(KMUL.EQ.2) KFJ=10003
69623 IF(KMUL.EQ.3) KFJ=10001
69624 IF(KMUL.EQ.4) KFJ=20003
69625 IF(KMUL.EQ.5) KFJ=5
69626 DO 180 KFQVER =1,3
69627 KFLA=MAX(KFQOLD,KFQVER)
69628 KFLB=MIN(KFQOLD,KFQVER)
69629 SWT=PARJ(11+KFLA/3+KFLA/4)
69630 IF(KMUL.EQ.0.OR.KMUL.EQ.2) SWT=1D0-SWT
69631 SWT=SWT*PJWT
69632 QWT=SQWT/(2D0+SQWT)
69633 IF(KFQVER.LT.3)THEN
69634 IF(KFQVER.EQ.KFQPOP) QWT=(1D0-QWT)*QQWT
69635 IF(KFQVER.NE.KFQPOP) QWT=(1D0-QWT)*(1D0-QQWT)
69636 ENDIF
69637 IF(KFQVER.NE.KFQOLD)THEN
69638 IMES=IMES+1
69639 KFM=100*KFLA+10*KFLB+KFJ
69640 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
69641 PARF(IPOS+IMES)=QWT*SWT*EXP(-PARF(193)*PMM)
69642 WTTOT=WTTOT+PARF(IPOS+IMES)
69643 ELSE
69644 DO 170 ID=3,5
69645 IF(ID.EQ.3) DWT=1D0-PARF(IMIX-1)
69646 IF(ID.EQ.4) DWT=PARF(IMIX-1)-PARF(IMIX)
69647 IF(ID.EQ.5) DWT=PARF(IMIX)
69648 KFM=110*(ID-2)+KFJ
69649 PMM=PMAS(PYCOMP(KFM),1)-PMAS(PYCOMP(KFM),3)
69650 PARF(IPOS+5*KMUL+ID)=QWT*SWT*DWT*EXP(-PARF(193)*PMM)
69651 IF(KMUL.EQ.0.AND.ID.GT.3) THEN
69652 WTFAIL=WTFAIL+QWT*SWT*DWT*(1D0-PARJ(21+ID))
69653 PARF(IPOS+5*KMUL+ID)=
69654 & PARF(IPOS+5*KMUL+ID)*PARJ(21+ID)
69655 ENDIF
69656 WTTOT=WTTOT+PARF(IPOS+5*KMUL+ID)
69657 170 CONTINUE
69658 ENDIF
69659 180 CONTINUE
69660 190 CONTINUE
69661 DO 200 IMES=1,30
69662 PARF(IPOS+IMES)=PARF(IPOS+IMES)/(1D0-WTFAIL)
69663 200 CONTINUE
69664 IF(MR.EQ.7) PARF(140)=
69665 & MAX(PARF(140),WTTOT/(1D0-WTFAIL))
69666 IF(MR.EQ.0) PARF(139-KFQPOP/3)=
69667 & MAX(PARF(139-KFQPOP/3),WTTOT/(1D0-WTFAIL))
69668 IPOS=IPOS+30
69669 210 CONTINUE
69670 220 CONTINUE
69671 230 CONTINUE
69672 240 CONTINUE
69673 IF(PARF(139).GT.1D-10) PARF(138)=PARF(138)/PARF(139)
69674 MSTU(121)=0
69675
69676 ENDIF
69677
69678C..Recombine diquark weights to flavour and spin ratios
69679 PARF(151)=(2D0*(QBB(ISU0)+QBB(ISU1))+QBB(ISS1))/
69680 & (1D0+QBB(IUD1)+QBB(IUU1)+QBB(IUS0)+QBB(IUS1))
69681 PARF(152)=2D0*(QBB(IUS0)+QBB(IUS1))/(1D0+QBB(IUD1)+QBB(IUU1))
69682 PARF(153)=QBB(ISS1)/(QBB(ISU0)+QBB(ISU1))
69683 PARF(154)=QBB(IUU1)/(1D0+QBB(IUD1)+QBB(IUU1))
69684 PARF(155)=QBB(ISU1)/QBB(ISU0)
69685 PARF(156)=QBB(IUS1)/QBB(IUS0)
69686 PARF(157)=QBB(IUD1)
69687
69688 PARF(161)=(2D0*(QBM(ISU0)+QBM(ISU1))+QBM(ISS1))/
69689 & (1D0+QBM(IUD1)+QBM(IUU1)+QBM(IUS0)+QBM(IUS1))
69690 PARF(162)=2D0*(QBM(IUS0)+QBM(IUS1))/(1D0+QBM(IUD1)+QBM(IUU1))
69691 PARF(163)=QBM(ISS1)/(QBM(ISU0)+QBM(ISU1))
69692 PARF(164)=QBM(IUU1)/(1D0+QBM(IUD1)+QBM(IUU1))
69693 PARF(165)=QBM(ISU1)/QBM(ISU0)
69694 PARF(166)=QBM(IUS1)/QBM(IUS0)
69695 PARF(167)=QBM(IUD1)
69696
69697 PARF(171)=(2D0*(DMB(ISU0)+DMB(ISU1))+DMB(ISS1))/
69698 & (1D0+DMB(IUD1)+DMB(IUU1)+DMB(IUS0)+DMB(IUS1))
69699 PARF(172)=2D0*(DMB(IUS0)+DMB(IUS1))/(1D0+DMB(IUD1)+DMB(IUU1))
69700 PARF(173)=DMB(ISS1)/(DMB(ISU0)+DMB(ISU1))
69701 PARF(174)=DMB(IUU1)/(1D0+DMB(IUD1)+DMB(IUU1))
69702 PARF(175)=DMB(ISU1)/DMB(ISU0)
69703 PARF(176)=DMB(IUS1)/DMB(IUS0)
69704 PARF(177)=DMB(IUD1)
69705
69706 PARF(185)=DMB(7+ISU1)/DMB(7+ISU0)
69707 PARF(186)=DMB(7+IUS1)/DMB(7+IUS0)
69708 PARF(187)=DMB(7+IUD1)
69709
69710 RETURN
69711 END
69712
69713
69714C*********************************************************************
69715
69716C...PYPTDI
69717C...Generates transverse momentum according to a Gaussian.
69718
69719 SUBROUTINE PYPTDI(KFL,PX,PY)
69720
69721C...Double precision and integer declarations.
69722 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69723 IMPLICIT INTEGER(I-N)
69724 INTEGER PYK,PYCHGE,PYCOMP
69725C...Commonblocks.
69726 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69727 SAVE /PYDAT1/
69728
69729C...Generate p_T and azimuthal angle, gives p_x and p_y.
69730 KFLA=IABS(KFL)
69731 PT=PARJ(21)*SQRT(-LOG(MAX(1D-10,PYR(0))))
69732 IF(PARJ(23).GT.PYR(0)) PT=PARJ(24)*PT
69733 IF(MSTJ(91).EQ.1) PT=PARJ(22)*PT
69734 IF(KFLA.EQ.0.AND.MSTJ(13).LE.0) PT=0D0
69735 PHI=PARU(2)*PYR(0)
69736 PX=PT*COS(PHI)
69737 PY=PT*SIN(PHI)
69738
69739 RETURN
69740 END
69741
69742C*********************************************************************
69743
69744C...PYZDIS
69745C...Generates the longitudinal splitting variable z.
69746
69747 SUBROUTINE PYZDIS(KFL1,KFL2,PR,Z)
69748
69749C...Double precision and integer declarations.
69750 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69751 IMPLICIT INTEGER(I-N)
69752 INTEGER PYK,PYCHGE,PYCOMP
69753C...Commonblocks.
69754 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69755 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69756 SAVE /PYDAT1/,/PYDAT2/
69757
69758C...Check if heavy flavour fragmentation.
69759 KFLA=IABS(KFL1)
69760 KFLB=IABS(KFL2)
69761 KFLH=KFLA
69762 IF(KFLA.GE.10) KFLH=MOD(KFLA/1000,10)
69763
69764C...Lund symmetric scaling function: determine parameters of shape.
69765 IF(MSTJ(11).EQ.1.OR.(MSTJ(11).EQ.3.AND.KFLH.LE.3).OR.
69766 &MSTJ(11).GE.4) THEN
69767 FA=PARJ(41)
69768 IF(MSTJ(91).EQ.1) FA=PARJ(43)
69769 IF(KFLB.GE.10) FA=FA+PARJ(45)
69770 FBB=PARJ(42)
69771 IF(MSTJ(91).EQ.1) FBB=PARJ(44)
69772 FB=FBB*PR
69773 FC=1D0
69774 IF(KFLA.GE.10) FC=FC-PARJ(45)
69775 IF(KFLB.GE.10) FC=FC+PARJ(45)
69776 IF(MSTJ(11).GE.4.AND.(KFLH.EQ.4.OR.KFLH.EQ.5)) THEN
69777 FRED=PARJ(46)
69778 IF(MSTJ(11).EQ.5.AND.KFLH.EQ.5) FRED=PARJ(47)
69779 FC=FC+FRED*FBB*PARF(100+KFLH)**2
69780 ENDIF
69781 MC=1
69782 IF(ABS(FC-1D0).GT.0.01D0) MC=2
69783
69784C...Determine position of maximum. Special cases for a = 0 or a = c.
69785 IF(FA.LT.0.02D0) THEN
69786 MA=1
69787 ZMAX=1D0
69788 IF(FC.GT.FB) ZMAX=FB/FC
69789 ELSEIF(ABS(FC-FA).LT.0.01D0) THEN
69790 MA=2
69791 ZMAX=FB/(FB+FC)
69792 ELSE
69793 MA=3
69794 ZMAX=0.5D0*(FB+FC-SQRT((FB-FC)**2+4D0*FA*FB))/(FC-FA)
69795 IF(ZMAX.GT.0.9999D0.AND.FB.GT.100D0) ZMAX=MIN(ZMAX,1D0-FA/FB)
69796 ENDIF
69797
69798C...Subdivide z range if distribution very peaked near endpoint.
69799 MMAX=2
69800 IF(ZMAX.LT.0.1D0) THEN
69801 MMAX=1
69802 ZDIV=2.75D0*ZMAX
69803 IF(MC.EQ.1) THEN
69804 FINT=1D0-LOG(ZDIV)
69805 ELSE
69806 ZDIVC=ZDIV**(1D0-FC)
69807 FINT=1D0+(1D0-1D0/ZDIVC)/(FC-1D0)
69808 ENDIF
69809 ELSEIF(ZMAX.GT.0.85D0.AND.FB.GT.1D0) THEN
69810 MMAX=3
69811 FSCB=SQRT(4D0+(FC/FB)**2)
69812 ZDIV=FSCB-1D0/ZMAX-(FC/FB)*LOG(ZMAX*0.5D0*(FSCB+FC/FB))
69813 IF(MA.GE.2) ZDIV=ZDIV+(FA/FB)*LOG(1D0-ZMAX)
69814 ZDIV=MIN(ZMAX,MAX(0D0,ZDIV))
69815 FINT=1D0+FB*(1D0-ZDIV)
69816 ENDIF
69817
69818C...Choice of z, preweighted for peaks at low or high z.
69819 100 Z=PYR(0)
69820 FPRE=1D0
69821 IF(MMAX.EQ.1) THEN
69822 IF(FINT*PYR(0).LE.1D0) THEN
69823 Z=ZDIV*Z
69824 ELSEIF(MC.EQ.1) THEN
69825 Z=ZDIV**Z
69826 FPRE=ZDIV/Z
69827 ELSE
69828 Z=(ZDIVC+Z*(1D0-ZDIVC))**(1D0/(1D0-FC))
69829 FPRE=(ZDIV/Z)**FC
69830 ENDIF
69831 ELSEIF(MMAX.EQ.3) THEN
69832 IF(FINT*PYR(0).LE.1D0) THEN
69833 Z=ZDIV+LOG(Z)/FB
69834 FPRE=EXP(FB*(Z-ZDIV))
69835 ELSE
69836 Z=ZDIV+Z*(1D0-ZDIV)
69837 ENDIF
69838 ENDIF
69839
69840C...Weighting according to correct formula.
69841 IF(Z.LE.0D0.OR.Z.GE.1D0) GOTO 100
69842 FEXP=FC*LOG(ZMAX/Z)+FB*(1D0/ZMAX-1D0/Z)
69843 IF(MA.GE.2) FEXP=FEXP+FA*LOG((1D0-Z)/(1D0-ZMAX))
69844 FVAL=EXP(MAX(-50D0,MIN(50D0,FEXP)))
69845 IF(FVAL.LT.PYR(0)*FPRE) GOTO 100
69846
69847C...Generate z according to Field-Feynman, SLAC, (1-z)**c OR z**c.
69848 ELSE
69849 FC=PARJ(50+MAX(1,KFLH))
69850 IF(MSTJ(91).EQ.1) FC=PARJ(59)
69851 110 Z=PYR(0)
69852 IF(FC.GE.0D0.AND.FC.LE.1D0) THEN
69853 IF(FC.GT.PYR(0)) Z=1D0-Z**(1D0/3D0)
69854 ELSEIF(FC.GT.-1.AND.FC.LT.0D0) THEN
69855 IF(-4D0*FC*Z*(1D0-Z)**2.LT.PYR(0)*((1D0-Z)**2-FC*Z)**2)
69856 & GOTO 110
69857 ELSE
69858 IF(FC.GT.0D0) Z=1D0-Z**(1D0/FC)
69859 IF(FC.LT.0D0) Z=Z**(-1D0/FC)
69860 ENDIF
69861 ENDIF
69862
69863 RETURN
69864 END
69865
69866C*********************************************************************
69867
69868C...PYSHOW
69869C...Generates timelike parton showers from given partons.
69870
69871 SUBROUTINE PYSHOW(IP1,IP2,QMAX)
69872
69873C...Double precision and integer declarations.
69874 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
69875 IMPLICIT INTEGER(I-N)
69876 INTEGER PYK,PYCHGE,PYCOMP
69877C...Parameter statement to help give large particle numbers.
69878 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
69879 &KEXCIT=4000000,KDIMEN=5000000)
69880 PARAMETER (MAXNUR=1000)
69881C...Commonblocks.
69882 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
69883 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
69884 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
69885 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
69886 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
69887 COMMON/PYINT1/MINT(400),VINT(400)
69888 SAVE /PYPART/,/PYJETS/,/PYDAT1/,/PYDAT2/,/PYPARS/,/PYINT1/
69889C...Local arrays.
69890 DIMENSION PMTH(5,140),PS(5),PMA(100),PMSD(100),IEP(100),IPA(100),
69891 &KFLA(100),KFLD(100),KFL(100),ITRY(100),ISI(100),ISL(100),DP(100),
69892 &DPT(5,4),KSH(0:140),KCII(2),NIIS(2),IIIS(2,2),THEIIS(2,2),
69893 &PHIIIS(2,2),ISII(2),ISSET(2),ISCOL(0:140),ISCHG(0:140),
69894 &IREF(1000)
69895
69896C...Check that QMAX not too low.
69897 IF(MSTJ(41).LE.0) THEN
69898 RETURN
69899 ELSEIF(MSTJ(41).EQ.1.OR.MSTJ(41).EQ.11) THEN
69900 IF(QMAX.LE.PARJ(82).AND.IP2.GE.-80) RETURN
69901 ELSE
69902 IF(QMAX.LE.MIN(PARJ(82),PARJ(83),PARJ(90)).AND.IP2.GE.-80)
69903 & RETURN
69904 ENDIF
69905
69906C...Store positions of shower initiating partons.
69907 MPSPD=0
69908 IF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.EQ.0) THEN
69909 NPA=1
69910 IPA(1)=IP1
69911 ELSEIF(MIN(IP1,IP2).GT.0.AND.MAX(IP1,IP2).LE.MIN(N,MSTU(4)-
69912 & MSTU(32))) THEN
69913 NPA=2
69914 IPA(1)=IP1
69915 IPA(2)=IP2
69916 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.IP2.LT.0
69917 & .AND.IP2.GE.-80) THEN
69918 NPA=IABS(IP2)
69919 DO 100 I=1,NPA
69920 IPA(I)=IP1+I-1
69921 100 CONTINUE
69922 ELSEIF(IP1.GT.0.AND.IP1.LE.MIN(N,MSTU(4)-MSTU(32)).AND.
69923 &IP2.EQ.-100) THEN
69924 MPSPD=1
69925 NPA=2
69926 IPA(1)=IP1+6
69927 IPA(2)=IP1+7
69928 ELSE
69929 CALL PYERRM(12,
69930 & '(PYSHOW:) failed to reconstruct showering system')
69931 IF(MSTU(21).GE.1) RETURN
69932 ENDIF
69933
69934C...Send off to PYPTFS for pT-ordered evolution if requested,
69935C...if at least 2 partons, and without predefined shower branchings.
69936 IF((MSTJ(41).EQ.11.OR.MSTJ(41).EQ.12).AND.NPA.GE.2.AND.
69937 &MPSPD.EQ.0) THEN
69938 NPART=NPA
69939 DO 110 II=1,NPART
69940 IPART(II)=IPA(II)
69941 PTPART(II)=0.5D0*QMAX
69942 110 CONTINUE
69943 CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
69944 RETURN
69945 ENDIF
69946
69947C...Initialization of cutoff masses etc.
69948 DO 120 IFL=0,40
69949 ISCOL(IFL)=0
69950 ISCHG(IFL)=0
69951 KSH(IFL)=0
69952 120 CONTINUE
69953 ISCOL(21)=1
69954 KSH(21)=1
69955 PMTH(1,21)=PYMASS(21)
69956 PMTH(2,21)=SQRT(PMTH(1,21)**2+0.25D0*PARJ(82)**2)
69957 PMTH(3,21)=2D0*PMTH(2,21)
69958 PMTH(4,21)=PMTH(3,21)
69959 PMTH(5,21)=PMTH(3,21)
69960 PMTH(1,22)=PYMASS(22)
69961 PMTH(2,22)=SQRT(PMTH(1,22)**2+0.25D0*PARJ(83)**2)
69962 PMTH(3,22)=2D0*PMTH(2,22)
69963 PMTH(4,22)=PMTH(3,22)
69964 PMTH(5,22)=PMTH(3,22)
69965 PMQTH1=PARJ(82)
69966 IF(MSTJ(41).GE.2) PMQTH1=MIN(PARJ(82),PARJ(83))
69967 PMQT1E=MIN(PMQTH1,PARJ(90))
69968 PMQTH2=PMTH(2,21)
69969 IF(MSTJ(41).GE.2) PMQTH2=MIN(PMTH(2,21),PMTH(2,22))
69970 PMQT2E=MIN(PMQTH2,0.5D0*PARJ(90))
69971 DO 130 IFL=1,5
69972 ISCOL(IFL)=1
69973 IF(MSTJ(41).GE.2) ISCHG(IFL)=1
69974 KSH(IFL)=1
69975 PMTH(1,IFL)=PYMASS(IFL)
69976 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PMQTH1**2)
69977 PMTH(3,IFL)=PMTH(2,IFL)+PMQTH2
69978 PMTH(4,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
69979 PMTH(5,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
69980 130 CONTINUE
69981 DO 140 IFL=11,15,2
69982 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IFL)=1
69983 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) KSH(IFL)=1
69984 PMTH(1,IFL)=PYMASS(IFL)
69985 PMTH(2,IFL)=SQRT(PMTH(1,IFL)**2+0.25D0*PARJ(90)**2)
69986 PMTH(3,IFL)=PMTH(2,IFL)+0.5D0*PARJ(90)
69987 PMTH(4,IFL)=PMTH(3,IFL)
69988 PMTH(5,IFL)=PMTH(3,IFL)
69989 140 CONTINUE
69990 PT2MIN=MAX(0.5D0*PARJ(82),1.1D0*PARJ(81))**2
69991 ALAMS=PARJ(81)**2
69992 ALFM=LOG(PT2MIN/ALAMS)
69993
69994C...Check on phase space available for emission.
69995 IREJ=0
69996 DO 150 J=1,5
69997 PS(J)=0D0
69998 150 CONTINUE
69999 PM=0D0
70000 KFLA(2)=0
70001 DO 170 I=1,NPA
70002 KFLA(I)=IABS(K(IPA(I),2))
70003 PMA(I)=P(IPA(I),5)
70004C...Special cutoff masses for initial partons (may be a heavy quark,
70005C...squark, ..., and need not be on the mass shell).
70006 IR=30+I
70007 IF(NPA.LE.1) IREF(I)=IR
70008 IF(NPA.GE.2) IREF(I+1)=IR
70009 ISCOL(IR)=0
70010 ISCHG(IR)=0
70011 KSH(IR)=0
70012 IF(KFLA(I).LE.8) THEN
70013 ISCOL(IR)=1
70014 IF(MSTJ(41).GE.2) ISCHG(IR)=1
70015 ELSEIF(KFLA(I).EQ.11.OR.KFLA(I).EQ.13.OR.KFLA(I).EQ.15.OR.
70016 & KFLA(I).EQ.17) THEN
70017 IF(MSTJ(41).EQ.2.OR.MSTJ(41).GE.4) ISCHG(IR)=1
70018 ELSEIF(KFLA(I).EQ.21) THEN
70019 ISCOL(IR)=1
70020 ELSEIF((KFLA(I).GE.KSUSY1+1.AND.KFLA(I).LE.KSUSY1+8).OR.
70021 & (KFLA(I).GE.KSUSY2+1.AND.KFLA(I).LE.KSUSY2+8)) THEN
70022 ISCOL(IR)=1
70023 ELSEIF(KFLA(I).EQ.KSUSY1+21) THEN
70024 ISCOL(IR)=1
70025C...QUARKONIA+++
70026C...same for QQ~[3S18]
70027 ELSEIF(MSTP(148).GE.1.AND.(KFLA(I).EQ.9900443.OR.
70028 & KFLA(I).EQ.9900553)) THEN
70029 ISCOL(IR)=1
70030C...QUARKONIA---
70031 ENDIF
70032
70033C...Option to switch off radiation from particle KF = MSTJ(39) entirely
70034C...(only intended for studying the effects of switching such rad on/off)
70035 IF (MSTJ(39).GT.0.AND.KFLA(I).EQ.MSTJ(39)) THEN
70036 ISCOL(IR)=0
70037 ISCHG(IR)=0
70038 ENDIF
70039
70040 IF(ISCOL(IR).EQ.1.OR.ISCHG(IR).EQ.1) KSH(IR)=1
70041 PMTH(1,IR)=PMA(I)
70042 IF(ISCOL(IR).EQ.1.AND.ISCHG(IR).EQ.1) THEN
70043 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PMQTH1**2)
70044 PMTH(3,IR)=PMTH(2,IR)+PMQTH2
70045 PMTH(4,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)+PMTH(2,21)
70046 PMTH(5,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(83)**2)+PMTH(2,22)
70047 ELSEIF(ISCOL(IR).EQ.1) THEN
70048 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(82)**2)
70049 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(82)
70050 PMTH(4,IR)=PMTH(3,IR)
70051 PMTH(5,IR)=PMTH(3,IR)
70052 ELSEIF(ISCHG(IR).EQ.1) THEN
70053 PMTH(2,IR)=SQRT(PMTH(1,IR)**2+0.25D0*PARJ(90)**2)
70054 PMTH(3,IR)=PMTH(2,IR)+0.5D0*PARJ(90)
70055 PMTH(4,IR)=PMTH(3,IR)
70056 PMTH(5,IR)=PMTH(3,IR)
70057 ENDIF
70058 IF(KSH(IR).EQ.1) PMA(I)=PMTH(3,IR)
70059 PM=PM+PMA(I)
70060 IF(KSH(IR).EQ.0.OR.PMA(I).GT.10D0*QMAX) IREJ=IREJ+1
70061 DO 160 J=1,4
70062 PS(J)=PS(J)+P(IPA(I),J)
70063 160 CONTINUE
70064 170 CONTINUE
70065 IF(IREJ.EQ.NPA.AND.IP2.GE.-7) RETURN
70066 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
70067 IF(NPA.EQ.1) PS(5)=PS(4)
70068 IF(PS(5).LE.PM+PMQT1E) RETURN
70069
70070C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
70071 KFSRCE=0
70072 IF(IP2.LE.0) THEN
70073 ELSEIF(K(IP1,3).EQ.K(IP2,3).AND.K(IP1,3).GT.0) THEN
70074 KFSRCE=IABS(K(K(IP1,3),2))
70075 ELSE
70076 IPAR1=MAX(1,K(IP1,3))
70077 IPAR2=MAX(1,K(IP2,3))
70078 IF(K(IPAR1,3).EQ.K(IPAR2,3).AND.K(IPAR1,3).GT.0)
70079 & KFSRCE=IABS(K(K(IPAR1,3),2))
70080 ENDIF
70081 ITYPES=0
70082 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
70083 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
70084 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
70085 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
70086 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
70087 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
70088 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
70089 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
70090
70091C...Identify two primary showerers.
70092 ITYPE1=0
70093 IF(KFLA(1).GE.1.AND.KFLA(1).LE.8) ITYPE1=1
70094 IF(KFLA(1).GE.KSUSY1+1.AND.KFLA(1).LE.KSUSY1+8) ITYPE1=2
70095 IF(KFLA(1).GE.KSUSY2+1.AND.KFLA(1).LE.KSUSY2+8) ITYPE1=2
70096 IF(KFLA(1).GE.21.AND.KFLA(1).LE.24) ITYPE1=3
70097 IF(KFLA(1).GE.32.AND.KFLA(1).LE.34) ITYPE1=3
70098 IF(KFLA(1).EQ.25.OR.(KFLA(1).GE.35.AND.KFLA(1).LE.37)) ITYPE1=4
70099 IF(KFLA(1).GE.KSUSY1+22.AND.KFLA(1).LE.KSUSY1+37) ITYPE1=5
70100 IF(KFLA(1).EQ.KSUSY1+21) ITYPE1=6
70101 ITYPE2=0
70102 IF(KFLA(2).GE.1.AND.KFLA(2).LE.8) ITYPE2=1
70103 IF(KFLA(2).GE.KSUSY1+1.AND.KFLA(2).LE.KSUSY1+8) ITYPE2=2
70104 IF(KFLA(2).GE.KSUSY2+1.AND.KFLA(2).LE.KSUSY2+8) ITYPE2=2
70105 IF(KFLA(2).GE.21.AND.KFLA(2).LE.24) ITYPE2=3
70106 IF(KFLA(2).GE.32.AND.KFLA(2).LE.34) ITYPE2=3
70107 IF(KFLA(2).EQ.25.OR.(KFLA(2).GE.35.AND.KFLA(2).LE.37)) ITYPE2=4
70108 IF(KFLA(2).GE.KSUSY1+22.AND.KFLA(2).LE.KSUSY1+37) ITYPE2=5
70109 IF(KFLA(2).EQ.KSUSY1+21) ITYPE2=6
70110
70111C...Order of showerers. Presence of gluino.
70112 ITYPMN=MIN(ITYPE1,ITYPE2)
70113 ITYPMX=MAX(ITYPE1,ITYPE2)
70114 IORD=1
70115 IF(ITYPE1.GT.ITYPE2) IORD=2
70116 IGLUI=0
70117 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
70118
70119C...Check if 3-jet matrix elements to be used.
70120 M3JC=0
70121 ALPHA=0.5D0
70122 IF(NPA.EQ.2.AND.MSTJ(47).GE.1.AND.MPSPD.EQ.0) THEN
70123 IF(MSTJ(38).NE.0) THEN
70124 M3JC=MSTJ(38)
70125 ALPHA=PARJ(80)
70126 MSTJ(38)=0
70127 ELSEIF(MSTJ(47).GE.6) THEN
70128 M3JC=MSTJ(47)
70129 ELSE
70130 ICLASS=1
70131 ICOMBI=4
70132
70133C...Vector/axial vector -> q + qbar; q -> q + V.
70134 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
70135 & ITYPES.EQ.3)) THEN
70136 ICLASS=2
70137 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
70138 ICOMBI=1
70139 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
70140 & K(IPA(1),2)+K(IPA(2),2).EQ.0)) THEN
70141C...gamma*/Z0: assume e+e- initial state if unknown.
70142 EI=-1D0
70143 IF(KFSRCE.EQ.23) THEN
70144 IANNFL=K(K(IP1,3),3)
70145 IF(IANNFL.NE.0) THEN
70146 KANNFL=IABS(K(IANNFL,2))
70147 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
70148 ENDIF
70149 ENDIF
70150 AI=SIGN(1D0,EI+0.1D0)
70151 VI=AI-4D0*EI*PARU(102)
70152 EF=KCHG(KFLA(1),1)/3D0
70153 AF=SIGN(1D0,EF+0.1D0)
70154 VF=AF-4D0*EF*PARU(102)
70155 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
70156 SH=PS(5)**2
70157 SQMZ=PMAS(23,1)**2
70158 SQWZ=PS(5)*PMAS(23,2)
70159 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
70160 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
70161 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
70162 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
70163 ICOMBI=3
70164 ALPHA=VECT/(VECT+AXIV)
70165 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
70166 ICOMBI=4
70167 ENDIF
70168C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
70169 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
70170 ICLASS=2
70171 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70172 & ITYPES.EQ.1)) THEN
70173 ICLASS=3
70174
70175C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
70176 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
70177 ICLASS=4
70178 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
70179 ICOMBI=1
70180 ELSEIF(KFSRCE.EQ.36) THEN
70181 ICOMBI=2
70182 ENDIF
70183 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70184 & ITYPES.EQ.1)) THEN
70185 ICLASS=5
70186
70187C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
70188 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70189 & ITYPES.EQ.3)) THEN
70190 ICLASS=6
70191 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
70192 & ITYPES.EQ.2)) THEN
70193 ICLASS=7
70194 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
70195 ICLASS=8
70196 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
70197 & ITYPES.EQ.2)) THEN
70198 ICLASS=9
70199
70200C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
70201 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
70202 & ITYPES.EQ.5)) THEN
70203 ICLASS=10
70204 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70205 & ITYPES.EQ.2)) THEN
70206 ICLASS=11
70207 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
70208 & ITYPES.EQ.1)) THEN
70209 ICLASS=12
70210
70211C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
70212 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
70213 ICLASS=13
70214 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70215 & ITYPES.EQ.2)) THEN
70216 ICLASS=14
70217 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
70218 & ITYPES.EQ.1)) THEN
70219 ICLASS=15
70220
70221C...g -> ~g + ~g (eikonal approximation).
70222 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
70223 ICLASS=16
70224 ENDIF
70225 M3JC=5*ICLASS+ICOMBI
70226 ENDIF
70227 ENDIF
70228
70229C...Find if interference with initial state partons.
70230 MIIS=0
70231 IF(MSTJ(50).GE.1.AND.MSTJ(50).LE.3.AND.NPA.EQ.2.AND.KFSRCE.EQ.0
70232 &.AND.MPSPD.EQ.0) MIIS=MSTJ(50)
70233 IF(MSTJ(50).GE.4.AND.MSTJ(50).LE.6.AND.NPA.EQ.2.AND.MPSPD.EQ.0)
70234 &MIIS=MSTJ(50)-3
70235 IF(MIIS.NE.0) THEN
70236 DO 190 I=1,2
70237 KCII(I)=0
70238 KCA=PYCOMP(KFLA(I))
70239 IF(KCA.NE.0) KCII(I)=KCHG(KCA,2)*ISIGN(1,K(IPA(I),2))
70240 NIIS(I)=0
70241 IF(KCII(I).NE.0) THEN
70242 DO 180 J=1,2
70243 ICSI=MOD(K(IPA(I),3+J)/MSTU(5),MSTU(5))
70244 IF(ICSI.GT.0.AND.ICSI.NE.IPA(1).AND.ICSI.NE.IPA(2).AND.
70245 & (KCII(I).EQ.(-1)**(J+1).OR.KCII(I).EQ.2)) THEN
70246 NIIS(I)=NIIS(I)+1
70247 IIIS(I,NIIS(I))=ICSI
70248 ENDIF
70249 180 CONTINUE
70250 ENDIF
70251 190 CONTINUE
70252 IF(NIIS(1)+NIIS(2).EQ.0) MIIS=0
70253 ENDIF
70254
70255C...Boost interfering initial partons to rest frame
70256C...and reconstruct their polar and azimuthal angles.
70257 IF(MIIS.NE.0) THEN
70258 DO 210 I=1,2
70259 DO 200 J=1,5
70260 K(N+I,J)=K(IPA(I),J)
70261 P(N+I,J)=P(IPA(I),J)
70262 V(N+I,J)=0D0
70263 200 CONTINUE
70264 210 CONTINUE
70265 DO 230 I=3,2+NIIS(1)
70266 DO 220 J=1,5
70267 K(N+I,J)=K(IIIS(1,I-2),J)
70268 P(N+I,J)=P(IIIS(1,I-2),J)
70269 V(N+I,J)=0D0
70270 220 CONTINUE
70271 230 CONTINUE
70272 DO 250 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
70273 DO 240 J=1,5
70274 K(N+I,J)=K(IIIS(2,I-2-NIIS(1)),J)
70275 P(N+I,J)=P(IIIS(2,I-2-NIIS(1)),J)
70276 V(N+I,J)=0D0
70277 240 CONTINUE
70278 250 CONTINUE
70279 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,0D0,-PS(1)/PS(4),
70280 & -PS(2)/PS(4),-PS(3)/PS(4))
70281 PHI=PYANGL(P(N+1,1),P(N+1,2))
70282 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),0D0,-PHI,0D0,0D0,0D0)
70283 THE=PYANGL(P(N+1,3),P(N+1,1))
70284 CALL PYROBO(N+1,N+2+NIIS(1)+NIIS(2),-THE,0D0,0D0,0D0,0D0)
70285 DO 260 I=3,2+NIIS(1)
70286 THEIIS(1,I-2)=PYANGL(P(N+I,3),SQRT(P(N+I,1)**2+P(N+I,2)**2))
70287 PHIIIS(1,I-2)=PYANGL(P(N+I,1),P(N+I,2))
70288 260 CONTINUE
70289 DO 270 I=3+NIIS(1),2+NIIS(1)+NIIS(2)
70290 THEIIS(2,I-2-NIIS(1))=PARU(1)-PYANGL(P(N+I,3),
70291 & SQRT(P(N+I,1)**2+P(N+I,2)**2))
70292 PHIIIS(2,I-2-NIIS(1))=PYANGL(P(N+I,1),P(N+I,2))
70293 270 CONTINUE
70294 ENDIF
70295
70296C...Boost 3 or more partons to their rest frame.
70297 IF(NPA.GE.3) CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,-PS(1)/PS(4),
70298 &-PS(2)/PS(4),-PS(3)/PS(4))
70299
70300C...Define imagined single initiator of shower for parton system.
70301 NS=N
70302 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
70303 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
70304 IF(MSTU(21).GE.1) RETURN
70305 ENDIF
70306 280 N=NS
70307 IF(NPA.GE.2) THEN
70308 K(N+1,1)=11
70309 K(N+1,2)=21
70310 K(N+1,3)=0
70311 K(N+1,4)=0
70312 K(N+1,5)=0
70313 P(N+1,1)=0D0
70314 P(N+1,2)=0D0
70315 P(N+1,3)=0D0
70316 P(N+1,4)=PS(5)
70317 P(N+1,5)=PS(5)
70318 V(N+1,5)=PS(5)**2
70319 N=N+1
70320 IREF(1)=21
70321 ENDIF
70322
70323C...Loop over partons that may branch.
70324 NEP=NPA
70325 IM=NS
70326 IF(NPA.EQ.1) IM=NS-1
70327 290 IM=IM+1
70328 IF(N.GT.NS) THEN
70329 IF(IM.GT.N) GOTO 600
70330 KFLM=IABS(K(IM,2))
70331 IR=IREF(IM-NS)
70332 IF(KSH(IR).EQ.0) GOTO 290
70333 IF(P(IM,5).LT.PMTH(2,IR)) GOTO 290
70334 IGM=K(IM,3)
70335 ELSE
70336 IGM=-1
70337 ENDIF
70338 IF(N+NEP.GT.MSTU(4)-MSTU(32)-10) THEN
70339 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
70340 IF(MSTU(21).GE.1) RETURN
70341 ENDIF
70342
70343C...Position of aunt (sister to branching parton).
70344C...Origin and flavour of daughters.
70345 IAU=0
70346 IF(IGM.GT.0) THEN
70347 IF(K(IM-1,3).EQ.IGM) IAU=IM-1
70348 IF(N.GE.IM+1.AND.K(IM+1,3).EQ.IGM) IAU=IM+1
70349 ENDIF
70350 IF(IGM.GE.0) THEN
70351 K(IM,4)=N+1
70352 DO 300 I=1,NEP
70353 K(N+I,3)=IM
70354 300 CONTINUE
70355 ELSE
70356 K(N+1,3)=IPA(1)
70357 ENDIF
70358 IF(IGM.LE.0) THEN
70359 DO 310 I=1,NEP
70360 K(N+I,2)=K(IPA(I),2)
70361 310 CONTINUE
70362 ELSEIF(KFLM.NE.21) THEN
70363 K(N+1,2)=K(IM,2)
70364 K(N+2,2)=K(IM,5)
70365 IREF(N+1-NS)=IREF(IM-NS)
70366 IREF(N+2-NS)=IABS(K(N+2,2))
70367 ELSEIF(K(IM,5).EQ.21) THEN
70368 K(N+1,2)=21
70369 K(N+2,2)=21
70370 IREF(N+1-NS)=21
70371 IREF(N+2-NS)=21
70372 ELSE
70373 K(N+1,2)=K(IM,5)
70374 K(N+2,2)=-K(IM,5)
70375 IREF(N+1-NS)=IABS(K(N+1,2))
70376 IREF(N+2-NS)=IABS(K(N+2,2))
70377 ENDIF
70378
70379C...Reset flags on daughters and tries made.
70380 DO 320 IP=1,NEP
70381 K(N+IP,1)=3
70382 K(N+IP,4)=0
70383 K(N+IP,5)=0
70384 KFLD(IP)=IABS(K(N+IP,2))
70385 IF(KCHG(PYCOMP(KFLD(IP)),2).EQ.0) K(N+IP,1)=1
70386 ITRY(IP)=0
70387 ISL(IP)=0
70388 ISI(IP)=0
70389 IF(KSH(IREF(N+IP-NS)).EQ.1) ISI(IP)=1
70390 320 CONTINUE
70391 ISLM=0
70392
70393C...Maximum virtuality of daughters.
70394 IF(IGM.LE.0) THEN
70395 DO 330 I=1,NPA
70396 IF(NPA.GE.3) P(N+I,4)=P(IPA(I),4)
70397 P(N+I,5)=MIN(QMAX,PS(5))
70398 IR=IREF(N+I-NS)
70399 IF(IP2.LE.-8) P(N+I,5)=MAX(P(N+I,5),2D0*PMTH(3,IR))
70400 IF(ISI(I).EQ.0) P(N+I,5)=P(IPA(I),5)
70401 330 CONTINUE
70402 ELSE
70403 IF(MSTJ(43).LE.2) PEM=V(IM,2)
70404 IF(MSTJ(43).GE.3) PEM=P(IM,4)
70405 P(N+1,5)=MIN(P(IM,5),V(IM,1)*PEM)
70406 P(N+2,5)=MIN(P(IM,5),(1D0-V(IM,1))*PEM)
70407 IF(K(N+2,2).EQ.22) P(N+2,5)=PMTH(1,22)
70408 ENDIF
70409 DO 340 I=1,NEP
70410 PMSD(I)=P(N+I,5)
70411 IF(ISI(I).EQ.1) THEN
70412 IR=IREF(N+I-NS)
70413 IF(P(N+I,5).LE.PMTH(3,IR)) P(N+I,5)=PMTH(1,IR)
70414 ENDIF
70415 V(N+I,5)=P(N+I,5)**2
70416 340 CONTINUE
70417
70418C...Choose one of the daughters for evolution.
70419 350 INUM=0
70420 IF(NEP.EQ.1) INUM=1
70421 DO 360 I=1,NEP
70422 IF(INUM.EQ.0.AND.ISL(I).EQ.1) INUM=I
70423 360 CONTINUE
70424 DO 370 I=1,NEP
70425 IF(INUM.EQ.0.AND.ITRY(I).EQ.0.AND.ISI(I).EQ.1) THEN
70426 IR=IREF(N+I-NS)
70427 IF(P(N+I,5).GE.PMTH(2,IR)) INUM=I
70428 ENDIF
70429 370 CONTINUE
70430 IF(INUM.EQ.0) THEN
70431 RMAX=0D0
70432 DO 380 I=1,NEP
70433 IF(ISI(I).EQ.1.AND.PMSD(I).GE.PMQT2E) THEN
70434 RPM=P(N+I,5)/PMSD(I)
70435 IR=IREF(N+I-NS)
70436 IF(RPM.GT.RMAX.AND.P(N+I,5).GE.PMTH(2,IR)) THEN
70437 RMAX=RPM
70438 INUM=I
70439 ENDIF
70440 ENDIF
70441 380 CONTINUE
70442 ENDIF
70443
70444C...Cancel choice of predetermined daughter already treated.
70445 INUM=MAX(1,INUM)
70446 INUMT=INUM
70447 IF(MPSPD.EQ.1.AND.IGM.EQ.0.AND.ITRY(INUMT).GE.1) THEN
70448 IF(K(IP1-1+INUM,4).GT.0) INUM=3-INUM
70449 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2.AND.ITRY(INUMT).GE.1) THEN
70450 IF(KFLD(INUMT).NE.21.AND.K(IP1+2,4).GT.0) INUM=3-INUM
70451 IF(KFLD(INUMT).EQ.21.AND.K(IP1+3,4).GT.0) INUM=3-INUM
70452 ENDIF
70453
70454C...Store information on choice of evolving daughter.
70455 IEP(1)=N+INUM
70456 DO 390 I=2,NEP
70457 IEP(I)=IEP(I-1)+1
70458 IF(IEP(I).GT.N+NEP) IEP(I)=N+1
70459 390 CONTINUE
70460 DO 400 I=1,NEP
70461 KFL(I)=IABS(K(IEP(I),2))
70462 400 CONTINUE
70463 ITRY(INUM)=ITRY(INUM)+1
70464 IF(ITRY(INUM).GT.200) THEN
70465 CALL PYERRM(14,'(PYSHOW:) caught in infinite loop')
70466 IF(MSTU(21).GE.1) RETURN
70467 ENDIF
70468 Z=0.5D0
70469 IR=IREF(IEP(1)-NS)
70470 IF(KSH(IR).EQ.0) GOTO 450
70471 IF(P(IEP(1),5).LT.PMTH(2,IR)) GOTO 450
70472
70473C...Check if evolution already predetermined for daughter.
70474 IPSPD=0
70475 IF(MPSPD.EQ.1.AND.IGM.EQ.0) THEN
70476 IF(K(IP1-1+INUM,4).GT.0) IPSPD=IP1-1+INUM
70477 ELSEIF(MPSPD.EQ.1.AND.IM.EQ.NS+2) THEN
70478 IF(KFL(1).NE.21.AND.K(IP1+2,4).GT.0) IPSPD=IP1+2
70479 IF(KFL(1).EQ.21.AND.K(IP1+3,4).GT.0) IPSPD=IP1+3
70480 ENDIF
70481 IF(INUM.EQ.1.OR.INUM.EQ.2) THEN
70482 ISSET(INUM)=0
70483 IF(IPSPD.NE.0) ISSET(INUM)=1
70484 ENDIF
70485
70486C...Select side for interference with initial state partons.
70487 IF(MIIS.GE.1.AND.IEP(1).LE.NS+3) THEN
70488 III=IEP(1)-NS-1
70489 ISII(III)=0
70490 IF(IABS(KCII(III)).EQ.1.AND.NIIS(III).EQ.1) THEN
70491 ISII(III)=1
70492 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.1) THEN
70493 IF(PYR(0).GT.0.5D0) ISII(III)=1
70494 ELSEIF(KCII(III).EQ.2.AND.NIIS(III).EQ.2) THEN
70495 ISII(III)=1
70496 IF(PYR(0).GT.0.5D0) ISII(III)=2
70497 ENDIF
70498 ENDIF
70499
70500C...Calculate allowed z range.
70501 IF(NEP.EQ.1) THEN
70502 PMED=PS(4)
70503 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
70504 PMED=P(IM,5)
70505 ELSE
70506 IF(INUM.EQ.1) PMED=V(IM,1)*PEM
70507 IF(INUM.EQ.2) PMED=(1D0-V(IM,1))*PEM
70508 ENDIF
70509 IF(MOD(MSTJ(43),2).EQ.1) THEN
70510 ZC=PMTH(2,21)/PMED
70511 ZCE=PMTH(2,22)/PMED
70512 IF(ISCOL(IR).EQ.0) ZCE=0.5D0*PARJ(90)/PMED
70513 ELSE
70514 ZC=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTH(2,21)/PMED)**2)))
70515 IF(ZC.LT.1D-6) ZC=(PMTH(2,21)/PMED)**2
70516 PMTMPE=PMTH(2,22)
70517 IF(ISCOL(IR).EQ.0) PMTMPE=0.5D0*PARJ(90)
70518 ZCE=0.5D0*(1D0-SQRT(MAX(0D0,1D0-(2D0*PMTMPE/PMED)**2)))
70519 IF(ZCE.LT.1D-6) ZCE=(PMTMPE/PMED)**2
70520 ENDIF
70521 ZC=MIN(ZC,0.491D0)
70522 ZCE=MIN(ZCE,0.49991D0)
70523 IF(((MSTJ(41).EQ.1.AND.ZC.GT.0.49D0).OR.(MSTJ(41).GE.2.AND.
70524 &MIN(ZC,ZCE).GT.0.4999D0)).AND.IPSPD.EQ.0) THEN
70525 P(IEP(1),5)=PMTH(1,IR)
70526 V(IEP(1),5)=P(IEP(1),5)**2
70527 GOTO 450
70528 ENDIF
70529
70530C...Integral of Altarelli-Parisi z kernel for QCD.
70531C...(Includes squark and gluino; with factor N_C/C_F extra for latter).
70532 IF(MSTJ(49).EQ.0.AND.KFL(1).EQ.21) THEN
70533 FBR=6D0*LOG((1D0-ZC)/ZC)+MSTJ(45)*0.5D0
70534C...QUARKONIA+++
70535C...Evolution of QQ~[3S18] state if MSTP(148)=1.
70536 ELSEIF(MSTJ(49).EQ.0.AND.MSTP(149).GE.0.AND.
70537 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
70538 FBR=6D0*LOG((1D0-ZC)/ZC)
70539C...QUARKONIA---
70540 ELSEIF(MSTJ(49).EQ.0) THEN
70541 FBR=(8D0/3D0)*LOG((1D0-ZC)/ZC)
70542 IF(IGLUI.EQ.1.AND.IR.GE.31) FBR=FBR*(9D0/4D0)
70543
70544C...Integral of Altarelli-Parisi z kernel for scalar gluon.
70545 ELSEIF(MSTJ(49).EQ.1.AND.KFL(1).EQ.21) THEN
70546 FBR=(PARJ(87)+MSTJ(45)*PARJ(88))*(1D0-2D0*ZC)
70547 ELSEIF(MSTJ(49).EQ.1) THEN
70548 FBR=(1D0-2D0*ZC)/3D0
70549 IF(IGM.EQ.0.AND.M3JC.GE.1) FBR=4D0*FBR
70550
70551C...Integral of Altarelli-Parisi z kernel for Abelian vector gluon.
70552 ELSEIF(KFL(1).EQ.21) THEN
70553 FBR=6D0*MSTJ(45)*(0.5D0-ZC)
70554 ELSE
70555 FBR=2D0*LOG((1D0-ZC)/ZC)
70556 ENDIF
70557
70558C...Reset QCD probability for colourless.
70559 IF(ISCOL(IR).EQ.0) FBR=0D0
70560
70561C...Integral of Altarelli-Parisi kernel for photon emission.
70562 FBRE=0D0
70563 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1) THEN
70564 IF(KFL(1).LE.18) THEN
70565 FBRE=(KCHG(KFL(1),1)/3D0)**2*2D0*LOG((1D0-ZCE)/ZCE)
70566 ENDIF
70567 IF(MSTJ(41).EQ.10) FBRE=PARJ(84)*FBRE
70568 ENDIF
70569
70570C...Inner veto algorithm starts. Find maximum mass for evolution.
70571 410 PMS=V(IEP(1),5)
70572 IF(IGM.GE.0) THEN
70573 PM2=0D0
70574 DO 420 I=2,NEP
70575 PM=P(IEP(I),5)
70576 IRI=IREF(IEP(I)-NS)
70577 IF(KSH(IRI).EQ.1) PM=PMTH(2,IRI)
70578 PM2=PM2+PM
70579 420 CONTINUE
70580 PMS=MIN(PMS,(P(IM,5)-PM2)**2)
70581 ENDIF
70582
70583C...Select mass for daughter in QCD evolution.
70584 B0=27D0/6D0
70585 DO 430 IFF=4,MSTJ(45)
70586 IF(PMS.GT.4D0*PMTH(2,IFF)**2) B0=(33D0-2D0*IFF)/6D0
70587 430 CONTINUE
70588C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
70589 PMSC=MAX(0.5D0*PARJ(82),PMS-PMTH(1,IR)**2)
70590C...Already predetermined choice.
70591 IF(IPSPD.NE.0) THEN
70592 PMSQCD=P(IPSPD,5)**2
70593 ELSEIF(FBR.LT.1D-3) THEN
70594 PMSQCD=0D0
70595 ELSEIF(MSTJ(44).LE.0) THEN
70596 PMSQCD=PMSC*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/(PARU(111)*FBR)))
70597 ELSEIF(MSTJ(44).EQ.1) THEN
70598 PMSQCD=4D0*ALAMS*(0.25D0*PMSC/ALAMS)**(PYR(0)**(B0/FBR))
70599 ELSE
70600 PMSQCD=PMSC*EXP(MAX(-50D0,ALFM*B0*LOG(PYR(0))/FBR))
70601 ENDIF
70602C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
70603 IF(IPSPD.EQ.0) PMSQCD=PMSQCD+PMTH(1,IR)**2
70604 IF(ZC.GT.0.49D0.OR.PMSQCD.LE.PMTH(4,IR)**2) PMSQCD=PMTH(2,IR)**2
70605 V(IEP(1),5)=PMSQCD
70606 MCE=1
70607
70608C...Select mass for daughter in QED evolution.
70609 IF(MSTJ(41).GE.2.AND.ISCHG(IR).EQ.1.AND.IPSPD.EQ.0) THEN
70610C...Shift m^2 for evolution in Q^2 = m^2 - m(onshell)^2.
70611 PMSE=MAX(0.5D0*PARJ(83),PMS-PMTH(1,IR)**2)
70612 IF(FBRE.LT.1D-3) THEN
70613 PMSQED=0D0
70614 ELSE
70615 PMSQED=PMSE*EXP(MAX(-50D0,LOG(PYR(0))*PARU(2)/
70616 & (PARU(101)*FBRE)))
70617 ENDIF
70618C...Shift back m^2 from evolution in Q^2 = m^2 - m(onshell)^2.
70619 PMSQED=PMSQED+PMTH(1,IR)**2
70620 IF(ZCE.GT.0.4999D0.OR.PMSQED.LE.PMTH(5,IR)**2) PMSQED=
70621 & PMTH(2,IR)**2
70622 IF(PMSQED.GT.PMSQCD) THEN
70623 V(IEP(1),5)=PMSQED
70624 MCE=2
70625 ENDIF
70626 ENDIF
70627
70628C...Check whether daughter mass below cutoff.
70629 P(IEP(1),5)=SQRT(V(IEP(1),5))
70630 IF(P(IEP(1),5).LE.PMTH(3,IR)) THEN
70631 P(IEP(1),5)=PMTH(1,IR)
70632 V(IEP(1),5)=P(IEP(1),5)**2
70633 GOTO 450
70634 ENDIF
70635
70636C...Already predetermined choice of z, and flavour in g -> qqbar.
70637 IF(IPSPD.NE.0) THEN
70638 IPSGD1=K(IPSPD,4)
70639 IPSGD2=K(IPSPD,5)
70640 PMSGD1=P(IPSGD1,5)**2
70641 PMSGD2=P(IPSGD2,5)**2
70642 ALAMPS=SQRT(MAX(1D-10,(PMSQCD-PMSGD1-PMSGD2)**2-
70643 & 4D0*PMSGD1*PMSGD2))
70644 Z=0.5D0*(PMSQCD*(2D0*P(IPSGD1,4)/P(IPSPD,4)-1D0)+ALAMPS-
70645 & PMSGD1+PMSGD2)/ALAMPS
70646 Z=MAX(0.00001D0,MIN(0.99999D0,Z))
70647 IF(KFL(1).NE.21) THEN
70648 K(IEP(1),5)=21
70649 ELSE
70650 K(IEP(1),5)=IABS(K(IPSGD1,2))
70651 ENDIF
70652
70653C...Select z value of branching: q -> qgamma.
70654 ELSEIF(MCE.EQ.2) THEN
70655 Z=1D0-(1D0-ZCE)*(ZCE/(1D0-ZCE))**PYR(0)
70656 IF(1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
70657 K(IEP(1),5)=22
70658
70659C...QUARKONIA+++
70660C...Select z value of branching: QQ~[3S18] -> QQ~[3S18]g.
70661 ELSEIF(MSTJ(49).EQ.0.AND.
70662 & (KFL(1).EQ.9900443.OR.KFL(1).EQ.9900553)) THEN
70663 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
70664C...Select always the harder 'gluon' if the switch MSTP(149)<=0.
70665 IF(MSTP(149).LE.0.OR.PYR(0).GT.0.5D0) Z=1D0-Z
70666 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
70667 K(IEP(1),5)=21
70668C...QUARKONIA---
70669
70670C...Select z value of branching: q -> qg, g -> gg, g -> qqbar.
70671 ELSEIF(MSTJ(49).NE.1.AND.KFL(1).NE.21) THEN
70672 Z=1D0-(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
70673C...Only do z weighting when no ME correction afterwards.
70674 IF(M3JC.EQ.0.AND.1D0+Z**2.LT.2D0*PYR(0)) GOTO 410
70675 K(IEP(1),5)=21
70676 ELSEIF(MSTJ(49).EQ.0.AND.MSTJ(45)*0.5D0.LT.PYR(0)*FBR) THEN
70677 Z=(1D0-ZC)*(ZC/(1D0-ZC))**PYR(0)
70678 IF(PYR(0).GT.0.5D0) Z=1D0-Z
70679 IF((1D0-Z*(1D0-Z))**2.LT.PYR(0)) GOTO 410
70680 K(IEP(1),5)=21
70681 ELSEIF(MSTJ(49).NE.1) THEN
70682 Z=PYR(0)
70683 IF(Z**2+(1D0-Z)**2.LT.PYR(0)) GOTO 410
70684 KFLB=1+INT(MSTJ(45)*PYR(0))
70685 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
70686 IF(PMQ.GE.1D0) GOTO 410
70687 IF(MSTJ(44).LE.2.OR.MSTJ(44).EQ.4) THEN
70688 IF(Z.LT.ZC.OR.Z.GT.1D0-ZC) GOTO 410
70689 PMQ0=4D0*PMTH(2,21)**2/V(IEP(1),5)
70690 IF(MOD(MSTJ(43),2).EQ.0.AND.(1D0+0.5D0*PMQ)*SQRT(1D0-PMQ)
70691 & .LT.PYR(0)*(1D0+0.5D0*PMQ0)*SQRT(1D0-PMQ0)) GOTO 410
70692 ELSE
70693 IF((1D0+0.5D0*PMQ)*SQRT(1D0-PMQ).LT.PYR(0)) GOTO 410
70694 ENDIF
70695 K(IEP(1),5)=KFLB
70696
70697C...Ditto for scalar gluon model.
70698 ELSEIF(KFL(1).NE.21) THEN
70699 Z=1D0-SQRT(ZC**2+PYR(0)*(1D0-2D0*ZC))
70700 K(IEP(1),5)=21
70701 ELSEIF(PYR(0)*(PARJ(87)+MSTJ(45)*PARJ(88)).LE.PARJ(87)) THEN
70702 Z=ZC+(1D0-2D0*ZC)*PYR(0)
70703 K(IEP(1),5)=21
70704 ELSE
70705 Z=ZC+(1D0-2D0*ZC)*PYR(0)
70706 KFLB=1+INT(MSTJ(45)*PYR(0))
70707 PMQ=4D0*PMTH(2,KFLB)**2/V(IEP(1),5)
70708 IF(PMQ.GE.1D0) GOTO 410
70709 K(IEP(1),5)=KFLB
70710 ENDIF
70711
70712C...Correct to alpha_s(pT^2) (optionally m^2/4 for g -> q qbar).
70713 IF(MCE.EQ.1.AND.MSTJ(44).GE.2.AND.IPSPD.EQ.0) THEN
70714 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
70715 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
70716 IF(ALFM/LOG(V(IEP(1),5)*0.25D0/ALAMS).LT.PYR(0)) GOTO 410
70717 ELSE
70718 PT2APP=Z*(1D0-Z)*V(IEP(1),5)
70719 IF(MSTJ(44).GE.4) PT2APP=PT2APP*
70720 & (1D0-PMTH(1,IR)**2/V(IEP(1),5))**2
70721 IF(PT2APP.LT.PT2MIN) GOTO 410
70722 IF(ALFM/LOG(PT2APP/ALAMS).LT.PYR(0)) GOTO 410
70723 ENDIF
70724 ENDIF
70725
70726C...Check if z consistent with chosen m.
70727 IF(KFL(1).EQ.21) THEN
70728 IRGD1=IABS(K(IEP(1),5))
70729 IRGD2=IRGD1
70730 ELSE
70731 IRGD1=IR
70732 IRGD2=IABS(K(IEP(1),5))
70733 ENDIF
70734 IF(NEP.EQ.1) THEN
70735 PED=PS(4)
70736 ELSEIF(NEP.GE.3) THEN
70737 PED=P(IEP(1),4)
70738 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
70739 PED=0.5D0*(V(IM,5)+V(IEP(1),5)-PM2**2)/P(IM,5)
70740 ELSE
70741 IF(IEP(1).EQ.N+1) PED=V(IM,1)*PEM
70742 IF(IEP(1).EQ.N+2) PED=(1D0-V(IM,1))*PEM
70743 ENDIF
70744 IF(MOD(MSTJ(43),2).EQ.1) THEN
70745 PMQTH3=0.5D0*PARJ(82)
70746 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
70747 IF(IRGD2.EQ.22.AND.ISCOL(IR).EQ.0) PMQTH3=0.5D0*PARJ(90)
70748 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(IEP(1),5)
70749 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(IEP(1),5)
70750 ZD=SQRT(MAX(0D0,(1D0-V(IEP(1),5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
70751 & 4D0*PMQ1*PMQ2)))
70752 ZH=1D0+PMQ1-PMQ2
70753 ELSE
70754 ZD=SQRT(MAX(0D0,1D0-V(IEP(1),5)/PED**2))
70755 ZH=1D0
70756 ENDIF
70757 IF(KFL(1).EQ.21.AND.K(IEP(1),5).LT.10.AND.
70758 &(MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
70759 ELSEIF(IPSPD.NE.0) THEN
70760 ELSE
70761 ZL=0.5D0*(ZH-ZD)
70762 ZU=0.5D0*(ZH+ZD)
70763 IF(Z.LT.ZL.OR.Z.GT.ZU) GOTO 410
70764 ENDIF
70765 IF(KFL(1).EQ.21) V(IEP(1),3)=LOG(ZU*(1D0-ZL)/MAX(1D-20,ZL*
70766 &(1D0-ZU)))
70767 IF(KFL(1).NE.21) V(IEP(1),3)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
70768
70769C...Width suppression for q -> q + g.
70770 IF(MSTJ(40).NE.0.AND.KFL(1).NE.21.AND.IPSPD.EQ.0) THEN
70771 IF(IGM.EQ.0) THEN
70772 EGLU=0.5D0*PS(5)*(1D0-Z)*(1D0+V(IEP(1),5)/V(NS+1,5))
70773 ELSE
70774 EGLU=PMED*(1D0-Z)
70775 ENDIF
70776 CHI=PARJ(89)**2/(PARJ(89)**2+EGLU**2)
70777 IF(MSTJ(40).EQ.1) THEN
70778 IF(CHI.LT.PYR(0)) GOTO 410
70779 ELSEIF(MSTJ(40).EQ.2) THEN
70780 IF(1D0-CHI.LT.PYR(0)) GOTO 410
70781 ENDIF
70782 ENDIF
70783
70784C...Three-jet matrix element correction.
70785 IF(M3JC.GE.1) THEN
70786 WME=1D0
70787 WSHOW=1D0
70788
70789C...QED matrix elements: only for massless case so far.
70790 IF(MCE.EQ.2.AND.IGM.EQ.0) THEN
70791 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
70792 X2=1D0-V(IEP(1),5)/V(NS+1,5)
70793 X3=(1D0-X1)+(1D0-X2)
70794 KI1=K(IPA(INUM),2)
70795 KI2=K(IPA(3-INUM),2)
70796 QF1=KCHG(PYCOMP(KI1),1)*ISIGN(1,KI1)/3D0
70797 QF2=KCHG(PYCOMP(KI2),1)*ISIGN(1,KI2)/3D0
70798 WSHOW=QF1**2*(1D0-X1)/X3*(1D0+(X1/(2D0-X2))**2)+
70799 & QF2**2*(1D0-X2)/X3*(1D0+(X2/(2D0-X1))**2)
70800 WME=(QF1*(1D0-X1)/X3-QF2*(1D0-X2)/X3)**2*(X1**2+X2**2)
70801 ELSEIF(MCE.EQ.2) THEN
70802
70803C...QCD matrix elements, including mass effects.
70804 ELSEIF(MSTJ(49).NE.1.AND.K(IEP(1),2).NE.21) THEN
70805 PS1ME=V(IEP(1),5)
70806 PM1ME=PMTH(1,IR)
70807 M3JCC=M3JC
70808 IF(IR.GE.31.AND.IGM.EQ.0) THEN
70809C...QCD ME: original parton, first branching.
70810 PM2ME=PMTH(1,63-IR)
70811 ECMME=PS(5)
70812 ELSEIF(IR.GE.31) THEN
70813C...QCD ME: original parton, subsequent branchings.
70814 PM2ME=PMTH(1,63-IR)
70815 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
70816 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
70817 ELSEIF(K(IM,2).EQ.21) THEN
70818C...QCD ME: secondary partons, first branching.
70819 PM2ME=PM1ME
70820 ZMME=V(IM,1)
70821 IF(IEP(1).GT.IEP(2)) ZMME=1D0-ZMME
70822 PMLME=SQRT(MAX(0D0,(V(IM,5)-PS1ME-PM2ME**2)**2-
70823 & 4D0*PS1ME*PM2ME**2))
70824 PEDME=PEM*(0.5D0*(V(IM,5)-PMLME+PS1ME-PM2ME**2)+PMLME*ZMME)/
70825 & V(IM,5)
70826 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
70827 M3JCC=66
70828 ELSE
70829C...QCD ME: secondary partons, subsequent branchings.
70830 PM2ME=PM1ME
70831 PEDME=PEM*(V(IM,1)+(1D0-V(IM,1))*PS1ME/V(IM,5))
70832 ECMME=PEDME+SQRT(MAX(0D0,PEDME**2-PS1ME+PM2ME**2))
70833 M3JCC=66
70834 ENDIF
70835C...Construct ME variables.
70836 R1ME=PM1ME/ECMME
70837 R2ME=PM2ME/ECMME
70838 X1=(1D0+PS1ME/ECMME**2-R2ME**2)*(Z+(1D0-Z)*PM1ME**2/PS1ME)
70839 X2=1D0+R2ME**2-PS1ME/ECMME**2
70840C...Call ME, with right order important for two inequivalent showerers.
70841 IF(IR.EQ.IORD+30) THEN
70842 WME=PYMAEL(M3JCC,X1,X2,R1ME,R2ME,ALPHA)
70843 ELSE
70844 WME=PYMAEL(M3JCC,X2,X1,R2ME,R1ME,ALPHA)
70845 ENDIF
70846C...Split up total ME when two radiating partons.
70847 ISPRAD=1
70848 IF((M3JCC.GE.16.AND.M3JCC.LE.19).OR.
70849 & (M3JCC.GE.26.AND.M3JCC.LE.29).OR.
70850 & (M3JCC.GE.36.AND.M3JCC.LE.39).OR.
70851 & (M3JCC.GE.46.AND.M3JCC.LE.49).OR.
70852 & (M3JCC.GE.56.AND.M3JCC.LE.64)) ISPRAD=0
70853 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
70854 & MAX(1D-10,2D0-X1-X2)
70855C...Evaluate shower rate to be compared with.
70856 WSHOW=2D0/(MAX(1D-10,2D0-X1-X2)*
70857 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
70858 IF(IGLUI.EQ.1.AND.IR.GE.31) WSHOW=(9D0/4D0)*WSHOW
70859 ELSEIF(MSTJ(49).NE.1) THEN
70860
70861C...Toy model scalar theory matrix elements; no mass effects.
70862 ELSE
70863 X1=Z*(1D0+V(IEP(1),5)/V(NS+1,5))
70864 X2=1D0-V(IEP(1),5)/V(NS+1,5)
70865 X3=(1D0-X1)+(1D0-X2)
70866 WSHOW=4D0*X3*((1D0-X1)/(2D0-X2)**2+(1D0-X2)/(2D0-X1)**2)
70867 WME=X3**2
70868 IF(MSTJ(102).GE.2) WME=X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*
70869 & PARJ(171)
70870 ENDIF
70871
70872 IF(WME.LT.PYR(0)*WSHOW) GOTO 410
70873 ENDIF
70874
70875C...Impose angular ordering by rejection of nonordered emission.
70876 IF(MCE.EQ.1.AND.IGM.GT.0.AND.MSTJ(42).GE.2.AND.IPSPD.EQ.0) THEN
70877 PEMAO=V(IM,1)*P(IM,4)
70878 IF(IEP(1).EQ.N+2) PEMAO=(1D0-V(IM,1))*P(IM,4)
70879 IF(IR.GE.31.AND.MSTJ(42).GE.5) THEN
70880 MAOD=0
70881 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.4
70882 & .OR.MSTJ(42).EQ.7)) THEN
70883 MAOD=0
70884 ELSEIF(KFL(1).EQ.21.AND.K(IEP(1),5).LE.10.AND.(MSTJ(42).EQ.3
70885 & .OR.MSTJ(42).EQ.6)) THEN
70886 MAOD=1
70887 PMDAO=PMTH(2,K(IEP(1),5))
70888 THE2ID=Z*(1D0-Z)*PEMAO**2/(V(IEP(1),5)-4D0*PMDAO**2)
70889 ELSE
70890 MAOD=1
70891 THE2ID=Z*(1D0-Z)*PEMAO**2/V(IEP(1),5)
70892 IF(MSTJ(42).GE.3.AND.MSTJ(42).NE.5) THE2ID=THE2ID*
70893 & (1D0+PMTH(1,IR)**2*(1D0-Z)/(V(IEP(1),5)*Z))**2
70894 ENDIF
70895 MAOM=1
70896 IAOM=IM
70897 440 IF(K(IAOM,5).EQ.22) THEN
70898 IAOM=K(IAOM,3)
70899 IF(K(IAOM,3).LE.NS) MAOM=0
70900 IF(MAOM.EQ.1) GOTO 440
70901 ENDIF
70902 IF(MAOM.EQ.1.AND.MAOD.EQ.1) THEN
70903 THE2IM=V(IAOM,1)*(1D0-V(IAOM,1))*P(IAOM,4)**2/V(IAOM,5)
70904 IF(THE2ID.LT.THE2IM) GOTO 410
70905 ENDIF
70906 ENDIF
70907
70908C...Impose user-defined maximum angle at first branching.
70909 IF(MSTJ(48).EQ.1.AND.IPSPD.EQ.0) THEN
70910 IF(NEP.EQ.1.AND.IM.EQ.NS) THEN
70911 THE2ID=Z*(1D0-Z)*PS(4)**2/V(IEP(1),5)
70912 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
70913 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+2) THEN
70914 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
70915 IF(PARJ(85)**2*THE2ID.LT.1D0) GOTO 410
70916 ELSEIF(NEP.EQ.2.AND.IEP(1).EQ.NS+3) THEN
70917 THE2ID=Z*(1D0-Z)*(0.5D0*P(IM,4))**2/V(IEP(1),5)
70918 IF(PARJ(86)**2*THE2ID.LT.1D0) GOTO 410
70919 ENDIF
70920 ENDIF
70921
70922C...Impose angular constraint in first branching from interference
70923C...with initial state partons.
70924 IF(MIIS.GE.2.AND.IEP(1).LE.NS+3) THEN
70925 THE2D=MAX((1D0-Z)/Z,Z/(1D0-Z))*V(IEP(1),5)/(0.5D0*P(IM,4))**2
70926 IF(IEP(1).EQ.NS+2.AND.ISII(1).GE.1) THEN
70927 IF(THE2D.GT.THEIIS(1,ISII(1))**2) GOTO 410
70928 ELSEIF(IEP(1).EQ.NS+3.AND.ISII(2).GE.1) THEN
70929 IF(THE2D.GT.THEIIS(2,ISII(2))**2) GOTO 410
70930 ENDIF
70931 ENDIF
70932
70933C...End of inner veto algorithm. Check if only one leg evolved so far.
70934 450 V(IEP(1),1)=Z
70935 ISL(1)=0
70936 ISL(2)=0
70937 IF(NEP.EQ.1) GOTO 490
70938 IF(NEP.EQ.2.AND.P(IEP(1),5)+P(IEP(2),5).GE.P(IM,5)) GOTO 350
70939 DO 460 I=1,NEP
70940 IR=IREF(N+I-NS)
70941 IF(ITRY(I).EQ.0.AND.KSH(IR).EQ.1) THEN
70942 IF(P(N+I,5).GE.PMTH(2,IR)) GOTO 350
70943 ENDIF
70944 460 CONTINUE
70945
70946C...Check if chosen multiplet m1,m2,z1,z2 is physical.
70947 IF(NEP.GE.3) THEN
70948 PMSUM=0D0
70949 DO 470 I=1,NEP
70950 PMSUM=PMSUM+P(N+I,5)
70951 470 CONTINUE
70952 IF(PMSUM.GE.PS(5)) GOTO 350
70953 ELSEIF(IGM.EQ.0.OR.MSTJ(43).LE.2.OR.MOD(MSTJ(43),2).EQ.0) THEN
70954 DO 480 I1=N+1,N+2
70955 IRDA=IREF(I1-NS)
70956 IF(KSH(IRDA).EQ.0) GOTO 480
70957 IF(P(I1,5).LT.PMTH(2,IRDA)) GOTO 480
70958 IF(IRDA.EQ.21) THEN
70959 IRGD1=IABS(K(I1,5))
70960 IRGD2=IRGD1
70961 ELSE
70962 IRGD1=IRDA
70963 IRGD2=IABS(K(I1,5))
70964 ENDIF
70965 I2=2*N+3-I1
70966 IF(IGM.EQ.0.OR.MSTJ(43).LE.2) THEN
70967 PED=0.5D0*(V(IM,5)+V(I1,5)-V(I2,5))/P(IM,5)
70968 ELSE
70969 IF(I1.EQ.N+1) ZM=V(IM,1)
70970 IF(I1.EQ.N+2) ZM=1D0-V(IM,1)
70971 PML=SQRT((V(IM,5)-V(N+1,5)-V(N+2,5))**2-
70972 & 4D0*V(N+1,5)*V(N+2,5))
70973 PED=PEM*(0.5D0*(V(IM,5)-PML+V(I1,5)-V(I2,5))+PML*ZM)/
70974 & V(IM,5)
70975 ENDIF
70976 IF(MOD(MSTJ(43),2).EQ.1) THEN
70977 PMQTH3=0.5D0*PARJ(82)
70978 IF(IRGD2.EQ.22) PMQTH3=0.5D0*PARJ(83)
70979 IF(IRGD2.EQ.22.AND.ISCOL(IRDA).EQ.0) PMQTH3=0.5D0*PARJ(90)
70980 PMQ1=(PMTH(1,IRGD1)**2+PMQTH3**2)/V(I1,5)
70981 PMQ2=(PMTH(1,IRGD2)**2+PMQTH3**2)/V(I1,5)
70982 ZD=SQRT(MAX(0D0,(1D0-V(I1,5)/PED**2)*((1D0-PMQ1-PMQ2)**2-
70983 & 4D0*PMQ1*PMQ2)))
70984 ZH=1D0+PMQ1-PMQ2
70985 ELSE
70986 ZD=SQRT(MAX(0D0,1D0-V(I1,5)/PED**2))
70987 ZH=1D0
70988 ENDIF
70989 IF(IRDA.EQ.21.AND.IRGD1.LT.10.AND.
70990 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
70991 ELSE
70992 ZL=0.5D0*(ZH-ZD)
70993 ZU=0.5D0*(ZH+ZD)
70994 IF(I1.EQ.N+1.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
70995 & ISSET(1).EQ.0) THEN
70996 ISL(1)=1
70997 ELSEIF(I1.EQ.N+2.AND.(V(I1,1).LT.ZL.OR.V(I1,1).GT.ZU).AND.
70998 & ISSET(2).EQ.0) THEN
70999 ISL(2)=1
71000 ENDIF
71001 ENDIF
71002 IF(IRDA.EQ.21) V(I1,4)=LOG(ZU*(1D0-ZL)/MAX(1D-20,
71003 & ZL*(1D0-ZU)))
71004 IF(IRDA.NE.21) V(I1,4)=LOG((1D0-ZL)/MAX(1D-10,1D0-ZU))
71005 480 CONTINUE
71006 IF(ISL(1).EQ.1.AND.ISL(2).EQ.1.AND.ISLM.NE.0) THEN
71007 ISL(3-ISLM)=0
71008 ISLM=3-ISLM
71009 ELSEIF(ISL(1).EQ.1.AND.ISL(2).EQ.1) THEN
71010 ZDR1=MAX(0D0,V(N+1,3)/MAX(1D-6,V(N+1,4))-1D0)
71011 ZDR2=MAX(0D0,V(N+2,3)/MAX(1D-6,V(N+2,4))-1D0)
71012 IF(ZDR2.GT.PYR(0)*(ZDR1+ZDR2)) ISL(1)=0
71013 IF(ISL(1).EQ.1) ISL(2)=0
71014 IF(ISL(1).EQ.0) ISLM=1
71015 IF(ISL(2).EQ.0) ISLM=2
71016 ENDIF
71017 IF(ISL(1).EQ.1.OR.ISL(2).EQ.1) GOTO 350
71018 ENDIF
71019 IRD1=IREF(N+1-NS)
71020 IRD2=IREF(N+2-NS)
71021 IF(IGM.GT.0) THEN
71022 IF(MOD(MSTJ(43),2).EQ.1.AND.(P(N+1,5).GE.
71023 & PMTH(2,IRD1).OR.P(N+2,5).GE.PMTH(2,IRD2))) THEN
71024 PMQ1=V(N+1,5)/V(IM,5)
71025 PMQ2=V(N+2,5)/V(IM,5)
71026 ZD=SQRT(MAX(0D0,(1D0-V(IM,5)/PEM**2)*((1D0-PMQ1-PMQ2)**2-
71027 & 4D0*PMQ1*PMQ2)))
71028 ZH=1D0+PMQ1-PMQ2
71029 ZL=0.5D0*(ZH-ZD)
71030 ZU=0.5D0*(ZH+ZD)
71031 IF(V(IM,1).LT.ZL.OR.V(IM,1).GT.ZU) GOTO 350
71032 ENDIF
71033 ENDIF
71034
71035C...Accepted branch. Construct four-momentum for initial partons.
71036 490 MAZIP=0
71037 MAZIC=0
71038 IF(NEP.EQ.1) THEN
71039 P(N+1,1)=0D0
71040 P(N+1,2)=0D0
71041 P(N+1,3)=SQRT(MAX(0D0,(P(IPA(1),4)+P(N+1,5))*(P(IPA(1),4)-
71042 & P(N+1,5))))
71043 P(N+1,4)=P(IPA(1),4)
71044 V(N+1,2)=P(N+1,4)
71045 ELSEIF(IGM.EQ.0.AND.NEP.EQ.2) THEN
71046 PED1=0.5D0*(V(IM,5)+V(N+1,5)-V(N+2,5))/P(IM,5)
71047 P(N+1,1)=0D0
71048 P(N+1,2)=0D0
71049 P(N+1,3)=SQRT(MAX(0D0,(PED1+P(N+1,5))*(PED1-P(N+1,5))))
71050 P(N+1,4)=PED1
71051 P(N+2,1)=0D0
71052 P(N+2,2)=0D0
71053 P(N+2,3)=-P(N+1,3)
71054 P(N+2,4)=P(IM,5)-PED1
71055 V(N+1,2)=P(N+1,4)
71056 V(N+2,2)=P(N+2,4)
71057 ELSEIF(NEP.GE.3) THEN
71058C...Rescale all momenta for energy conservation.
71059 LOOP=0
71060 PES=0D0
71061 PQS=0D0
71062 DO 510 I=1,NEP
71063 DO 500 J=1,4
71064 P(N+I,J)=P(IPA(I),J)
71065 500 CONTINUE
71066 PES=PES+P(N+I,4)
71067 PQS=PQS+P(N+I,5)**2/P(N+I,4)
71068 510 CONTINUE
71069 520 LOOP=LOOP+1
71070 FAC=(PS(5)-PQS)/(PES-PQS)
71071 PES=0D0
71072 PQS=0D0
71073 DO 540 I=1,NEP
71074 DO 530 J=1,3
71075 P(N+I,J)=FAC*P(N+I,J)
71076 530 CONTINUE
71077 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)
71078 V(N+I,2)=P(N+I,4)
71079 PES=PES+P(N+I,4)
71080 PQS=PQS+P(N+I,5)**2/P(N+I,4)
71081 540 CONTINUE
71082 IF(LOOP.LT.10.AND.ABS(PES-PS(5)).GT.1D-12*PS(5)) GOTO 520
71083
71084C...Construct transverse momentum for ordinary branching in shower.
71085 ELSE
71086 ZM=V(IM,1)
71087 LOOPPT=0
71088 550 LOOPPT=LOOPPT+1
71089 PZM=SQRT(MAX(0D0,(PEM+P(IM,5))*(PEM-P(IM,5))))
71090 PMLS=(V(IM,5)-V(N+1,5)-V(N+2,5))**2-4D0*V(N+1,5)*V(N+2,5)
71091 IF(PZM.LE.0D0) THEN
71092 PTS=0D0
71093 ELSEIF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
71094 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71095 PTS=PMLS*ZM*(1D0-ZM)/V(IM,5)
71096 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
71097 PTS=(PEM**2*(ZM*(1D0-ZM)*V(IM,5)-(1D0-ZM)*V(N+1,5)-
71098 & ZM*V(N+2,5))-0.25D0*PMLS)/PZM**2
71099 ELSE
71100 PTS=PMLS*(ZM*(1D0-ZM)*PEM**2/V(IM,5)-0.25D0)/PZM**2
71101 ENDIF
71102 IF(PTS.LT.0D0.AND.LOOPPT.LT.10) THEN
71103 ZM=0.05D0+0.9D0*ZM
71104 GOTO 550
71105 ELSEIF(PTS.LT.0D0) THEN
71106 GOTO 280
71107 ENDIF
71108 PT=SQRT(MAX(0D0,PTS))
71109
71110C...Global statistics.
71111 MINT(353)=MINT(353)+1
71112 VINT(353)=VINT(353)+PT
71113 IF (MINT(353).EQ.1) VINT(358)=PT
71114
71115C...Find coefficient of azimuthal asymmetry due to gluon polarization.
71116 HAZIP=0D0
71117 IF(MSTJ(49).NE.1.AND.MOD(MSTJ(46),2).EQ.1.AND.K(IM,2).EQ.21
71118 & .AND.IAU.NE.0) THEN
71119 IF(K(IGM,3).NE.0) MAZIP=1
71120 ZAU=V(IGM,1)
71121 IF(IAU.EQ.IM+1) ZAU=1D0-V(IGM,1)
71122 IF(MAZIP.EQ.0) ZAU=0D0
71123 IF(K(IGM,2).NE.21) THEN
71124 HAZIP=2D0*ZAU/(1D0+ZAU**2)
71125 ELSE
71126 HAZIP=(ZAU/(1D0-ZAU*(1D0-ZAU)))**2
71127 ENDIF
71128 IF(K(N+1,2).NE.21) THEN
71129 HAZIP=HAZIP*(-2D0*ZM*(1D0-ZM))/(1D0-2D0*ZM*(1D0-ZM))
71130 ELSE
71131 HAZIP=HAZIP*(ZM*(1D0-ZM)/(1D0-ZM*(1D0-ZM)))**2
71132 ENDIF
71133 ENDIF
71134
71135C...Find coefficient of azimuthal asymmetry due to soft gluon
71136C...interference.
71137 HAZIC=0D0
71138 IF(MSTJ(49).NE.2.AND.MSTJ(46).GE.2.AND.(K(N+1,2).EQ.21.OR.
71139 & K(N+2,2).EQ.21).AND.IAU.NE.0) THEN
71140 IF(K(IGM,3).NE.0) MAZIC=N+1
71141 IF(K(IGM,3).NE.0.AND.K(N+1,2).NE.21) MAZIC=N+2
71142 IF(K(IGM,3).NE.0.AND.K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
71143 & ZM.GT.0.5D0) MAZIC=N+2
71144 IF(K(IAU,2).EQ.22) MAZIC=0
71145 ZS=ZM
71146 IF(MAZIC.EQ.N+2) ZS=1D0-ZM
71147 ZGM=V(IGM,1)
71148 IF(IAU.EQ.IM-1) ZGM=1D0-V(IGM,1)
71149 IF(MAZIC.EQ.0) ZGM=1D0
71150 IF(MAZIC.NE.0) HAZIC=(P(IM,5)/P(IGM,5))*
71151 & SQRT((1D0-ZS)*(1D0-ZGM)/(ZS*ZGM))
71152 HAZIC=MIN(0.95D0,HAZIC)
71153 ENDIF
71154 ENDIF
71155
71156C...Construct energies for ordinary branching in shower.
71157 560 IF(NEP.EQ.2.AND.IGM.GT.0) THEN
71158 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
71159 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71160 P(N+1,4)=0.5D0*(PEM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
71161 & PZM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
71162 ELSEIF(MOD(MSTJ(43),2).EQ.1) THEN
71163 P(N+1,4)=PEM*V(IM,1)
71164 ELSE
71165 P(N+1,4)=PEM*(0.5D0*(V(IM,5)-SQRT(PMLS)+V(N+1,5)-V(N+2,5))+
71166 & SQRT(PMLS)*ZM)/V(IM,5)
71167 ENDIF
71168
71169C...Already predetermined choice of phi angle or not
71170 PHI=PARU(2)*PYR(0)
71171 IF(MPSPD.EQ.1.AND.IGM.EQ.NS+1) THEN
71172 IPSPD=IP1+IM-NS-2
71173 IF(K(IPSPD,4).GT.0) THEN
71174 IPSGD1=K(IPSPD,4)
71175 IF(IM.EQ.NS+2) THEN
71176 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
71177 ELSE
71178 PHI=PYANGL(-P(IPSGD1,1),P(IPSGD1,2))
71179 ENDIF
71180 ENDIF
71181 ELSEIF(MPSPD.EQ.1.AND.IGM.EQ.NS+2) THEN
71182 IPSPD=IP1+IM-NS-2
71183 IF(K(IPSPD,4).GT.0) THEN
71184 IPSGD1=K(IPSPD,4)
71185 PHIPSM=PYANGL(P(IPSPD,1),P(IPSPD,2))
71186 THEPSM=PYANGL(P(IPSPD,3),SQRT(P(IPSPD,1)**2+P(IPSPD,2)**2))
71187 CALL PYROBO(IPSGD1,IPSGD1,0D0,-PHIPSM,0D0,0D0,0D0)
71188 CALL PYROBO(IPSGD1,IPSGD1,-THEPSM,0D0,0D0,0D0,0D0)
71189 PHI=PYANGL(P(IPSGD1,1),P(IPSGD1,2))
71190 CALL PYROBO(IPSGD1,IPSGD1,THEPSM,PHIPSM,0D0,0D0,0D0)
71191 ENDIF
71192 ENDIF
71193
71194C...Construct momenta for ordinary branching in shower.
71195 P(N+1,1)=PT*COS(PHI)
71196 P(N+1,2)=PT*SIN(PHI)
71197 IF(K(IM,2).EQ.21.AND.IABS(K(N+1,2)).LE.10.AND.
71198 & (MSTJ(44).EQ.3.OR.MSTJ(44).EQ.5)) THEN
71199 P(N+1,3)=0.5D0*(PZM*(V(IM,5)+V(N+1,5)-V(N+2,5))+
71200 & PEM*SQRT(MAX(0D0,PMLS))*(2D0*ZM-1D0))/V(IM,5)
71201 ELSEIF(PZM.GT.0D0) THEN
71202 P(N+1,3)=0.5D0*(V(N+2,5)-V(N+1,5)-V(IM,5)+
71203 & 2D0*PEM*P(N+1,4))/PZM
71204 ELSE
71205 P(N+1,3)=0D0
71206 ENDIF
71207 P(N+2,1)=-P(N+1,1)
71208 P(N+2,2)=-P(N+1,2)
71209 P(N+2,3)=PZM-P(N+1,3)
71210 P(N+2,4)=PEM-P(N+1,4)
71211 IF(MSTJ(43).LE.2) THEN
71212 V(N+1,2)=(PEM*P(N+1,4)-PZM*P(N+1,3))/P(IM,5)
71213 V(N+2,2)=(PEM*P(N+2,4)-PZM*P(N+2,3))/P(IM,5)
71214 ENDIF
71215 ENDIF
71216
71217C...Rotate and boost daughters.
71218 IF(IGM.GT.0) THEN
71219 IF(MSTJ(43).LE.2) THEN
71220 BEX=P(IGM,1)/P(IGM,4)
71221 BEY=P(IGM,2)/P(IGM,4)
71222 BEZ=P(IGM,3)/P(IGM,4)
71223 GA=P(IGM,4)/P(IGM,5)
71224 GABEP=GA*(GA*(BEX*P(IM,1)+BEY*P(IM,2)+BEZ*P(IM,3))/(1D0+GA)-
71225 & P(IM,4))
71226 ELSE
71227 BEX=0D0
71228 BEY=0D0
71229 BEZ=0D0
71230 GA=1D0
71231 GABEP=0D0
71232 ENDIF
71233 PTIMB=SQRT((P(IM,1)+GABEP*BEX)**2+(P(IM,2)+GABEP*BEY)**2)
71234 THE=PYANGL(P(IM,3)+GABEP*BEZ,PTIMB)
71235 IF(PTIMB.GT.1D-4) THEN
71236 PHI=PYANGL(P(IM,1)+GABEP*BEX,P(IM,2)+GABEP*BEY)
71237 ELSE
71238 PHI=0D0
71239 ENDIF
71240 DO 570 I=N+1,N+2
71241 DP(1)=COS(THE)*COS(PHI)*P(I,1)-SIN(PHI)*P(I,2)+
71242 & SIN(THE)*COS(PHI)*P(I,3)
71243 DP(2)=COS(THE)*SIN(PHI)*P(I,1)+COS(PHI)*P(I,2)+
71244 & SIN(THE)*SIN(PHI)*P(I,3)
71245 DP(3)=-SIN(THE)*P(I,1)+COS(THE)*P(I,3)
71246 DP(4)=P(I,4)
71247 DBP=BEX*DP(1)+BEY*DP(2)+BEZ*DP(3)
71248 DGABP=GA*(GA*DBP/(1D0+GA)+DP(4))
71249 P(I,1)=DP(1)+DGABP*BEX
71250 P(I,2)=DP(2)+DGABP*BEY
71251 P(I,3)=DP(3)+DGABP*BEZ
71252 P(I,4)=GA*(DP(4)+DBP)
71253 570 CONTINUE
71254 ENDIF
71255
71256C...Weight with azimuthal distribution, if required.
71257 IF(MAZIP.NE.0.OR.MAZIC.NE.0) THEN
71258 DO 580 J=1,3
71259 DPT(1,J)=P(IM,J)
71260 DPT(2,J)=P(IAU,J)
71261 DPT(3,J)=P(N+1,J)
71262 580 CONTINUE
71263 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
71264 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
71265 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
71266 DO 590 J=1,3
71267 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
71268 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
71269 590 CONTINUE
71270 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
71271 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
71272 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
71273 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
71274 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
71275 IF(MAZIP.NE.0) THEN
71276 IF(1D0+HAZIP*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(HAZIP)))
71277 & GOTO 560
71278 ENDIF
71279 IF(MAZIC.NE.0) THEN
71280 IF(MAZIC.EQ.N+2) CAD=-CAD
71281 IF((1D0-HAZIC)*(1D0-HAZIC*CAD)/(1D0+HAZIC**2-2D0*HAZIC*CAD)
71282 & .LT.PYR(0)) GOTO 560
71283 ENDIF
71284 ENDIF
71285 ENDIF
71286
71287C...Azimuthal anisotropy due to interference with initial state partons.
71288 IF(MOD(MIIS,2).EQ.1.AND.IGM.EQ.NS+1.AND.(K(N+1,2).EQ.21.OR.
71289 &K(N+2,2).EQ.21)) THEN
71290 III=IM-NS-1
71291 IF(ISII(III).GE.1) THEN
71292 IAZIID=N+1
71293 IF(K(N+1,2).NE.21) IAZIID=N+2
71294 IF(K(N+1,2).EQ.21.AND.K(N+2,2).EQ.21.AND.
71295 & P(N+1,4).GT.P(N+2,4)) IAZIID=N+2
71296 THEIID=PYANGL(P(IAZIID,3),SQRT(P(IAZIID,1)**2+P(IAZIID,2)**2))
71297 IF(III.EQ.2) THEIID=PARU(1)-THEIID
71298 PHIIID=PYANGL(P(IAZIID,1),P(IAZIID,2))
71299 HAZII=MIN(0.95D0,THEIID/THEIIS(III,ISII(III)))
71300 CAD=COS(PHIIID-PHIIIS(III,ISII(III)))
71301 PHIREL=ABS(PHIIID-PHIIIS(III,ISII(III)))
71302 IF(PHIREL.GT.PARU(1)) PHIREL=PARU(2)-PHIREL
71303 IF((1D0-HAZII)*(1D0-HAZII*CAD)/(1D0+HAZII**2-2D0*HAZII*CAD)
71304 & .LT.PYR(0)) GOTO 560
71305 ENDIF
71306 ENDIF
71307
71308C...Continue loop over partons that may branch, until none left.
71309 IF(IGM.GE.0) K(IM,1)=14
71310 N=N+NEP
71311 NEP=2
71312 IF(N.GT.MSTU(4)-MSTU(32)-10) THEN
71313 CALL PYERRM(11,'(PYSHOW:) no more memory left in PYJETS')
71314 IF(MSTU(21).GE.1) N=NS
71315 IF(MSTU(21).GE.1) RETURN
71316 ENDIF
71317 GOTO 290
71318
71319C...Set information on imagined shower initiator.
71320 600 IF(NPA.GE.2) THEN
71321 K(NS+1,1)=11
71322 K(NS+1,2)=94
71323 K(NS+1,3)=IP1
71324 IF(IP2.GT.0.AND.IP2.LT.IP1) K(NS+1,3)=IP2
71325 K(NS+1,4)=NS+2
71326 K(NS+1,5)=NS+1+NPA
71327 IIM=1
71328 ELSE
71329 IIM=0
71330 ENDIF
71331
71332C...Reconstruct string drawing information.
71333 DO 610 I=NS+1+IIM,N
71334 KQ=KCHG(PYCOMP(K(I,2)),2)
71335 IF(K(I,1).LE.10.AND.K(I,2).EQ.22) THEN
71336 K(I,1)=1
71337 ELSEIF(K(I,1).LE.10.AND.IABS(K(I,2)).GE.11.AND.
71338 & IABS(K(I,2)).LE.18) THEN
71339 K(I,1)=1
71340 ELSEIF(K(I,1).LE.10) THEN
71341 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))
71342 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))
71343 ELSEIF(K(MOD(K(I,4),MSTU(5))+1,2).NE.22) THEN
71344 ID1=MOD(K(I,4),MSTU(5))
71345 IF(KQ.EQ.1.AND.K(I,2).GT.0) ID1=MOD(K(I,4),MSTU(5))+1
71346 IF(KQ.EQ.2.AND.(K(ID1,2).EQ.21.OR.K(ID1+1,2).EQ.21).AND.
71347 & PYR(0).GT.0.5D0) ID1=MOD(K(I,4),MSTU(5))+1
71348 ID2=2*MOD(K(I,4),MSTU(5))+1-ID1
71349 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
71350 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID2
71351 K(ID1,4)=K(ID1,4)+MSTU(5)*I
71352 K(ID1,5)=K(ID1,5)+MSTU(5)*ID2
71353 K(ID2,4)=K(ID2,4)+MSTU(5)*ID1
71354 K(ID2,5)=K(ID2,5)+MSTU(5)*I
71355 ELSE
71356 ID1=MOD(K(I,4),MSTU(5))
71357 ID2=ID1+1
71358 K(I,4)=MSTU(5)*(K(I,4)/MSTU(5))+ID1
71359 K(I,5)=MSTU(5)*(K(I,5)/MSTU(5))+ID1
71360 IF(KQ.EQ.1.OR.K(ID1,1).GE.11) THEN
71361 K(ID1,4)=K(ID1,4)+MSTU(5)*I
71362 K(ID1,5)=K(ID1,5)+MSTU(5)*I
71363 ELSE
71364 K(ID1,4)=0
71365 K(ID1,5)=0
71366 ENDIF
71367 K(ID2,4)=0
71368 K(ID2,5)=0
71369 ENDIF
71370 610 CONTINUE
71371
71372C...Transformation from CM frame.
71373 IF(NPA.EQ.1) THEN
71374 THE=PYANGL(P(IPA(1),3),SQRT(P(IPA(1),1)**2+P(IPA(1),2)**2))
71375 PHI=PYANGL(P(IPA(1),1),P(IPA(1),2))
71376 MSTU(33)=1
71377 CALL PYROBO(NS+1,N,THE,PHI,0D0,0D0,0D0)
71378 ELSEIF(NPA.EQ.2) THEN
71379 BEX=PS(1)/PS(4)
71380 BEY=PS(2)/PS(4)
71381 BEZ=PS(3)/PS(4)
71382 GA=PS(4)/PS(5)
71383 GABEP=GA*(GA*(BEX*P(IPA(1),1)+BEY*P(IPA(1),2)+BEZ*P(IPA(1),3))
71384 & /(1D0+GA)-P(IPA(1),4))
71385 THE=PYANGL(P(IPA(1),3)+GABEP*BEZ,SQRT((P(IPA(1),1)
71386 & +GABEP*BEX)**2+(P(IPA(1),2)+GABEP*BEY)**2))
71387 PHI=PYANGL(P(IPA(1),1)+GABEP*BEX,P(IPA(1),2)+GABEP*BEY)
71388 MSTU(33)=1
71389 CALL PYROBO(NS+1,N,THE,PHI,BEX,BEY,BEZ)
71390 ELSE
71391 CALL PYROBO(IPA(1),IPA(NPA),0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),
71392 & PS(3)/PS(4))
71393 MSTU(33)=1
71394 CALL PYROBO(NS+1,N,0D0,0D0,PS(1)/PS(4),PS(2)/PS(4),PS(3)/PS(4))
71395 ENDIF
71396
71397C...Decay vertex of shower.
71398 DO 630 I=NS+1,N
71399 DO 620 J=1,5
71400 V(I,J)=V(IP1,J)
71401 620 CONTINUE
71402 630 CONTINUE
71403
71404C...Delete trivial shower, else connect initiators.
71405 IF(N.LE.NS+NPA+IIM) THEN
71406 N=NS
71407 ELSE
71408 DO 640 IP=1,NPA
71409 K(IPA(IP),1)=14
71410 K(IPA(IP),4)=K(IPA(IP),4)+NS+IIM+IP
71411 K(IPA(IP),5)=K(IPA(IP),5)+NS+IIM+IP
71412 K(NS+IIM+IP,3)=IPA(IP)
71413 IF(IIM.EQ.1.AND.MSTU(16).NE.2) K(NS+IIM+IP,3)=NS+1
71414 IF(K(NS+IIM+IP,1).NE.1) THEN
71415 K(NS+IIM+IP,4)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,4)
71416 K(NS+IIM+IP,5)=MSTU(5)*IPA(IP)+K(NS+IIM+IP,5)
71417 ENDIF
71418 640 CONTINUE
71419 ENDIF
71420
71421 RETURN
71422 END
71423
71424C*********************************************************************
71425
71426C...PYPTFS
71427C...Generates pT-ordered timelike final-state parton showers.
71428
71429C...MODE defines how to find radiators and recoilers.
71430C... = 0 : based on colour flow between undecayed partons.
71431C... = 1 : for IPART <= NPARTD only consider primary partons,
71432C... whether decayed or not; else as above.
71433C... = 2 : based on common history, whether decayed or not.
71434C... = 3 : use (or create) MCT color information to shower partons
71435
71436 SUBROUTINE PYPTFS(MODE,PTMAX,PTMIN,PTGEN)
71437
71438C...Double precision and integer declarations.
71439 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
71440 IMPLICIT INTEGER(I-N)
71441 INTEGER PYK,PYCHGE,PYCOMP
71442C...Parameter statement to help give large particle numbers.
71443 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
71444 &KEXCIT=4000000,KDIMEN=5000000)
71445C...Parameter statement for maximum size of showers.
71446 PARAMETER (MAXNUR=1000)
71447C...Commonblocks.
71448 COMMON/PYPART/NPART,NPARTD,IPART(MAXNUR),PTPART(MAXNUR)
71449 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
71450 COMMON/PYCTAG/NCT,MCT(4000,2)
71451 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
71452 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
71453 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
71454 COMMON/PYINT1/MINT(400),VINT(400)
71455 SAVE /PYPART/,/PYJETS/,/PYCTAG/,/PYDAT1/,/PYDAT2/,/PYPARS/,
71456 &/PYINT1/
71457C...Local arrays.
71458 DIMENSION IPOS(2*MAXNUR),IREC(2*MAXNUR),IFLG(2*MAXNUR),
71459 &ISCOL(2*MAXNUR),ISCHG(2*MAXNUR),PTSCA(2*MAXNUR),IMESAV(2*MAXNUR),
71460 &PT2SAV(2*MAXNUR),ZSAV(2*MAXNUR),SHTSAV(2*MAXNUR),
71461 &MESYS(MAXNUR,0:2),PSUM(5),DPT(5,4)
71462C...Statement functions.
71463 SHAT(L,J)=(P(L,4)+P(J,4))**2-(P(L,1)+P(J,1))**2-
71464 &(P(L,2)+P(J,2))**2-(P(L,3)+P(J,3))**2
71465 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)
71466
71467C...Initial values. Check that valid system.
71468 PTGEN=0D0
71469 IF(MSTJ(41).NE.1.AND.MSTJ(41).NE.2.AND.MSTJ(41).NE.11.AND.
71470 &MSTJ(41).NE.12) RETURN
71471 IF(NPART.LE.0) THEN
71472 CALL PYERRM(2,'(PYPTFS:) showering system too small')
71473 RETURN
71474 ENDIF
71475 PT2CMX=PTMAX**2
71476 IORD=1
71477
71478C...Mass thresholds and Lambda for QCD evolution.
71479 PMB=PMAS(5,1)
71480 PMC=PMAS(4,1)
71481 ALAM5=PARJ(81)
71482 ALAM4=ALAM5*(PMB/ALAM5)**(2D0/25D0)
71483 ALAM3=ALAM4*(PMC/ALAM4)**(2D0/27D0)
71484 PMBS=PMB**2
71485 PMCS=PMC**2
71486 ALAM5S=ALAM5**2
71487 ALAM4S=ALAM4**2
71488 ALAM3S=ALAM3**2
71489
71490C...Cutoff scale for QCD evolution. Starting pT2.
71491 NFLAV=MAX(0,MIN(5,MSTJ(45)))
71492 PT0C=0.5D0*PARJ(82)
71493 PT2CMN=MAX(PTMIN,PT0C,1.1D0*ALAM3)**2
71494
71495C...Parameters for QED evolution.
71496 AEM2PI=PARU(101)/PARU(2)
71497 PT0EQ=0.5D0*PARJ(83)
71498 PT0EL=0.5D0*PARJ(90)
71499
71500C...Reset. Remove irrelevant colour tags.
71501 NEVOL=0
71502 DO 100 J=1,4
71503 PSUM(J)=0D0
71504 100 CONTINUE
71505 DO 110 I=MINT(84)+1,N
71506 IF(K(I,2).GT.0.AND.K(I,2).LT.6) THEN
71507 K(I,5)=0
71508 MCT(I,2)=0
71509 ENDIF
71510 IF(K(I,2).LT.0.AND.K(I,2).GT.-6) THEN
71511 K(I,4)=0
71512 MCT(I,1)=0
71513 ENDIF
71514 110 CONTINUE
71515 NPARTS=NPART
71516
71517C...Begin loop to set up showering partons. Sum four-momenta.
71518 DO 230 IP=1,NPART
71519 I=IPART(IP)
71520 IF(MODE.NE.1.OR.I.GT.NPARTD) THEN
71521 IF(K(I,1).GT.10) GOTO 230
71522 ELSEIF(K(I,3).GT.MINT(84)) THEN
71523 IF(K(I,3).GT.MINT(84)+2) GOTO 230
71524 ELSE
71525 IF(K(K(I,3),3).GT.MINT(83)+6) GOTO 230
71526 ENDIF
71527 DO 120 J=1,4
71528 PSUM(J)=PSUM(J)+P(I,J)
71529 120 CONTINUE
71530
71531C...Find colour and charge, but skip diquarks.
71532 IF(IABS(K(I,2)).GT.1000.AND.IABS(K(I,2)).LT.10000) GOTO 230
71533 KCOL=PYK(I,12)
71534 KCHA=PYK(I,6)
71535
71536C...QUARKONIA++
71537 IF (IABS(K(I,2)).GE.9900101.AND.IABS(K(I,2)).LE.9910555) THEN
71538 IF (MSTP(148).GE.1) THEN
71539C...Temporary: force no radiation from quarkonia since not yet treated
71540 CALL PYERRM(11,'(PYPTFS:) quarkonia showers not yet in'
71541 & //' PYPTFS, switched off')
71542 CALL PYGIVE('MSTP(148)=0')
71543 ENDIF
71544 IF (MSTP(148).EQ.0) THEN
71545C...Skip quarkonia if radiation switched off
71546 GOTO 230
71547 ENDIF
71548 ENDIF
71549C...QUARKONIA--
71550
71551C...Option to switch off radiation from particle KF = MSTJ(39) entirely
71552C...(only intended for studying the effects of switching such rad on/off)
71553 IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) THEN
71554 GOTO 230
71555 ENDIF
71556
71557C...Either colour or anticolour charge radiates; for gluon both.
71558 DO 180 JSGCOL=1,-1,-2
71559 IF(KCOL.EQ.JSGCOL.OR.KCOL.EQ.2) THEN
71560 JCOL=4+(1-JSGCOL)/2
71561 JCOLR=9-JCOL
71562
71563C...Basic info about radiating parton.
71564 NEVOL=NEVOL+1
71565 IPOS(NEVOL)=I
71566 IFLG(NEVOL)=0
71567 ISCOL(NEVOL)=JSGCOL
71568 ISCHG(NEVOL)=0
71569 PTSCA(NEVOL)=PTPART(IP)
71570
71571C...Begin search for colour recoiler when MODE = 0 or 1.
71572 IF(MODE.LE.1) THEN
71573C...Find sister with matching anticolour to the radiating parton.
71574 IROLD=I
71575 IRNEW=K(IROLD,JCOL)/MSTU(5)
71576 MOVE=1
71577
71578C...Skip radiation off loose colour ends.
71579 130 IF(IRNEW.EQ.0) THEN
71580 NEVOL=NEVOL-1
71581 GOTO 180
71582
71583C...Optionally skip radiation on dipole to beam remnant.
71584 ELSEIF(MSTP(72).LE.1.AND.IRNEW.GT.MINT(53)) THEN
71585 NEVOL=NEVOL-1
71586 GOTO 180
71587
71588C...For now always skip radiation on dipole to junction.
71589 ELSEIF(K(IRNEW,2).EQ.88) THEN
71590 NEVOL=NEVOL-1
71591 GOTO 180
71592
71593C...For MODE=1: if reached primary then done.
71594 ELSEIF(MODE.EQ.1.AND.IRNEW.GT.MINT(84)+2.AND.
71595 & IRNEW.LE.NPARTD) THEN
71596
71597C...If sister stable and points back then done.
71598 ELSEIF(MOVE.EQ.1.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
71599 & THEN
71600 IF(K(IRNEW,1).LT.10) THEN
71601
71602C...If sister unstable then go to her daughter.
71603 ELSE
71604 IROLD=IRNEW
71605 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
71606 MOVE=2
71607 GOTO 130
71608 ENDIF
71609
71610C...If found mother then look for aunt.
71611 ELSEIF(MOVE.EQ.1.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
71612 & IROLD) THEN
71613 IROLD=IRNEW
71614 IRNEW=K(IROLD,JCOL)/MSTU(5)
71615 GOTO 130
71616
71617C...If daughter stable then done.
71618 ELSEIF(MOVE.EQ.2.AND.K(IRNEW,JCOLR)/MSTU(5).EQ.IROLD)
71619 & THEN
71620 IF(K(IRNEW,1).LT.10) THEN
71621
71622C...If daughter unstable then go to granddaughter.
71623 ELSE
71624 IROLD=IRNEW
71625 IRNEW=MOD(K(IRNEW,JCOLR),MSTU(5))
71626 MOVE=2
71627 GOTO 130
71628 ENDIF
71629
71630C...If daughter points to another daughter then done or move up.
71631 ELSEIF(MOVE.EQ.2.AND.MOD(K(IRNEW,JCOL),MSTU(5)).EQ.
71632 & IROLD) THEN
71633 IF(K(IRNEW,1).LT.10) THEN
71634 ELSE
71635 IROLD=IRNEW
71636 IRNEW=K(IRNEW,JCOL)/MSTU(5)
71637 MOVE=1
71638 GOTO 130
71639 ENDIF
71640 ENDIF
71641
71642C...Begin search for colour recoiler when MODE = 2.
71643 ELSEIF (MODE.EQ.2) THEN
71644 IROLD=I
71645 IRNEW=K(IROLD,JCOL)/MSTU(5)
71646 140 IF (IRNEW.LE.0.OR.IRNEW.GT.N) THEN
71647C...If no color partner found, pick at random among other primaries
71648C...(e.g., when the color line is traced all the way to the beam)
71649 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
71650 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
71651 ELSEIF(K(IRNEW,JCOLR)/MSTU(5).NE.IROLD) THEN
71652C...Step up to mother if radiating parton already branched.
71653 IF(K(IRNEW,2).EQ.K(IROLD,2)) THEN
71654 IROLD=IRNEW
71655 IRNEW=K(IROLD,JCOL)/MSTU(5)
71656 GOTO 140
71657C...Pick sister by history if no anticolour available.
71658 ELSE
71659 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
71660 IRNEW=IROLD-1
71661 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3))
71662 & THEN
71663 IRNEW=IROLD+1
71664C...Last resort: pick at random among other primaries.
71665 ELSE
71666 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
71667 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
71668 ENDIF
71669 ENDIF
71670 ENDIF
71671C...Trace down if sister branched.
71672 150 IF(K(IRNEW,1).GT.10) THEN
71673 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
71674C...If no correct color-daughter found, swap.
71675 IF (IRTMP.EQ.0) THEN
71676 JCOL=9-JCOL
71677 JCOLR=9-JCOLR
71678 IRTMP=MOD(K(IRNEW,JCOLR),MSTU(5))
71679 ENDIF
71680 IRNEW=IRTMP
71681 GOTO 150
71682 ENDIF
71683 ELSEIF (MODE.EQ.3) THEN
71684C...The following will add MCT colour tracing for unprepped events
71685C...If not done, trace Les Houches colour tags for this dipole
71686 JCOLSV=JCOL
71687 IF (MCT(I,JCOL-3).EQ.0) THEN
71688C...Special end code -1 : trace to color partner or 0, return in IEND
71689 IEND=-1
71690 CALL PYCTTR(I,JCOL,IEND)
71691C...Clean up mother/daughter 'read' tags set by PYCTTR
71692 JCOL=JCOLSV
71693 DO 160 IR=1,N
71694 K(IR,4)=MOD(K(IR,4),MSTU(5)**2)
71695 K(IR,5)=MOD(K(IR,5),MSTU(5)**2)
71696 MCT(IR,1)=0
71697 MCT(IR,2)=0
71698 160 CONTINUE
71699 ELSE
71700 IEND=0
71701 DO 170 IR=1,N
71702 IF (K(IR,1).GT.0.AND.MCT(IR,6-JCOL).EQ.MCT(I,JCOL-3))
71703 & IEND=IR
71704 170 CONTINUE
71705 ENDIF
71706C...If no color partner, then we hit beam
71707 IF (IEND.LE.0) THEN
71708C...For MSTP(72) <= 1, do not allow dipoles stretched to beam to radiate
71709 IF (MSTP(72).LE.1) THEN
71710 NEVOL=NEVOL-1
71711 GOTO 180
71712 ELSE
71713C...Else try a random partner
71714 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
71715 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
71716 ENDIF
71717 ELSE
71718C...Else save recoiling colour partner
71719 IRNEW=IEND
71720 ENDIF
71721
71722 ENDIF
71723
71724C...Now found other end of colour dipole.
71725 IREC(NEVOL)=IRNEW
71726 ENDIF
71727 180 CONTINUE
71728
71729C...Also electrical charge may radiate; so far only quarks and leptons.
71730 IF((MSTJ(41).EQ.2.OR.MSTJ(41).EQ.12).AND.KCHA.NE.0.AND.
71731 & IABS(K(I,2)).LE.18) THEN
71732
71733C...Basic info about radiating parton.
71734 NEVOL=NEVOL+1
71735 IPOS(NEVOL)=I
71736 IFLG(NEVOL)=0
71737 ISCOL(NEVOL)=0
71738 ISCHG(NEVOL)=KCHA
71739 PTSCA(NEVOL)=PTPART(IP)
71740
71741C...Pick nearest (= smallest invariant mass) charged particle
71742C...as recoiler when MODE = 0 or 1 (but for latter among primaries).
71743 IF(MODE.LE.1) THEN
71744 IRNEW=0
71745 PM2MIN=VINT(2)
71746 DO 190 IP2=1,NPART+N-MINT(53)
71747 IF(IP2.EQ.IP) GOTO 190
71748 IF(IP2.LE.NPART) THEN
71749 I2=IPART(IP2)
71750 IF(MODE.NE.1.OR.I2.GT.NPARTD) THEN
71751 IF(K(I2,1).GT.10) GOTO 190
71752 ELSEIF(K(I2,3).GT.MINT(84)) THEN
71753 IF(K(I2,3).GT.MINT(84)+2) GOTO 190
71754 ELSE
71755 IF(K(K(I2,3),3).GT.MINT(83)+6) GOTO 190
71756 ENDIF
71757 ELSE
71758 I2=MINT(53)+IP2-NPART
71759 ENDIF
71760 IF(KCHG(PYCOMP(K(I2,2)),1).EQ.0) GOTO 190
71761 PM2INV=(P(I,4)+P(I2,4))**2-(P(I,1)+P(I2,1))**2-
71762 & (P(I,2)+P(I2,2))**2-(P(I,3)+P(I2,3))**2
71763 IF(PM2INV.LT.PM2MIN) THEN
71764 IRNEW=I2
71765 PM2MIN=PM2INV
71766 ENDIF
71767 190 CONTINUE
71768 IF(IRNEW.EQ.0) THEN
71769 NEVOL=NEVOL-1
71770 GOTO 230
71771 ENDIF
71772
71773C...Begin search for charge recoiler when MODE = 2.
71774 ELSE
71775 IROLD=I
71776C...Pick sister by history; step up if parton already branched.
71777 200 IF(K(IROLD,3).GT.0.AND.K(K(IROLD,3),2).EQ.K(IROLD,2)) THEN
71778 IROLD=K(IROLD,3)
71779 GOTO 200
71780 ENDIF
71781 IF(IROLD.GT.1.AND.K(IROLD-1,3).EQ.K(IROLD,3)) THEN
71782 IRNEW=IROLD-1
71783 ELSEIF(IROLD.LT.N.AND.K(IROLD+1,3).EQ.K(IROLD,3)) THEN
71784 IRNEW=IROLD+1
71785C...Last resort: pick at random among other primaries.
71786 ELSE
71787 ISTEP=MAX(1,MIN(NPART-1,INT(1D0+(NPART-1)*PYR(0))))
71788 IRNEW=IPART(1+MOD(IP+ISTEP-1,NPART))
71789 ENDIF
71790C...Trace down if sister branched.
71791 210 IF(K(IRNEW,1).GT.10) THEN
71792 DO 220 IR=IRNEW+1,N
71793 IF(K(IR,3).EQ.IRNEW.AND.K(IR,2).EQ.K(IRNEW,2)) THEN
71794 IRNEW=IR
71795 GOTO 210
71796 ENDIF
71797 220 CONTINUE
71798 ENDIF
71799 ENDIF
71800 IREC(NEVOL)=IRNEW
71801 ENDIF
71802
71803C...End loop to set up showering partons. System invariant mass.
71804 230 CONTINUE
71805 IF(NEVOL.LE.0) RETURN
71806 IF (MODE.EQ.3.AND.NEVOL.LE.1) RETURN
71807 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
71808
71809C...Check if 3-jet matrix elements to be used.
71810 M3JC=0
71811 ALPHA=0.5D0
71812 NMESYS=0
71813 IF(MSTJ(47).GE.1) THEN
71814
71815C...Identify source: q(1), ~q(2), V(3), S(4), chi(5), ~g(6), unknown(0).
71816 KFSRCE=0
71817 IPART1=K(IPART(1),3)
71818 IPART2=K(IPART(2),3)
71819 240 IF(IPART1.EQ.IPART2.AND.IPART1.GT.0) THEN
71820 KFSRCE=IABS(K(IPART1,2))
71821 ELSEIF(IPART1.GT.IPART2.AND.IPART2.GT.0) THEN
71822 IPART1=K(IPART1,3)
71823 GOTO 240
71824 ELSEIF(IPART2.GT.IPART1.AND.IPART1.GT.0) THEN
71825 IPART2=K(IPART2,3)
71826 GOTO 240
71827 ENDIF
71828 ITYPES=0
71829 IF(KFSRCE.GE.1.AND.KFSRCE.LE.8) ITYPES=1
71830 IF(KFSRCE.GE.KSUSY1+1.AND.KFSRCE.LE.KSUSY1+8) ITYPES=2
71831 IF(KFSRCE.GE.KSUSY2+1.AND.KFSRCE.LE.KSUSY2+8) ITYPES=2
71832 IF(KFSRCE.GE.21.AND.KFSRCE.LE.24) ITYPES=3
71833 IF(KFSRCE.GE.32.AND.KFSRCE.LE.34) ITYPES=3
71834 IF(KFSRCE.EQ.25.OR.(KFSRCE.GE.35.AND.KFSRCE.LE.37)) ITYPES=4
71835 IF(KFSRCE.GE.KSUSY1+22.AND.KFSRCE.LE.KSUSY1+37) ITYPES=5
71836 IF(KFSRCE.EQ.KSUSY1+21) ITYPES=6
71837
71838C...Identify two primary showerers.
71839 KFLA1=IABS(K(IPART(1),2))
71840 ITYPE1=0
71841 IF(KFLA1.GE.1.AND.KFLA1.LE.8) ITYPE1=1
71842 IF(KFLA1.GE.KSUSY1+1.AND.KFLA1.LE.KSUSY1+8) ITYPE1=2
71843 IF(KFLA1.GE.KSUSY2+1.AND.KFLA1.LE.KSUSY2+8) ITYPE1=2
71844 IF(KFLA1.GE.21.AND.KFLA1.LE.24) ITYPE1=3
71845 IF(KFLA1.GE.32.AND.KFLA1.LE.34) ITYPE1=3
71846 IF(KFLA1.EQ.25.OR.(KFLA1.GE.35.AND.KFLA1.LE.37)) ITYPE1=4
71847 IF(KFLA1.GE.KSUSY1+22.AND.KFLA1.LE.KSUSY1+37) ITYPE1=5
71848 IF(KFLA1.EQ.KSUSY1+21) ITYPE1=6
71849 KFLA2=IABS(K(IPART(2),2))
71850 ITYPE2=0
71851 IF(KFLA2.GE.1.AND.KFLA2.LE.8) ITYPE2=1
71852 IF(KFLA2.GE.KSUSY1+1.AND.KFLA2.LE.KSUSY1+8) ITYPE2=2
71853 IF(KFLA2.GE.KSUSY2+1.AND.KFLA2.LE.KSUSY2+8) ITYPE2=2
71854 IF(KFLA2.GE.21.AND.KFLA2.LE.24) ITYPE2=3
71855 IF(KFLA2.GE.32.AND.KFLA2.LE.34) ITYPE2=3
71856 IF(KFLA2.EQ.25.OR.(KFLA2.GE.35.AND.KFLA2.LE.37)) ITYPE2=4
71857 IF(KFLA2.GE.KSUSY1+22.AND.KFLA2.LE.KSUSY1+37) ITYPE2=5
71858 IF(KFLA2.EQ.KSUSY1+21) ITYPE2=6
71859
71860C...Order of showerers. Presence of gluino.
71861 ITYPMN=MIN(ITYPE1,ITYPE2)
71862 ITYPMX=MAX(ITYPE1,ITYPE2)
71863 IORD=1
71864 IF(ITYPE1.GT.ITYPE2) IORD=2
71865 IGLUI=0
71866 IF(ITYPE1.EQ.6.OR.ITYPE2.EQ.6) IGLUI=1
71867
71868C...Require exactly two primary showerers for ME corrections.
71869 NPRIM=0
71870 IF(IPART1.GT.0) THEN
71871 DO 250 I=1,N
71872 IF(K(I,3).EQ.IPART1.AND.K(I,2).NE.K(IPART1,2)) NPRIM=NPRIM+1
71873 250 CONTINUE
71874 ENDIF
71875 IF(NPRIM.NE.2) THEN
71876
71877C...Predetermined and default matrix element kinds.
71878 ELSEIF(MSTJ(38).NE.0) THEN
71879 M3JC=MSTJ(38)
71880 ALPHA=PARJ(80)
71881 MSTJ(38)=0
71882 ELSEIF(MSTJ(47).GE.6) THEN
71883 M3JC=MSTJ(47)
71884 ELSE
71885 ICLASS=1
71886 ICOMBI=4
71887
71888C...Vector/axial vector -> q + qbar; q -> q + V.
71889 IF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.(ITYPES.EQ.0.OR.
71890 & ITYPES.EQ.3)) THEN
71891 ICLASS=2
71892 IF(KFSRCE.EQ.21.OR.KFSRCE.EQ.22) THEN
71893 ICOMBI=1
71894 ELSEIF(KFSRCE.EQ.23.OR.(KFSRCE.EQ.0.AND.
71895 & K(IPART(1),2)+K(IPART(2),2).EQ.0)) THEN
71896C...gamma*/Z0: assume e+e- initial state if unknown.
71897 EI=-1D0
71898 IF(KFSRCE.EQ.23) THEN
71899 IANNFL=IPART1
71900 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
71901 IF(IANNFL.GT.0) THEN
71902 IF(K(IANNFL,2).EQ.23) IANNFL=K(IANNFL,3)
71903 ENDIF
71904 IF(IANNFL.NE.0) THEN
71905 KANNFL=IABS(K(IANNFL,2))
71906 IF(KANNFL.GE.1.AND.KANNFL.LE.18) EI=KCHG(KANNFL,1)/3D0
71907 ENDIF
71908 ENDIF
71909 AI=SIGN(1D0,EI+0.1D0)
71910 VI=AI-4D0*EI*PARU(102)
71911 EF=KCHG(KFLA1,1)/3D0
71912 AF=SIGN(1D0,EF+0.1D0)
71913 VF=AF-4D0*EF*PARU(102)
71914 XWC=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
71915 SH=PSUM(5)**2
71916 SQMZ=PMAS(23,1)**2
71917 SQWZ=PSUM(5)*PMAS(23,2)
71918 SBWZ=1D0/((SH-SQMZ)**2+SQWZ**2)
71919 VECT=EI**2*EF**2+2D0*EI*VI*EF*VF*XWC*SH*(SH-SQMZ)*SBWZ+
71920 & (VI**2+AI**2)*VF**2*XWC**2*SH**2*SBWZ
71921 AXIV=(VI**2+AI**2)*AF**2*XWC**2*SH**2*SBWZ
71922 ICOMBI=3
71923 ALPHA=VECT/(VECT+AXIV)
71924 ELSEIF(KFSRCE.EQ.24.OR.KFSRCE.EQ.0) THEN
71925 ICOMBI=4
71926 ENDIF
71927C...For chi -> chi q qbar, use V/A -> q qbar as first approximation.
71928 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.5) THEN
71929 ICLASS=2
71930 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
71931 & ITYPES.EQ.1)) THEN
71932 ICLASS=3
71933
71934C...Scalar/pseudoscalar -> q + qbar; q -> q + S.
71935 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.1.AND.ITYPES.EQ.4) THEN
71936 ICLASS=4
71937 IF(KFSRCE.EQ.25.OR.KFSRCE.EQ.35.OR.KFSRCE.EQ.37) THEN
71938 ICOMBI=1
71939 ELSEIF(KFSRCE.EQ.36) THEN
71940 ICOMBI=2
71941 ENDIF
71942 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
71943 & ITYPES.EQ.1)) THEN
71944 ICLASS=5
71945
71946C...V -> ~q + ~qbar; ~q -> ~q + V; S -> ~q + ~qbar; ~q -> ~q + S.
71947 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
71948 & ITYPES.EQ.3)) THEN
71949 ICLASS=6
71950 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.3.AND.(ITYPES.EQ.0.OR.
71951 & ITYPES.EQ.2)) THEN
71952 ICLASS=7
71953 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.4) THEN
71954 ICLASS=8
71955 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.4.AND.(ITYPES.EQ.0.OR.
71956 & ITYPES.EQ.2)) THEN
71957 ICLASS=9
71958
71959C...chi -> q + ~qbar; ~q -> q + chi; q -> ~q + chi.
71960 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.(ITYPES.EQ.0.OR.
71961 & ITYPES.EQ.5)) THEN
71962 ICLASS=10
71963 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
71964 & ITYPES.EQ.2)) THEN
71965 ICLASS=11
71966 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.5.AND.(ITYPES.EQ.0.OR.
71967 & ITYPES.EQ.1)) THEN
71968 ICLASS=12
71969
71970C...~g -> q + ~qbar; ~q -> q + ~g; q -> ~q + ~g.
71971 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.2.AND.ITYPES.EQ.6) THEN
71972 ICLASS=13
71973 ELSEIF(ITYPMN.EQ.1.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
71974 & ITYPES.EQ.2)) THEN
71975 ICLASS=14
71976 ELSEIF(ITYPMN.EQ.2.AND.ITYPMX.EQ.6.AND.(ITYPES.EQ.0.OR.
71977 & ITYPES.EQ.1)) THEN
71978 ICLASS=15
71979
71980C...g -> ~g + ~g (eikonal approximation).
71981 ELSEIF(ITYPMN.EQ.6.AND.ITYPMX.EQ.6.AND.ITYPES.EQ.0) THEN
71982 ICLASS=16
71983 ENDIF
71984 M3JC=5*ICLASS+ICOMBI
71985 ENDIF
71986
71987C...Store pair that together define matrix element treatment.
71988 IF(M3JC.NE.0) THEN
71989 NMESYS=1
71990 MESYS(NMESYS,0)=M3JC
71991 MESYS(NMESYS,1)=IPART(1)
71992 MESYS(NMESYS,2)=IPART(2)
71993 ENDIF
71994
71995C...Store qqbar or l+l- pairs for QED radiation.
71996 IF(KFLA1.LE.18.AND.KFLA2.LE.18) THEN
71997 NMESYS=NMESYS+1
71998 MESYS(NMESYS,0)=101
71999 IF(K(IPART(1),2)+K(IPART(2),2).EQ.0) MESYS(NMESYS,0)=102
72000 MESYS(NMESYS,1)=IPART(1)
72001 MESYS(NMESYS,2)=IPART(2)
72002 ENDIF
72003
72004C...Store other qqbar/l+l- pairs from g/gamma branchings.
72005 DO 290 I1=1,N
72006 IF(K(I1,1).GT.10.OR.IABS(K(I1,2)).GT.18) GOTO 290
72007 I1M=K(I1,3)
72008 260 IF(I1M.GT.0) THEN
72009 IF(K(I1M,2).EQ.K(I1,2)) THEN
72010 I1M=K(I1M,3)
72011 GOTO 260
72012 ENDIF
72013 ENDIF
72014C...Move up this check to avoid out-of-bounds.
72015 IF(I1M.EQ.0) GOTO 290
72016 IF(K(I1M,2).NE.21.AND.K(I1M,2).NE.22) GOTO 290
72017 DO 280 I2=I1+1,N
72018 IF(K(I2,1).GT.10.OR.K(I2,2)+K(I1,2).NE.0) GOTO 280
72019 I2M=K(I2,3)
72020 270 IF(I2M.GT.0) THEN
72021 IF(K(I2M,2).EQ.K(I2,2)) THEN
72022 I2M=K(I2M,3)
72023 GOTO 270
72024 ENDIF
72025 ENDIF
72026 IF(I1M.EQ.I2M.AND.I1M.GT.0) THEN
72027 NMESYS=NMESYS+1
72028 MESYS(NMESYS,0)=66
72029 MESYS(NMESYS,1)=I1
72030 MESYS(NMESYS,2)=I2
72031 NMESYS=NMESYS+1
72032 MESYS(NMESYS,0)=102
72033 MESYS(NMESYS,1)=I1
72034 MESYS(NMESYS,2)=I2
72035 ENDIF
72036 280 CONTINUE
72037 290 CONTINUE
72038 ENDIF
72039
72040C..Loopback point for counting number of emissions.
72041 NGEN=0
72042 300 NGEN=NGEN+1
72043
72044C...Begin loop to evolve all existing partons, if required.
72045 310 IMX=0
72046 PT2MX=0D0
72047 DO 380 IEVOL=1,NEVOL
72048 IF(IFLG(IEVOL).EQ.0) THEN
72049
72050C...Basic info on radiator and recoil.
72051 I=IPOS(IEVOL)
72052 IR=IREC(IEVOL)
72053 SHT=SHAT(I,IR)
72054 PM2I=P(I,5)**2
72055 PM2R=P(IR,5)**2
72056
72057C...Skip any particles that are "turned off"
72058 IF (MSTJ(39).GT.0.AND.IABS(K(I,2)).EQ.MSTJ(39)) GOTO 380
72059
72060C...Invariant mass of "dipole".Starting value for pT evolution.
72061 SHTCOR=(SQRT(SHT)-P(IR,5))**2-PM2I
72062 PT2=MIN(PT2CMX,0.25D0*SHTCOR,PTSCA(IEVOL)**2)
72063
72064C...Case of evolution by QCD branching.
72065 IF(ISCOL(IEVOL).NE.0) THEN
72066
72067C...Parton-by-parton maximum scale from initial conditions.
72068 IF(MSTP(72).EQ.0) THEN
72069 DO 320 IPRT=1,NPARTS
72070 IF(IR.EQ.IPART(IPRT)) PT2=MIN(PT2,PTPART(IPRT)**2)
72071 320 CONTINUE
72072 ENDIF
72073
72074C...If kinematically impossible then do not evolve.
72075 IF(PT2.LT.PT2CMN) THEN
72076 IFLG(IEVOL)=-1
72077 GOTO 380
72078 ENDIF
72079
72080C...Check if part of system for which ME corrections should be applied.
72081 IMESYS=0
72082 DO 330 IME=1,NMESYS
72083 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
72084 & MESYS(IME,0).LT.100) IMESYS=IME
72085 330 CONTINUE
72086
72087C...Special flag for colour octet states.
72088C...MOCT=1: can do gluon splitting g->qqbar; MOCT=2: cannot.
72089 MOCT=0
72090 KC = PYCOMP(K(I,2))
72091 IF(K(I,2).EQ.21) THEN
72092 MOCT=1
72093 ELSEIF(KCHG(KC,2).EQ.2) THEN
72094 MOCT=2
72095 ENDIF
72096C...QUARKONIA++
72097 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).EQ.9900101.AND.
72098 & IABS(K(I,2)).LE.9910555) MOCT=2
72099C...QUARKONIA--
72100
72101
72102C...Upper estimate for matrix element weighting and colour factor.
72103C...Note that g->gg and g->qqbar is split on two sides = "dipoles".
72104 WTPSGL=2D0
72105 COLFAC=4D0/3D0
72106 IF(MOCT.GE.1) COLFAC=3D0/2D0
72107 IF(IGLUI.EQ.1.AND.IMESYS.EQ.1.AND.MOCT.EQ.0) COLFAC=3D0
72108 WTPSQQ=0.5D0*0.5D0*NFLAV
72109
72110C...Determine overestimated z range: switch at c and b masses.
72111 340 IZRG=1
72112 PT2MNE=PT2CMN
72113 B0=27D0/6D0
72114 ALAMS=ALAM3S
72115 IF(PT2.GT.1.01D0*PMCS) THEN
72116 IZRG=2
72117 PT2MNE=PMCS
72118 B0=25D0/6D0
72119 ALAMS=ALAM4S
72120 ENDIF
72121 IF(PT2.GT.1.01D0*PMBS) THEN
72122 IZRG=3
72123 PT2MNE=PMBS
72124 B0=23D0/6D0
72125 ALAMS=ALAM5S
72126 ENDIF
72127 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2MNE/SHTCOR))
72128 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2MNE/SHTCOR
72129
72130C...Find evolution coefficients for q->qg/g->gg and g->qqbar.
72131 EVEMGL=WTPSGL*COLFAC*LOG(1D0/ZMNCUT-1D0)/B0
72132 EVCOEF=EVEMGL
72133 IF(MOCT.EQ.1) THEN
72134 EVEMQQ=WTPSQQ*(1D0-2D0*ZMNCUT)/B0
72135 EVCOEF=EVCOEF+EVEMQQ
72136 ENDIF
72137
72138C...Pick pT2 (in overestimated z range).
72139 350 PT2=ALAMS*(PT2/ALAMS)**(PYR(0)**(1D0/EVCOEF))
72140
72141C...Loopback if crossed c/b mass thresholds.
72142 IF(IZRG.EQ.3.AND.PT2.LT.PMBS) THEN
72143 PT2=PMBS
72144 GOTO 340
72145 ENDIF
72146 IF(IZRG.EQ.2.AND.PT2.LT.PMCS) THEN
72147 PT2=PMCS
72148 GOTO 340
72149 ENDIF
72150
72151C...Finish if below lower cutoff.
72152 IF(PT2.LT.PT2CMN) THEN
72153 IFLG(IEVOL)=-1
72154 GOTO 380
72155 ENDIF
72156
72157C...Pick kind of branching: q->qg/g->gg/X->Xg or g->qqbar.
72158C...IFLAG=1: gluon emission; IFLAG=2: gluon splitting
72159 IFLAG=1
72160 IF(MOCT.EQ.1.AND.EVEMGL.LT.PYR(0)*EVCOEF) IFLAG=2
72161
72162C...Pick z: dz/(1-z) or dz.
72163 IF(IFLAG.EQ.1) THEN
72164 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
72165 ELSE
72166 Z=ZMNCUT+PYR(0)*(1D0-2D0*ZMNCUT)
72167 ENDIF
72168
72169C...Loopback if outside allowed range for given pT2.
72170 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
72171 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
72172 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 350
72173 PM2=PM2I+PT2/(Z*(1D0-Z))
72174 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 350
72175
72176C...No weighting for primary partons; to be done later on.
72177 IF(IMESYS.GT.0) THEN
72178
72179C...Weighting of q->qg/X->Xg branching.
72180 ELSEIF(IFLAG.EQ.1.AND.MOCT.NE.1) THEN
72181 IF(1D0+Z**2.LT.WTPSGL*PYR(0)) GOTO 350
72182
72183C...Weighting of g->gg branching.
72184 ELSEIF(IFLAG.EQ.1) THEN
72185 IF(1D0+Z**3.LT.WTPSGL*PYR(0)) GOTO 350
72186
72187C...Flavour choice and weighting of g->qqbar branching.
72188 ELSE
72189 KFQ=MIN(5,1+INT(NFLAV*PYR(0)))
72190 PMQ=PMAS(KFQ,1)
72191 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
72192 WTME=ROOTQQ*(Z**2+(1D0-Z)**2)
72193 IF(WTME.LT.PYR(0)) GOTO 350
72194 IFLAG=10+KFQ
72195 ENDIF
72196
72197C...Case of evolution by QED branching.
72198 ELSEIF(ISCHG(IEVOL).NE.0) THEN
72199
72200C...If kinematically impossible then do not evolve.
72201 PT2EMN=PT0EQ**2
72202 IF(IABS(K(I,2)).GT.10) PT2EMN=PT0EL**2
72203 IF(PT2.LT.PT2EMN) THEN
72204 IFLG(IEVOL)=-1
72205 GOTO 380
72206 ENDIF
72207
72208C...Check if part of system for which ME corrections should be applied.
72209 IMESYS=0
72210 DO 360 IME=1,NMESYS
72211 IF((I.EQ.MESYS(IME,1).OR.I.EQ.MESYS(IME,2)).AND.
72212 & MESYS(IME,0).GT.100) IMESYS=IME
72213 360 CONTINUE
72214
72215C...Charge. Matrix element weighting factor.
72216 CHG=ISCHG(IEVOL)/3D0
72217 WTPSGA=2D0
72218
72219C...Determine overestimated z range. Find evolution coefficient.
72220 ZMNCUT=0.5D0-SQRT(MAX(0D0,0.25D0-PT2EMN/SHTCOR))
72221 IF(ZMNCUT.LT.1D-8) ZMNCUT=PT2EMN/SHTCOR
72222 EVCOEF=AEM2PI*CHG**2*WTPSGA*LOG(1D0/ZMNCUT-1D0)
72223
72224C...Pick pT2 (in overestimated z range).
72225 370 PT2=PT2*PYR(0)**(1D0/EVCOEF)
72226
72227C...Finish if below lower cutoff.
72228 IF(PT2.LT.PT2EMN) THEN
72229 IFLG(IEVOL)=-1
72230 GOTO 380
72231 ENDIF
72232
72233C...Pick z: dz/(1-z).
72234 Z=1D0-ZMNCUT*(1D0/ZMNCUT-1D0)**PYR(0)
72235
72236C...Loopback if outside allowed range for given pT2.
72237 ZMNNOW=0.5D0-SQRT(MAX(0D0,0.25D0-PT2/SHTCOR))
72238 IF(ZMNNOW.LT.1D-8) ZMNNOW=PT2/SHTCOR
72239 IF(Z.LE.ZMNNOW.OR.Z.GE.1D0-ZMNNOW) GOTO 370
72240 PM2=PM2I+PT2/(Z*(1D0-Z))
72241 IF(Z*(1D0-Z).LE.PM2*SHT/(SHT+PM2-PM2R)**2) GOTO 370
72242
72243C...Weighting by branching kernel, except if ME weighting later.
72244 IF(IMESYS.EQ.0) THEN
72245 IF(1D0+Z**2.LT.WTPSGA*PYR(0)) GOTO 370
72246 ENDIF
72247 IFLAG=3
72248 ENDIF
72249
72250C...Save acceptable branching.
72251 IFLG(IEVOL)=IFLAG
72252 IMESAV(IEVOL)=IMESYS
72253 PT2SAV(IEVOL)=PT2
72254 ZSAV(IEVOL)=Z
72255 SHTSAV(IEVOL)=SHT
72256 ENDIF
72257
72258C...Check if branching has highest pT.
72259 IF(IFLG(IEVOL).GE.1.AND.PT2SAV(IEVOL).GT.PT2MX) THEN
72260 IMX=IEVOL
72261 PT2MX=PT2SAV(IEVOL)
72262 ENDIF
72263 380 CONTINUE
72264
72265C...Finished if no more branchings to be done.
72266 IF(IMX.EQ.0) GOTO 520
72267
72268C...Restore info on hardest branching to be processed.
72269 I=IPOS(IMX)
72270 IR=IREC(IMX)
72271 KCOL=ISCOL(IMX)
72272 KCHA=ISCHG(IMX)
72273 IMESYS=IMESAV(IMX)
72274 PT2=PT2SAV(IMX)
72275 Z=ZSAV(IMX)
72276 SHT=SHTSAV(IMX)
72277 PM2I=P(I,5)**2
72278 PM2R=P(IR,5)**2
72279 PM2=PM2I+PT2/(Z*(1D0-Z))
72280
72281C...Special flag for colour octet states.
72282 MOCT=0
72283 KC = PYCOMP(K(I,2))
72284 IF(K(I,2).EQ.21) THEN
72285 MOCT=1
72286 ELSEIF(KCHG(KC,2).EQ.2) THEN
72287 MOCT=2
72288 ENDIF
72289C...QUARKONIA++
72290 IF(MSTP(148).GE.1.AND.IABS(K(I,2)).GE.9900101.AND.
72291 & IABS(K(I,2)).LE.9910555) MOCT=2
72292C...QUARKONIA--
72293
72294C...Restore further info for g->qqbar branching.
72295 KFQ=0
72296 IF(IFLG(IMX).GT.10) THEN
72297 KFQ=IFLG(IMX)-10
72298 PMQ=PMAS(KFQ,1)
72299 ROOTQQ=SQRT(MAX(0D0,1D0-4D0*PMQ**2/PM2))
72300 ENDIF
72301
72302C...For branching g include azimuthal asymmetries from polarization.
72303 ASYPOL=0D0
72304 IF(MOCT.EQ.1.AND.MOD(MSTJ(46),2).EQ.1) THEN
72305C...Trace grandmother via intermediate recoil copies.
72306 KFGM=0
72307 IM=I
72308 390 IF(K(IM,3).NE.K(IM-1,3).AND.K(IM,3).NE.K(IM+1,3).AND.
72309 & K(IM,3).GT.0) THEN
72310 IM=K(IM,3)
72311 IF(IM.GT.MINT(84)) GOTO 390
72312 ENDIF
72313 IGM=K(IM,3)
72314 IF(IGM.GT.MINT(84).AND.IGM.LT.IM.AND.IM.LE.I)
72315 & KFGM=IABS(K(IGM,2))
72316C...Define approximate energy sharing by identifying aunt.
72317 IAU=IM+1
72318 IF(IAU.GT.N-3.OR.K(IAU,3).NE.IGM) IAU=IM-1
72319 IF(KFGM.NE.0.AND.(KFGM.LE.6.OR.KFGM.EQ.21)) THEN
72320 ZOLD=P(IM,4)/(P(IM,4)+P(IAU,4))
72321C...Coefficient from gluon production.
72322 IF(KFGM.LE.6) THEN
72323 ASYPOL=2D0*(1D0-ZOLD)/(1D0+(1D0-ZOLD)**2)
72324 ELSE
72325 ASYPOL=((1D0-ZOLD)/(1D0-ZOLD*(1D0-ZOLD)))**2
72326 ENDIF
72327C...Coefficient from gluon decay.
72328 IF(KFQ.EQ.0) THEN
72329 ASYPOL=ASYPOL*(Z*(1D0-Z)/(1D0-Z*(1D0-Z)))**2
72330 ELSE
72331 ASYPOL=-ASYPOL*2D0*Z*(1D0-Z)/(1D0-2D0*Z*(1D0-Z))
72332 ENDIF
72333 ENDIF
72334 ENDIF
72335
72336C...Create new slots for branching products and recoil.
72337 INEW=N+1
72338 IGNEW=N+2
72339 IRNEW=N+3
72340 N=N+3
72341
72342C...Set status, flavour and mother of new ones.
72343 K(INEW,1)=K(I,1)
72344 K(IGNEW,1)=3
72345 IF(KCHA.NE.0) K(IGNEW,1)=1
72346 K(IRNEW,1)=K(IR,1)
72347 IF(KFQ.EQ.0) THEN
72348 K(INEW,2)=K(I,2)
72349 K(IGNEW,2)=21
72350 IF(KCHA.NE.0) K(IGNEW,2)=22
72351 ELSE
72352 K(INEW,2)=-ISIGN(KFQ,KCOL)
72353 K(IGNEW,2)=-K(INEW,2)
72354 ENDIF
72355 K(IRNEW,2)=K(IR,2)
72356 K(INEW,3)=I
72357 K(IGNEW,3)=I
72358 K(IRNEW,3)=IR
72359
72360C...Find rest frame and angles of branching+recoil.
72361 DO 400 J=1,5
72362 P(INEW,J)=P(I,J)
72363 P(IGNEW,J)=0D0
72364 P(IRNEW,J)=P(IR,J)
72365 400 CONTINUE
72366 BETAX=(P(INEW,1)+P(IRNEW,1))/(P(INEW,4)+P(IRNEW,4))
72367 BETAY=(P(INEW,2)+P(IRNEW,2))/(P(INEW,4)+P(IRNEW,4))
72368 BETAZ=(P(INEW,3)+P(IRNEW,3))/(P(INEW,4)+P(IRNEW,4))
72369 CALL PYROBO(INEW,IRNEW,0D0,0D0,-BETAX,-BETAY,-BETAZ)
72370 PHI=PYANGL(P(INEW,1),P(INEW,2))
72371 THETA=PYANGL(P(INEW,3),SQRT(P(INEW,1)**2+P(INEW,2)**2))
72372
72373C...Derive kinematics of branching: generics (like g->gg).
72374 DO 410 J=1,4
72375 P(INEW,J)=0D0
72376 P(IRNEW,J)=0D0
72377 410 CONTINUE
72378 PEM=0.5D0*(SHT+PM2-PM2R)/SQRT(SHT)
72379 PZM=0.5D0*SQRT(MAX(0D0,(SHT-PM2-PM2R)**2-4D0*PM2*PM2R)/SHT)
72380 PT2COR=PM2*(PEM**2*Z*(1D0-Z)-0.25D0*PM2)/PZM**2
72381 PTCOR=SQRT(MAX(0D0,PT2COR))
72382 PZN=(PEM**2*Z-0.5D0*PM2)/PZM
72383 PZG=(PEM**2*(1D0-Z)-0.5D0*PM2)/PZM
72384C...Specific kinematics reduction for q->qg with m_q > 0.
72385 IF(MOCT.NE.1) THEN
72386 PTCOR=(1D0-PM2I/PM2)*PTCOR
72387 PZN=PZN+PM2I*PZG/PM2
72388 PZG=(1D0-PM2I/PM2)*PZG
72389C...Specific kinematics reduction for g->qqbar with m_q > 0.
72390 ELSEIF(KFQ.NE.0) THEN
72391 P(INEW,5)=PMQ
72392 P(IGNEW,5)=PMQ
72393 PTCOR=ROOTQQ*PTCOR
72394 PZN=0.5D0*((1D0+ROOTQQ)*PZN+(1D0-ROOTQQ)*PZG)
72395 PZG=PZM-PZN
72396 ENDIF
72397
72398C...Pick phi and construct kinematics of branching.
72399 420 PHIROT=PARU(2)*PYR(0)
72400 P(INEW,1)=PTCOR*COS(PHIROT)
72401 P(INEW,2)=PTCOR*SIN(PHIROT)
72402 P(INEW,3)=PZN
72403 P(INEW,4)=SQRT(PTCOR**2+P(INEW,3)**2+P(INEW,5)**2)
72404 P(IGNEW,1)=-P(INEW,1)
72405 P(IGNEW,2)=-P(INEW,2)
72406 P(IGNEW,3)=PZG
72407 P(IGNEW,4)=SQRT(PTCOR**2+P(IGNEW,3)**2+P(IGNEW,5)**2)
72408 P(IRNEW,1)=0D0
72409 P(IRNEW,2)=0D0
72410 P(IRNEW,3)=-PZM
72411 P(IRNEW,4)=0.5D0*(SHT+PM2R-PM2)/SQRT(SHT)
72412
72413C...Boost branching system to lab frame.
72414 CALL PYROBO(INEW,IRNEW,THETA,PHI,BETAX,BETAY,BETAZ)
72415
72416C...Renew choice of phi angle according to polarization asymmetry.
72417 IF(ABS(ASYPOL).GT.1D-3) THEN
72418 DO 430 J=1,3
72419 DPT(1,J)=P(I,J)
72420 DPT(2,J)=P(IAU,J)
72421 DPT(3,J)=P(INEW,J)
72422 430 CONTINUE
72423 DPMA=DPT(1,1)*DPT(2,1)+DPT(1,2)*DPT(2,2)+DPT(1,3)*DPT(2,3)
72424 DPMD=DPT(1,1)*DPT(3,1)+DPT(1,2)*DPT(3,2)+DPT(1,3)*DPT(3,3)
72425 DPMM=DPT(1,1)**2+DPT(1,2)**2+DPT(1,3)**2
72426 DO 440 J=1,3
72427 DPT(4,J)=DPT(2,J)-DPMA*DPT(1,J)/MAX(1D-10,DPMM)
72428 DPT(5,J)=DPT(3,J)-DPMD*DPT(1,J)/MAX(1D-10,DPMM)
72429 440 CONTINUE
72430 DPT(4,4)=SQRT(DPT(4,1)**2+DPT(4,2)**2+DPT(4,3)**2)
72431 DPT(5,4)=SQRT(DPT(5,1)**2+DPT(5,2)**2+DPT(5,3)**2)
72432 IF(MIN(DPT(4,4),DPT(5,4)).GT.0.1D0*PARJ(82)) THEN
72433 CAD=(DPT(4,1)*DPT(5,1)+DPT(4,2)*DPT(5,2)+
72434 & DPT(4,3)*DPT(5,3))/(DPT(4,4)*DPT(5,4))
72435 IF(1D0+ASYPOL*(2D0*CAD**2-1D0).LT.PYR(0)*(1D0+ABS(ASYPOL)))
72436 & GOTO 420
72437 ENDIF
72438 ENDIF
72439
72440C...Matrix element corrections for primary partons when requested.
72441 IF(IMESYS.GT.0) THEN
72442 M3JC=MESYS(IMESYS,0)
72443
72444C...Identify recoiling partner and set up three-body kinematics.
72445 IRP=MESYS(IMESYS,1)
72446 IF(IRP.EQ.I) IRP=MESYS(IMESYS,2)
72447 IF(IRP.EQ.IR) IRP=IRNEW
72448 DO 450 J=1,4
72449 PSUM(J)=P(INEW,J)+P(IRP,J)+P(IGNEW,J)
72450 450 CONTINUE
72451 PSUM(5)=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
72452 & PSUM(3)**2))
72453 X1=2D0*(PSUM(4)*P(INEW,4)-PSUM(1)*P(INEW,1)-PSUM(2)*P(INEW,2)-
72454 & PSUM(3)*P(INEW,3))/PSUM(5)**2
72455 X2=2D0*(PSUM(4)*P(IRP,4)-PSUM(1)*P(IRP,1)-PSUM(2)*P(IRP,2)-
72456 & PSUM(3)*P(IRP,3))/PSUM(5)**2
72457 X3=2D0-X1-X2
72458 R1ME=P(INEW,5)/PSUM(5)
72459 R2ME=P(IRP,5)/PSUM(5)
72460
72461C...Matrix elements for gluon emission.
72462 IF(M3JC.LT.100) THEN
72463
72464C...Call ME, with right order important for two inequivalent showerers.
72465 IF(MESYS(IMESYS,IORD).EQ.I) THEN
72466 WME=PYMAEL(M3JC,X1,X2,R1ME,R2ME,ALPHA)
72467 ELSE
72468 WME=PYMAEL(M3JC,X2,X1,R2ME,R1ME,ALPHA)
72469 ENDIF
72470
72471C...Split up total ME when two radiating partons.
72472 ISPRAD=1
72473 IF((M3JC.GE.16.AND.M3JC.LE.19).OR.(M3JC.GE.26.AND.M3JC.LE.29)
72474 & .OR.(M3JC.GE.36.AND.M3JC.LE.39).OR.(M3JC.GE.46.AND.M3JC.LE.49)
72475 & .OR.(M3JC.GE.56.AND.M3JC.LE.64)) ISPRAD=0
72476 IF(ISPRAD.EQ.1) WME=WME*MAX(1D-10,1D0+R1ME**2-R2ME**2-X1)/
72477 & MAX(1D-10,2D0-X1-X2)
72478
72479C...Evaluate shower rate.
72480 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
72481 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
72482 IF(IGLUI.EQ.1) WPS=(9D0/4D0)*WPS
72483
72484C...Matrix elements for photon emission: still rather primitive.
72485 ELSE
72486
72487C...For generic charge combination currently only massless expression.
72488 IF(M3JC.EQ.101) THEN
72489 CHG1=KCHG(PYCOMP(K(I,2)),1)*ISIGN(1,K(I,2))/3D0
72490 CHG2=KCHG(PYCOMP(K(IRP,2)),1)*ISIGN(1,K(IRP,2))/3D0
72491 WME=(CHG1*(1D0-X1)/X3-CHG2*(1D0-X2)/X3)**2*(X1**2+X2**2)
72492 WPS=2D0*(CHG1**2*(1D0-X1)/X3+CHG2**2*(1D0-X2)/X3)
72493
72494C...For flavour neutral system assume vector source and include masses.
72495 ELSE
72496 WME=PYMAEL(11,X1,X2,R1ME,R2ME,0D0)*MAX(1D-10,
72497 & 1D0+R1ME**2-R2ME**2-X1)/MAX(1D-10,2D0-X1-X2)
72498 WPS=2D0/(MAX(1D-10,2D0-X1-X2)*
72499 & MAX(1D-10,1D0+R2ME**2-R1ME**2-X2))
72500 ENDIF
72501 ENDIF
72502
72503C...Perform weighting with W_ME/W_PS.
72504 IF(WME.LT.PYR(0)*WPS) THEN
72505 N=N-3
72506 IFLG(IMX)=0
72507 PT2CMX=PT2
72508 GOTO 310
72509 ENDIF
72510 ENDIF
72511
72512C...Now for sure accepted branching. Save highest pT.
72513 IF(NGEN.EQ.1) PTGEN=SQRT(PT2)
72514
72515C...Update status for obsolete ones. Bookkkep the moved original parton
72516C...and new daughter (arbitrary choice for g->gg or g->qqbar).
72517C...Do not bookkeep radiated photon, since it cannot radiate further.
72518 K(I,1)=K(I,1)+10
72519 K(IR,1)=K(IR,1)+10
72520 DO 460 IP=1,NPART
72521 IF(IPART(IP).EQ.I) IPART(IP)=INEW
72522 IF(IPART(IP).EQ.IR) IPART(IP)=IRNEW
72523 460 CONTINUE
72524 IF(KCHA.EQ.0) THEN
72525 NPART=NPART+1
72526 IPART(NPART)=IGNEW
72527 ENDIF
72528
72529C...Initialize colour flow of branching.
72530C...Use both old and new style colour tags for flexibility.
72531 K(INEW,4)=0
72532 K(IGNEW,4)=0
72533 K(INEW,5)=0
72534 K(IGNEW,5)=0
72535 JCOLP=4+(1-KCOL)/2
72536 JCOLN=9-JCOLP
72537 MCT(INEW,1)=0
72538 MCT(INEW,2)=0
72539 MCT(IGNEW,1)=0
72540 MCT(IGNEW,2)=0
72541 MCT(IRNEW,1)=0
72542 MCT(IRNEW,2)=0
72543
72544C...Trivial colour flow for l->lgamma and q->qgamma.
72545 IF(IABS(KCHA).EQ.3) THEN
72546 K(I,4)=INEW
72547 K(I,5)=IGNEW
72548 ELSEIF(KCHA.NE.0) THEN
72549 IF(K(I,4).NE.0) THEN
72550 K(I,4)=K(I,4)+INEW
72551 K(INEW,4)=MSTU(5)*I
72552 MCT(INEW,1)=MCT(I,1)
72553 ENDIF
72554 IF(K(I,5).NE.0) THEN
72555 K(I,5)=K(I,5)+INEW
72556 K(INEW,5)=MSTU(5)*I
72557 MCT(INEW,2)=MCT(I,2)
72558 ENDIF
72559
72560C...Set colour flow for q->qg and g->gg.
72561 ELSEIF(KFQ.EQ.0) THEN
72562 K(I,JCOLP)=K(I,JCOLP)+IGNEW
72563 K(IGNEW,JCOLP)=MSTU(5)*I
72564 K(INEW,JCOLP)=MSTU(5)*IGNEW
72565 K(IGNEW,JCOLN)=MSTU(5)*INEW
72566 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
72567 NCT=NCT+1
72568 MCT(INEW,JCOLP-3)=NCT
72569 MCT(IGNEW,JCOLN-3)=NCT
72570 IF(MOCT.GE.1) THEN
72571 K(I,JCOLN)=K(I,JCOLN)+INEW
72572 K(INEW,JCOLN)=MSTU(5)*I
72573 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
72574 ENDIF
72575
72576C...Set colour flow for g->qqbar.
72577 ELSE
72578 K(I,JCOLN)=K(I,JCOLN)+INEW
72579 K(INEW,JCOLN)=MSTU(5)*I
72580 K(I,JCOLP)=K(I,JCOLP)+IGNEW
72581 K(IGNEW,JCOLP)=MSTU(5)*I
72582 MCT(INEW,JCOLN-3)=MCT(I,JCOLN-3)
72583 MCT(IGNEW,JCOLP-3)=MCT(I,JCOLP-3)
72584 ENDIF
72585
72586C...Daughter info for colourless recoiling parton.
72587 IF(K(IR,4).EQ.0.AND.K(IR,5).EQ.0) THEN
72588 K(IR,4)=IRNEW
72589 K(IR,5)=IRNEW
72590 K(IRNEW,4)=0
72591 K(IRNEW,5)=0
72592
72593C...Colour of recoiling parton sails through unchanged.
72594 ELSE
72595 IF(K(IR,4).NE.0) THEN
72596 K(IR,4)=K(IR,4)+IRNEW
72597 K(IRNEW,4)=MSTU(5)*IR
72598 MCT(IRNEW,1)=MCT(IR,1)
72599 ENDIF
72600 IF(K(IR,5).NE.0) THEN
72601 K(IR,5)=K(IR,5)+IRNEW
72602 K(IRNEW,5)=MSTU(5)*IR
72603 MCT(IRNEW,2)=MCT(IR,2)
72604 ENDIF
72605 ENDIF
72606
72607C...Vertex information trivial.
72608 DO 470 J=1,5
72609 V(INEW,J)=V(I,J)
72610 V(IGNEW,J)=V(I,J)
72611 V(IRNEW,J)=V(IR,J)
72612 470 CONTINUE
72613
72614C...Update list of old radiators.
72615 DO 480 IEVOL=1,NEVOL
72616C... A) radiator-recoiler mother pair for this branching
72617 IF(IPOS(IEVOL).EQ.I.AND.IREC(IEVOL).EQ.IR) THEN
72618 IPOS(IEVOL)=INEW
72619C... A2) QCD branching and color side matches, radiated parton follows recoiler
72620 IF(KCOL.NE.0.AND.ISCOL(IEVOL).EQ.KCOL) IPOS(IEVOL)=IGNEW
72621 IREC(IEVOL)=IRNEW
72622 IFLG(IEVOL)=0
72623 ELSEIF(IPOS(IEVOL).EQ.I) THEN
72624C... B) other dipoles with I as radiator simply get INEW as new radiator
72625 IPOS(IEVOL)=INEW
72626 IFLG(IEVOL)=0
72627 ELSEIF(IPOS(IEVOL).EQ.IR.AND.IREC(IEVOL).EQ.I) THEN
72628C... C) the "mirror image" of the parent dipole
72629 IPOS(IEVOL)=IRNEW
72630 IREC(IEVOL)=INEW
72631C... C2) QCD branching and color side matches, radiated parton follows recoiler
72632 IF(KCOL.NE.0.AND.ISCOL(IEVOL).NE.KCOL.AND.ISCOL(IEVOL).NE.0)
72633 & IREC(IEVOL)=IGNEW
72634 IFLG(IEVOL)=0
72635 ELSEIF(IPOS(IEVOL).EQ.IR) THEN
72636C... D) other dipoles with IR as radiator simply get IRNEW as new radiator
72637 IPOS(IEVOL)=IRNEW
72638 IFLG(IEVOL)=0
72639 ENDIF
72640C... Update links of old connected partons.
72641 IF(IREC(IEVOL).EQ.I) THEN
72642 IREC(IEVOL)=INEW
72643 IFLG(IEVOL)=0
72644 ELSEIF(IREC(IEVOL).EQ.IR) THEN
72645 IREC(IEVOL)=IRNEW
72646 IFLG(IEVOL)=0
72647 ENDIF
72648 480 CONTINUE
72649
72650C...q->qg or g->gg: create new gluon radiators.
72651 IF(KCOL.NE.0.AND.KFQ.EQ.0) THEN
72652 NEVOL=NEVOL+1
72653 IPOS(NEVOL)=INEW
72654 IREC(NEVOL)=IGNEW
72655 IFLG(NEVOL)=0
72656 ISCOL(NEVOL)=KCOL
72657 ISCHG(NEVOL)=0
72658 PTSCA(NEVOL)=SQRT(PT2)
72659 NEVOL=NEVOL+1
72660 IPOS(NEVOL)=IGNEW
72661 IREC(NEVOL)=INEW
72662 IFLG(NEVOL)=0
72663 ISCOL(NEVOL)=-KCOL
72664 ISCHG(NEVOL)=0
72665 PTSCA(NEVOL)=PTSCA(NEVOL-1)
72666C...g->qqbar: create new photon radiators.
72667 ELSEIF(KCOL.EQ.2.AND.KFQ.NE.0) THEN
72668 NEVOL=NEVOL+1
72669 IPOS(NEVOL)=INEW
72670 IREC(NEVOL)=IGNEW
72671 IFLG(NEVOL)=0
72672 ISCOL(NEVOL)=0
72673 ISCHG(NEVOL)=PYK(INEW,6)
72674 PTSCA(NEVOL)=SQRT(PT2)
72675 NEVOL=NEVOL+1
72676 IPOS(NEVOL)=IGNEW
72677 IREC(NEVOL)=INEW
72678 IFLG(NEVOL)=0
72679 ISCOL(NEVOL)=0
72680 ISCHG(NEVOL)=PYK(IGNEW,6)
72681 PTSCA(NEVOL)=SQRT(PT2)
72682 CALL PYLIST(4)
72683 print*, 'created new QED dipole ',INEW,'<->',IGNEW
72684 ENDIF
72685
72686C...Check color and charge connections,
72687C...Rewire if better partners can be found (screening, etc)
72688 DO 500 IEVOL=1,NEVOL
72689 KCOL = ISCOL(IEVOL)
72690 KCHA = ISCHG(IEVOL)
72691 IRTMP = IREC(IEVOL)
72692 ITMP = IPOS(IEVOL)
72693C...Do not modify QED dipoles
72694 IF (KCHA.NE.0) THEN
72695 GOTO 500
72696C...Also skip dipole ends that are switched off
72697 ELSEIF (IFLG(IEVOL).LE.-1) THEN
72698 GOTO 500
72699 ELSEIF (KCOL.NE.0) THEN
72700C...QCD dipoles. Check if current recoiler has appropriate color charge
72701 KCOLR = PYK(IRTMP,12)
72702 IF (KCOLR.EQ.2.OR.KCOLR.EQ.-KCOL) GOTO 500
72703C...If not, look for closest recoiler with appropriate color charge
72704 RM2MIN = PSUM(5)**2
72705 JMX = 0
72706 ISGOOD = 0
72707 DO 490 JEVOL=1,NEVOL
72708C...Skip self
72709 IF (JEVOL.EQ.IEVOL) GOTO 490
72710 JTMP = IPOS(JEVOL)
72711 IF (JTMP.EQ.ITMP) GOTO 490
72712 JCOL = ISCOL(JEVOL)
72713C...Skip dipole ends that are switched off
72714 IF (IFLG(JEVOL).LE.-1) GOTO 490
72715C...Skip QED dipole ends
72716 IF (ISCHG(JEVOL).NE.0) GOTO 490
72717C... Skip wrong-color if at least one correct-color partner already found
72718 IF (ISGOOD.NE.0.AND.JCOL.NE.-KCOL.AND.JCOL.NE.2) GOTO 490
72719C...Accept if smallest m2 so far, or if first with correct color
72720 RM2 = DOTP(ITMP,JTMP)
72721 ISGNOW = 0
72722 IF (JCOL.EQ.-KCOL.OR.JCOL.EQ.2) ISGNOW=1
72723 IF (RM2.LT.RM2MIN.OR.ISGNOW.GT.ISGOOD) THEN
72724 ISGOOD = ISGNOW
72725 RM2MIN = RM2
72726 JMX = JEVOL
72727 ENDIF
72728 490 CONTINUE
72729C...Update recoiler and reset dipole if new best partner found
72730 IF (JMX.NE.0) THEN
72731 IREC(IEVOL) = IPOS(JMX)
72732 IFLG(IEVOL) = 0
72733 ENDIF
72734 ENDIF
72735 500 CONTINUE
72736
72737C...TMP! print out list of dipoles
72738C DO 580 IEVOL=1,NEVOL
72739C KCHA = ISCHG(IEVOL)
72740C IF (KCHA.NE.0) THEN
72741C print*, 'qed dip',IPOS(IEVOL),IREC(IEVOL)
72742C ELSE
72743C print*, 'qcd dip',IPOS(IEVOL),IREC(IEVOL)
72744C ENDIF
72745C 580 CONTINUE
72746
72747C...Update matrix elements parton list and add new for g/gamma->qqbar.
72748 DO 510 IME=1,NMESYS
72749 IF(MESYS(IME,1).EQ.I) MESYS(IME,1)=INEW
72750 IF(MESYS(IME,2).EQ.I) MESYS(IME,2)=INEW
72751 IF(MESYS(IME,1).EQ.IR) MESYS(IME,1)=IRNEW
72752 IF(MESYS(IME,2).EQ.IR) MESYS(IME,2)=IRNEW
72753 510 CONTINUE
72754 IF(KFQ.NE.0) THEN
72755 NMESYS=NMESYS+1
72756 MESYS(NMESYS,0)=66
72757 MESYS(NMESYS,1)=INEW
72758 MESYS(NMESYS,2)=IGNEW
72759 NMESYS=NMESYS+1
72760 MESYS(NMESYS,0)=102
72761 MESYS(NMESYS,1)=INEW
72762 MESYS(NMESYS,2)=IGNEW
72763 ENDIF
72764
72765C...Global statistics.
72766 MINT(353)=MINT(353)+1
72767 VINT(353)=VINT(353)+PTCOR
72768 IF (MINT(353).EQ.1) VINT(358)=PTCOR
72769
72770C...Loopback for more emissions if enough space.
72771 PT2CMX=PT2
72772 IF(NPART.LT.MAXNUR-1.AND.NEVOL.LT.2*MAXNUR-2.AND.
72773 &NMESYS.LT.MAXNUR-2.AND.N.LT.MSTU(4)-MSTU(32)-5) THEN
72774 GOTO 300
72775 ELSE
72776 CALL PYERRM(11,'(PYPTFS:) no more memory left for shower')
72777 ENDIF
72778
72779C...Done.
72780 520 CONTINUE
72781
72782 RETURN
72783 END
72784
72785C*********************************************************************
72786
72787C...PYMAEL
72788C...Auxiliary to PYSHOW and PYPTFS.
72789C...Matrix elements for gluon (or photon) emission from
72790C...a two-body state; to be used by the parton shower routine.
72791C...Here X_i = 2 E_i/E_cm, R_i = m_i/E_cm and
72792C...1/sigma_0 d(sigma)/d(x_1)d(x_2) =
72793C... = (alpha-strong/2 pi) * CF * PYMAEL,
72794C...i.e. normalization is such that one recovers the familiar
72795C...(X1**2+X2**2)/((1-X1)*(1-X2)) for the massless case.
72796C...Coupling structure:
72797C...NI = 6- 9 : eikonal soft-gluon expression (spin-independent)
72798C... = 11-14 : V -> q qbar (V = vector/axial vector colour singlet)
72799C... = 16-19 : q -> q V
72800C... = 21-24 : S -> q qbar (S = scalar/pseudoscalar colour singlet)
72801C... = 26-29 : q -> q S
72802C... = 31-34 : V -> ~q ~qbar (~q = squark)
72803C... = 36-39 : ~q -> ~q V
72804C... = 41-44 : S -> ~q ~qbar
72805C... = 46-49 : ~q -> ~q S
72806C... = 51-54 : chi -> q ~qbar (chi = neutralino/chargino)
72807C... = 56-59 : ~q -> q chi
72808C... = 61-64 : q -> ~q chi
72809C... = 66-69 : ~g -> q ~qbar
72810C... = 71-74 : ~q -> q ~g
72811C... = 76-79 : q -> ~q ~g
72812C... = 81-84 : (9/4)*(eikonal) for gg -> ~g ~g
72813C...Note that the order of the decay products is important.
72814C...In each set of four, the variants are ordered as:
72815C...ICOMBI = 1 : pure non-gamma5, i.e. vector/scalar/...
72816C... = 2 : pure gamma5, i.e. axial vector/pseudoscalar/....
72817C... = 3 : mixture alpha*(ICOMBI=1) + (1-alpha)*(ICOMBI=2)
72818C... = 4 : mixture (ICOMBI=1) +- (ICOMBI=2)
72819
72820 FUNCTION PYMAEL(NI,X1,X2,R1,R2,ALPHA)
72821
72822C...Double precision and integer declarations.
72823 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
72824 IMPLICIT INTEGER(I-N)
72825
72826C...Check input values. Return zero outside allowed phase space.
72827 PYMAEL=0D0
72828 IF(X1.LE.2D0*R1.OR.X1.GE.1D0+R1**2-R2**2) RETURN
72829 IF(X2.LE.2D0*R2.OR.X2.GE.1D0+R2**2-R1**2) RETURN
72830 IF(X1+X2.LE.1D0+(R1+R2)**2) RETURN
72831 IF((2D0-2D0*X1-2D0*X2+X1*X2+2D0*R1**2+2D0*R2**2)**2.GE.
72832 &(X1**2-4D0*R1**2)*(X2**2-4D0*R2**2)) RETURN
72833 ALPCOR=MAX(0D0,MIN(1D0,ALPHA))
72834
72835C...Initial values and flags.
72836 ICLASS=NI/5
72837 ICOMBI=NI-5*ICLASS
72838 ISSET1=0
72839 ISSET2=0
72840 ISSET4=0
72841
72842C... Phase space.
72843 PS=SQRT((1D0-(R1+R2)**2)*(1D0-(R1-R2)**2))
72844
72845C...Eikonal expression; also acts as default.
72846 IF(ICLASS.LE.1.OR.ICLASS.GE.17.OR.ICOMBI.EQ.0) THEN
72847 RLO=PS
72848 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
72849 ANUM=0D0
72850 ELSEIF(ICOMBI.EQ.2) THEN
72851 ANUM=(2D0-X1-X2)**2
72852 ELSEIF(ICOMBI.EQ.3) THEN
72853 ANUM=ALPCOR*(2D0-X1-X2)**2
72854 ELSE
72855 ANUM=0.5D0*(2D0-X1-X2)**2
72856 ENDIF
72857 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
72858 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
72859 & R1**2/(1D0+R2**2-R1**2-X2)**2-
72860 & R2**2/(1D0+R1**2-R2**2-X1)**2)
72861 ICOMBI=0
72862
72863C...V -> q qbar (V = gamma*/Z0/W+-/...).
72864 ELSEIF(ICLASS.EQ.2) THEN
72865 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
72866 RLO1=PS*(2-R1**2-R1**4+6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
72867 RFO1=-1.D0*(3+6*R1**2+R1**4-6*R1*R2+6*R1**3*R2-2*R2**2
72868 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-3*X1+6*R1*R2*X1
72869 & +2*R2**2*X1+X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)
72870 & +6*R1*R2*(2-X1-X2)-R2**2*(2-X1-X2)-2*X1*(2-X1-X2)
72871 & -5*R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
72872 & -3*(2-X1-X2)**2-3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2
72873 & +2*X1*(2-X1-X2)**2+(2-X1-X2)**3-X2)/
72874 & (-1+R1**2-R2**2+X2)**2
72875 RFO1=RFO1-2*(-3+R1**2-6*R1*R2+6*R1**3*R2+3*R2**2-4*R1**2*R2**2
72876 & +6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
72877 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)+3*R1*R2*(2-X1
72878 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
72879 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2+R1*R2*(2
72880 & -X1-X2)**2+X1*(2-X1-X2)**2)/
72881 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
72882 RFO1=RFO1-1.D0*(-1+2*R1**2+R1**4+6*R1*R2+6*R1**3*R2-2*R2**2
72883 & -6*R1**2*R2**2+6*R1*R2**3+R2**4-X1-2*R1**2*X1-6*R1*R2*X1
72884 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2
72885 & -X1-X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*
72886 & (2-X1-X2)+X2)/(-1-R1**2+R2**2+X1)**2
72887 RFO1=RFO1/2.D0
72888 ISSET1=1
72889 ENDIF
72890 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
72891 RLO2=PS*(2-R1**2-R1**4-6*R1*R2-R2**2+2*R1**2*R2**2-R2**4)/2.D0
72892 RFO2=-1*(3+6*R1**2+R1**4+6*R1*R2-6*R1**3*R2-2*R2**2
72893 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-3*X1-6*R1*R2*X1+2*R2**2*X1
72894 & +X1**2-2*R1**2*X1**2+3*R1**2*(2-X1-X2)-6*R1*R2*(2-X1-X2)
72895 & -R2**2*(2-X1-X2)-2*X1*(2-X1-X2)-5*R1**2*X1*(2-X1-X2)
72896 & +R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)-3*(2-X1-X2)**2
72897 & -3*R1**2*(2-X1-X2)**2+R2**2*(2-X1-X2)**2+2*X1*(2-X1-X2)**2
72898 & +(2-X1-X2)**3-X2)/(-1+R1**2-R2**2+X2)**2
72899 RFO2=RFO2-2*(-3+R1**2+6*R1*R2-6*R1**3*R2+3*R2**2-4*R1**2*R2**2
72900 & -6*R1*R2**3+2*X1+3*R1**2*X1+R2**2*X1-X1**2-R1**2*X1**2
72901 & -R2**2*X1**2+4*(2-X1-X2)+2*R1**2*(2-X1-X2)-3*R1*R2*(2-X1
72902 & -X2)-R2**2*(2-X1-X2)-3*X1*(2-X1-X2)-2*R1**2*X1*(2-X1-X2)
72903 & +X1**2*(2-X1-X2)-(2-X1-X2)**2-R1**2*(2-X1-X2)**2-R1*R2*(2
72904 & -X1-X2)**2+X1*(2-X1-X2)**2)/
72905 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
72906 RFO2=RFO2-1*(-1+2*R1**2+R1**4-6*R1*R2-6*R1**3*R2-2*R2**2
72907 & -6*R1**2*R2**2-6*R1*R2**3+R2**4-X1-2*R1**2*X1+6*R1*R2*X1
72908 & +8*R2**2*X1+X1**2-2*R2**2*X1**2-R1**2*(2-X1-X2)+R2**2*(2-X1
72909 & -X2)-R1**2*X1*(2-X1-X2)+R2**2*X1*(2-X1-X2)+X1**2*(2-X1-X2)
72910 & +X2)/(-1-R1**2+R2**2+X1)**2
72911 RFO2=RFO2/2.D0
72912 ISSET2=1
72913 ENDIF
72914 IF(ICOMBI.EQ.4) THEN
72915 RLO4=PS*(2D0-R1**2-R1**4-R2**2+2D0*R1**2*R2**2-R2**4)/2D0
72916 RFO4=(1-R1**4+6*R1**2*R2**2-R2**4+X1+3*R1**2*X1-9*R2**2*X1
72917 & -3*X1**2-R1**2*X1**2+3*R2**2*X1**2+X1**3-X2-R1**2*X2
72918 & +R2**2*X2-R1**2*X1*X2+R2**2*X1*X2+X1**2*X2)/
72919 & (-1-R1**2+R2**2+X1)**2
72920 RFO4=RFO4
72921 & -2*(1+R1**2+R2**2-4*R1**2*R2**2+R1**2*X1+2*R2**2*X1-X1**2
72922 & -R2**2*X1**2+2*R1**2*X2+R2**2*X2-3*X1*X2+X1**2*X2-X2**2
72923 & -R1**2*X2**2+X1*X2**2)/
72924 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
72925 RFO4=RFO4+(1-R1**4+6*R1**2*R2**2-R2**4-X1+R1**2*X1-R2**2*X1+X2
72926 & -9*R1**2*X2+3*R2**2*X2+R1**2*X1*X2-R2**2*X1*X2-3*X2**2
72927 & +3*R1**2*X2**2-R2**2*X2**2+X1*X2**2+X2**3)/
72928 & (-1+R1**2-R2**2+X2)**2
72929 RFO4=RFO4/2.D0
72930 ISSET4=1
72931 ENDIF
72932
72933C...q -> q V.
72934 ELSEIF(ICLASS.EQ.3) THEN
72935 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
72936 RLO1=PS*(1D0-2D0*R1**2+R1**4+R2**2-6D0*R1*R2**2
72937 & +R1**2*R2**2-2D0*R2**4)
72938 RFO1=2*(-1+R1-2*R1**2+2*R1**3-R1**4+R1**5-R2**2+R1*R2**2
72939 & -5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4+2*X1-2*R1*X1
72940 & +2*R1**2*X1-2*R1**3*X1+2*R2**2*X1+5*R1*R2**2*X1
72941 & +R1**2*R2**2*X1+2*R2**4*X1-X1**2+R1*X1**2-R2**2*X1**2+3*X2
72942 & +4*R1**2*X2+R1**4*X2+2*R2**2*X2+2*R1**2*R2**2*X2-4*X1*X2
72943 & -2*R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-2*X2**2
72944 & -2*R1**2*X2**2+X1*X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
72945 RFO1=RFO1+(2*R2**2+6*R1*R2**2-6*R1**2*R2**2+6*R1**3*R2**2
72946 & +2*R2**4+6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
72947 & -R1**4*X2-3*R2**2*X2-6*R1*R2**2*X2+9*R1**2*R2**2*X2
72948 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
72949 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
72950 RFO1=RFO1+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4
72951 & +9*X1+10*R1**2*X1+R1**4*X1-3*R2**2*X1+6*R1*R2**2*X1
72952 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
72953 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2+6*R1*R2**2*X2
72954 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
72955 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2
72956 & +2*R2**2*X2**2+X1*X2**2)/(-2+X1+X2)**2
72957 ISSET1=1
72958 ENDIF
72959 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
72960 RLO2=PS*(1D0-2D0*R1**2+R1**4+R2**2+6D0*R1*R2**2
72961 & +R1**2*R2**2-2D0*R2**4)
72962 RFO2=2*(1+R1+2*R1**2+2*R1**3+R1**4+R1**5+R2**2+R1*R2**2
72963 & +5*R1**2*R2**2+R1**3*R2**2-2*R1*R2**4-2*X1-2*R1*X1
72964 & -2*R1**2*X1-2*R1**3*X1-2*R2**2*X1+5*R1*R2**2*X1
72965 & -R1**2*R2**2*X1-2*R2**4*X1+X1**2+R1*X1**2+R2**2*X1**2-3*X2
72966 & -4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2+4*X1*X2
72967 & +2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2+2*R1**2*X2**2
72968 & -X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
72969 RFO2=RFO2+(2*R2**2-6*R1*R2**2-6*R1**2*R2**2-6*R1**3*R2**2
72970 & +2*R2**4-6*R1*R2**4-R2**2*X1+R1**2*R2**2*X1-R2**4*X1+X2
72971 & -R1**4*X2-3*R2**2*X2+6*R1*R2**2*X2+9*R1**2*R2**2*X2
72972 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
72973 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
72974 RFO2=RFO2+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
72975 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1-6*R1*R2**2*X1
72976 & +R1**2*R2**2*X1-2*R2**4*X1-6*X1**2-2*R1**2*X1**2+X1**3
72977 & +7*X2+8*R1**2*X2+R1**4*X2-7*R2**2*X2-6*R1*R2**2*X2
72978 & +R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
72979 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
72980 & +X1*X2**2)/(-2+X1+X2)**2
72981 ISSET2=1
72982 ENDIF
72983 IF(ICOMBI.EQ.4) THEN
72984 RLO4=PS*(1.D0-2.D0*R1**2+R1**4+R2**2+R1**2*R2**2-2.D0*R2**4)
72985 RFO4=2*(1+2*R1**2+R1**4+R2**2+5*R1**2*R2**2-2*X1-2*R1**2*X1
72986 & -2*R2**2*X1-R1**2*R2**2*X1-2*R2**4*X1+X1**2+R2**2*X1**2
72987 & -3*X2-4*R1**2*X2-R1**4*X2-2*R2**2*X2-2*R1**2*R2**2*X2
72988 & +4*X1*X2+2*R1**2*X1*X2+R2**2*X1*X2-X1**2*X2+2*X2**2
72989 & +2*R1**2*X2**2-X1*X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
72990 RFO4=RFO4+(2*R2**2-6*R1**2*R2**2+2*R2**4-R2**2*X1+R1**2*R2**2*X1
72991 & -R2**4*X1+X2-R1**4*X2-3*R2**2*X2+9*R1**2*R2**2*X2
72992 & -2*R2**4*X2-X1*X2+R1**2*X1*X2-X2**2-3*R1**2*X2**2
72993 & +2*R2**2*X2**2+X1*X2**2)/(-1+R1**2-R2**2+X2)**2
72994 RFO4=RFO4+(-4-8*R1**2-4*R1**4+4*R2**2-4*R1**2*R2**2+8*R2**4+9*X1
72995 & +10*R1**2*X1+R1**4*X1-3*R2**2*X1+R1**2*R2**2*X1-2*R2**4*X1
72996 & -6*X1**2-2*R1**2*X1**2+X1**3+7*X2+8*R1**2*X2+R1**4*X2
72997 & -7*R2**2*X2+R1**2*R2**2*X2-2*R2**4*X2-9*X1*X2-3*R1**2*X1*X2
72998 & +2*R2**2*X1*X2+2*X1**2*X2-3*X2**2-R1**2*X2**2+2*R2**2*X2**2
72999 & +X1*X2**2)/(2-X1-X2)**2
73000 ISSET4=1
73001 ENDIF
73002
73003C...S -> q qbar (S = h0/H0/A0/H+-/...).
73004 ELSEIF(ICLASS.EQ.4) THEN
73005 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73006 RLO1=PS*(1D0-R1**2-R2**2-2D0*R1*R2)
73007 RFO1=-(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73008 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
73009 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
73010 & -2*(R1**2+R1**4-2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3
73011 & +R2**4-R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2
73012 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73013 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73014 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
73015 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73016 ISSET1=1
73017 ENDIF
73018 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73019 RLO2=PS*(1D0-R1**2-R2**2+2D0*R1*R2)
73020 RFO2=-(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
73021 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
73022 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
73023 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
73024 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
73025 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73026 & +2*(-R1**2-R1**4-2*R1**3*R2-R2**2+6*R1**2*R2**2
73027 & -2*R1*R2**3-R2**4+R1**2*X1+R1*R2*X1-2*R2**2*X1
73028 & -2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
73029 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73030 ISSET2=1
73031 ENDIF
73032 IF(ICOMBI.EQ.4) THEN
73033 RLO4=PS*(1D0-R1**2-R2**2)
73034 RFO4=-(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
73035 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
73036 & -2*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
73037 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
73038 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73039 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1
73040 & +X2+3*R1**2*X2-R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73041 ISSET4=1
73042 ENDIF
73043
73044C...q -> q S.
73045 ELSEIF(ICLASS.EQ.5) THEN
73046 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73047 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
73048 RFO1=(4-4*R1**2+4*R2**2-3*X1-2*R1*X1+R1**2*X1-R2**2*X1-5*X2
73049 & -2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
73050 & +2*(3-R1-5*R1**2-R1**3+3*R2**2+R1*R2**2-2*X1-R1*X1
73051 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73052 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
73053 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
73054 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73055 & (-1+R1**2-R2**2+X2)**2
73056 ISSET1=1
73057 ENDIF
73058 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73059 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
73060 RFO2=(4-4*R1**2+4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2
73061 & +2*R1*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
73062 & +2*(3+R1-5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1
73063 & +R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73064 & (1-R1**2+R2**2-X2)/(-2+X1+X2)
73065 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
73066 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73067 & (-1+R1**2-R2**2+X2)**2
73068 ISSET2=1
73069 ENDIF
73070 IF(ICOMBI.EQ.4) THEN
73071 RLO4=PS*(1D0+R1**2-R2**2)
73072 RFO4=(4-4*R1**2+4*R2**2-3*X1+R1**2*X1-R2**2*X1-5*X2+R1**2*X2
73073 & -R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2
73074 & +2*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2+2*R1**2*X2
73075 & -R2**2*X2+X1*X2+X2**2)/(1-R1**2+R2**2-X2)/(-2+X1+X2)
73076 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
73077 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
73078 ISSET4=1
73079 ENDIF
73080
73081C...V -> ~q ~qbar (~q = squark).
73082 ELSEIF(ICLASS.EQ.6) THEN
73083 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
73084 RFO1=2D0*3D0+(1+R1**2+R2**2-X1)*(4*R1**2-X1**2)/
73085 & (-1-R1**2+R2**2+X1)**2
73086 & -2D0*(-1-3*R1**2-R2**2+X1+X1**2/2+X2-X1*X2/2)/
73087 & (-1-R1**2+R2**2+X1)
73088 & +(1+R1**2+R2**2-X2)*(4*R2**2-X2**2)
73089 & /(-1+R1**2-R2**2+X2)**2
73090 & -2D0*(-1-R1**2-3*R2**2+X1+X2-X1*X2/2+X2**2/2)/
73091 & (-1+R1**2-R2**2+X2)
73092 & -(-4*R1**2-4*R1**4-4*R2**2-8*R1**2*R2**2-4*R2**4+2*X1
73093 & +6*R1**2*X1+6*R2**2*X1-2*X1**2+2*X2+6*R1**2*X2+6*R2**2*X2
73094 & -4*X1*X2-2*R1**2*X1*X2-2*R2**2*X1*X2+X1**2*X2-2*X2**2
73095 & +X1*X2**2)/(-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73096 ISSET1=1
73097
73098C...~q -> ~q V.
73099 ELSEIF(ICLASS.EQ.7) THEN
73100 RLO1=PS*(1D0-2D0*R1**2+R1**4-2D0*R2**2-2D0*R1**2*R2**2+R2**4)
73101 RFO1=16*R2**2+8*(4*R2**2+2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2
73102 & -2*X2**2)/(3*(-1+R1**2-R2**2+X2))+8*(1+R1**2+R2**2-X2)*
73103 & (4*R2**2-X2**2)/(3*(-1+R1**2-R2**2+X2)**2)+8*(X1+X2)*
73104 & (-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
73105 & +2*R1**2*X1+2*R2**2*X1-X1**2+2*X2+2*R1**2*X2+2*R2**2*X2
73106 & -2*X1*X2-X2**2)/(3*(-2+X1+X2)**2)+8*(-1-R1**2+R2**2-X1)*
73107 & (2*R2**2*X1+X2+R1**2*X2+R2**2*X2-X1*X2-X2**2)/
73108 & (3*(-1+R1**2-R2**2+X2)*(-2+X1+X2))+8*(1+2*R1**2+R1**4
73109 & +2*R2**2-2*R1**2*R2**2+R2**4-2*X1-2*R1**2*X1-4*R2**2*X1
73110 & +X1**2-3*X2-3*R1**2*X2-3*R2**2*X2+3*X1*X2+2*X2**2)/
73111 & (3*(-2+X1+X2))
73112 RFO1=3D0*RFO1/8D0
73113 ISSET1=1
73114
73115C...S -> ~q ~qbar.
73116 ELSEIF(ICLASS.EQ.8) THEN
73117 RLO1=PS
73118 RFO1=(-1-2*R1**2-R1**4-2*R2**2+2*R1**2*R2**2-R2**4+2*X1
73119 & +2*R1**2*X1+2*R2**2*X1-X1**2-R2**2*X1**2+2*X2+2*R1**2*X2
73120 & +2*R2**2*X2-3*X1*X2-R1**2*X1*X2-R2**2*X1*X2+X1**2*X2-X2**2
73121 & -R1**2*X2**2+X1*X2**2)/
73122 & (1+R1**2-R2**2-X1)**2/(-1+R1**2-R2**2+X2)**2
73123 RFO1=2D0*RFO1
73124 ISSET1=1
73125
73126C...~q -> ~q S.
73127 ELSEIF(ICLASS.EQ.9) THEN
73128 RLO1=PS
73129 RFO1=(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
73130 & +(1+R1**2-R2**2+X1)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
73131 & -(X1+X2)/(-2+X1+X2)**2
73132 ISSET1=1
73133
73134C...chi -> q ~qbar (chi = neutralino/chargino).
73135 ELSEIF(ICLASS.EQ.10) THEN
73136 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73137 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
73138 RFO1=(2*R1+X1)*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
73139 & +2*(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1
73140 & -R1**2*X1/2-R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
73141 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73142 & +(2-2*R1-6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1
73143 & -R2**2*X1-3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73144 & (-1+R1**2-R2**2+X2)**2
73145 ISSET1=1
73146 ENDIF
73147 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73148 RLO2=PS*(1D0-2D0*R1+R1**2-R2**2)
73149 RFO2=(2*R1-X1)*(1+R1**2+R2**2-X1)/(-1-R1**2+R2**2+X1)**2
73150 & +2*(-1-R1**2+2*R1**3-R2**2+2*R1*R2**2+3*X1/2-R1*X1
73151 & -R1**2*X1/2-R2**2*X1/2+X2-R1*X2+R1**2*X2-X1*X2/2)/
73152 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73153 & +(2+2*R1-6*R1**2+2*R1**3+2*R2**2+2*R1*R2**2-X1+R1**2*X1
73154 & -R2**2*X1-3*X2-2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73155 & (-1+R1**2-R2**2+X2)**2
73156 ISSET2=1
73157 ENDIF
73158 IF(ICOMBI.EQ.4) THEN
73159 RLO4=PS*(1+R1**2-R2**2)
73160 RFO4=X1*(-1-R1**2-R2**2+X1)/(-1-R1**2+R2**2+X1)**2
73161 & +2D0*(-1-R1**2-R2**2+3*X1/2-R1**2*X1/2-R2**2*X1/2
73162 & +X2+R1**2*X2-X1*X2/2)/
73163 & (-1-R1**2+R2**2+X1)/(-1+R1**2-R2**2+X2)
73164 & +(2-6*R1**2+2*R2**2-X1+R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2
73165 & -R2**2*X2+X1*X2+X2**2)/(-1+R1**2-R2**2+X2)**2
73166 ISSET4=1
73167 ENDIF
73168
73169C...~q -> q chi.
73170 ELSEIF(ICLASS.EQ.11) THEN
73171 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73172 RLO1=PS*(1D0-(R1+R2)**2)
73173 RFO1=(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
73174 & -(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73175 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
73176 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73177 & +(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
73178 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
73179 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
73180 ISSET1=1
73181 ENDIF
73182 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73183 RLO2=PS*(1D0-(R1-R2)**2)
73184 RFO2=(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/
73185 & (-2+X1+X2)**2
73186 & -(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
73187 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2
73188 & -R2**2*X2-X1*X2)/(-1+R1**2-R2**2+X2)**2
73189 & +(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3+R2**4
73190 & +X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
73191 & +X1*X2+X2**2)/(-1+R1**2-R2**2+X2)/(-2+X1+X2)
73192 ISSET2=1
73193 ENDIF
73194 IF(ICOMBI.EQ.4) THEN
73195 RLO4=PS*(1D0-R1**2-R2**2)
73196 RFO4=(1+R1**2+R2**2-X1-X2)*(X1+X2)/(-2+X1+X2)**2
73197 & -(-1+R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2
73198 & +3*R1**2*X2-R2**2*X2-X1*X2)/
73199 & (-1+R1**2-R2**2+X2)**2
73200 & -(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
73201 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
73202 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
73203 ISSET4=1
73204 ENDIF
73205
73206C...q -> ~q chi.
73207 ELSEIF(ICLASS.EQ.12) THEN
73208 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73209 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
73210 RFO1=(2*R2+X2)*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
73211 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1-2*R2*X1+R2**2*X1+X1**2
73212 & -3*X2-R1**2*X2-2*R2*X2+R2**2*X2+X1*X2)/
73213 & (-2+X1+X2)**2-2*(-1-R1**2+R2+R1**2*R2-R2**2-R2**3+X1
73214 & +R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
73215 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
73216 ISSET1=1
73217 END IF
73218 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73219 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
73220 RFO2=(2*R2-X2)*(1+R1**2+R2**2-X2)/(-1+R1**2-R2**2+X2)**2
73221 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1+X1**2
73222 & -3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
73223 & (-2+X1+X2)**2-2*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
73224 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
73225 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
73226 ISSET2=1
73227 END IF
73228 IF(ICOMBI.EQ.4) THEN
73229 RLO4=PS*(1D0-R1**2+R2**2)
73230 RFO4=X2*(-1-R1**2-R2**2+X2)/(-1+R1**2-R2**2+X2)**2
73231 & +(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2
73232 & -3*X2-R1**2*X2+R2**2*X2+X1*X2)/
73233 & (-2+X1+X2)**2-2*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2
73234 & +R1**2*X2-X1*X2/2-X2**2/2)/
73235 & (2-X1-X2)/(-1+R1**2-R2**2+X2)
73236 ISSET4=1
73237 END IF
73238
73239C...~g -> q ~qbar.
73240 ELSEIF(ICLASS.EQ.13) THEN
73241 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73242 RLO1=PS*(1D0+R1**2-R2**2+2D0*R1)
73243 RFO1=4*(2*R1+X1)*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)
73244 & -(-1-R1**2-2*R1**3-R2**2-2*R1*R2**2+3*X1/2+R1*X1-R1**2*X1/2
73245 & -R2**2*X1/2+X2+R1*X2+R1**2*X2-X1*X2/2)/(3*(-1-R1**2+R2**2
73246 & +X1)*(-1+R1**2-R2**2+X2))-3*(-1+R1-R1**2-R1**3-R2**2
73247 & +R1*R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1*X2+R1**2*X2-X1*X2/2)/
73248 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+3*(4-4*R1**2+4*R2**2-3*X1
73249 & -2*R1*X1+R1**2*X1-R2**2*X1-5*X2-2*R1*X2+R1**2*X2-R2**2*X2
73250 & +X1*X2+X2**2)/(-2+X1+X2)**2+3*(3-R1-5*R1**2-R1**3+3*R2**2
73251 & +R1*R2**2-2*X1-R1*X1+R1**2*X1-4*X2+2*R1**2*X2-R2**2*X2
73252 & +X1*X2+X2**2)/((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2-2*R1
73253 & -6*R1**2-2*R1**3+2*R2**2-2*R1*R2**2-X1+R1**2*X1-R2**2*X1
73254 & -3*X2+2*R1*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73255 & (3*(-1+R1**2-R2**2+X2)**2)
73256 RFO1=3D0*RFO1/4D0
73257 ISSET1=1
73258 ENDIF
73259 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73260 RLO2=PS*(1D0+R1**2-R2**2-2D0*R1)
73261 RFO2=4*(2*R1-X1)*(1+R1**2+R2**2-X1)/(3*(-1-R1**2+R2**2+X1)**2)
73262 & -3*(-1-R1-R1**2+R1**3-R2**2-R1*R2**2+2*X1+R2**2*X1-X1**2/2
73263 & +X2-R1*X2+R1**2*X2-X1*X2/2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
73264 & +(2+2*R1**2-4*R1**3+2*R2**2-4*R1*R2**2-3*X1+2*R1*X1
73265 & +R1**2*X1+R2**2*X1-2*X2+2*R1*X2-2*R1**2*X2+X1*X2)/
73266 & (6*(-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+3*(4-4*R1**2
73267 & +4*R2**2-3*X1+2*R1*X1+R1**2*X1-R2**2*X1-5*X2+2*R1*X2
73268 & +R1**2*X2-R2**2*X2+X1*X2+X2**2)/(-2+X1+X2)**2+3*(3+R1
73269 & -5*R1**2+R1**3+3*R2**2-R1*R2**2-2*X1+R1*X1+R1**2*X1-4*X2
73270 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73271 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+4*(2+2*R1-6*R1**2+2*R1**3
73272 & +2*R2**2+2*R1*R2**2-X1+R1**2*X1-R2**2*X1-3*X2-2*R1*X2
73273 & +3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73274 & (3*(-1+R1**2-R2**2+X2)**2)
73275 RFO2=3D0*RFO2/4D0
73276 ISSET2=1
73277 ENDIF
73278 IF(ICOMBI.EQ.4) THEN
73279 RLO4=PS*(1D0+R1**2-R2**2)
73280 RFO4=8*X1*(-1-R1**2-R2**2+X1)/(3*(-1-R1**2+R2**2+X1)**2)-6*(-1
73281 & -R1**2-R2**2+2*X1+R2**2*X1-X1**2/2+X2+R1**2*X2-X1*X2/2)/
73282 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+(2+2*R1**2+2*R2**2-3*X1
73283 & +R1**2*X1+R2**2*X1-2*X2-2*R1**2*X2+X1*X2)/(3*(-1-R1**2
73284 & +R2**2+X1)*(-1+R1**2-R2**2+X2))+6*(4-4*R1**2+4*R2**2-3*X1
73285 & +R1**2*X1-R2**2*X1-5*X2+R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73286 & (-2+X1+X2)**2+6*(3-5*R1**2+3*R2**2-2*X1+R1**2*X1-4*X2
73287 & +2*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73288 & ((1-R1**2+R2**2-X2)*(-2+X1+X2))+8*(2-6*R1**2+2*R2**2-X1
73289 & +R1**2*X1-R2**2*X1-3*X2+3*R1**2*X2-R2**2*X2+X1*X2+X2**2)/
73290 & (3*(-1+R1**2-R2**2+X2)**2)
73291 RFO4=3D0*RFO4/8D0
73292 ISSET4=1
73293 ENDIF
73294
73295C...~q -> q ~g.
73296 ELSEIF(ICLASS.EQ.14) THEN
73297 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73298 RLO1=PS*(1-R1**2-R2**2-2D0*R1*R2)
73299 RFO1=64*(1+R1**2+2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
73300 & -16*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73301 & +R2**4+X1-R1**2*X1+2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
73302 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-16*(R1**2+R1**4
73303 & -2*R1**3*R2+R2**2-6*R1**2*R2**2-2*R1*R2**3+R2**4
73304 & -R1**2*X1+R1*R2*X1+2*R2**2*X1+2*R1**2*X2+R1*R2*X2-R2**2*X2
73305 & -X1*X2)/((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
73306 & -64*(-1+R1**4-2*R1*R2-2*R1**3*R2-6*R1**2*R2**2-2*R1*R2**3
73307 & +R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2+2*R1*R2*X2
73308 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
73309 & +8*(-1+R1**4-2*R1*R2+2*R1**3*R2-2*R2**2-2*R1*R2**3-R2**4
73310 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2-2*R1*R2*X2
73311 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
73312 RFO1=RFO1
73313 & +8*(-1-2*R1**2-R1**4-2*R1*R2-2*R1**3*R2+2*R1*R2**3+R2**4
73314 & +X1+R1**2*X1-2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2-2*R2**2*X2
73315 & +X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
73316 RFO1=9D0*RFO1/64D0
73317 ISSET1=1
73318 ENDIF
73319 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73320 RLO2=PS*(1-R1**2-R2**2+2D0*R1*R2)
73321 RFO2=64*(1+R1**2-2*R1*R2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)
73322 & -16*(-1+R1**4+2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3
73323 & +R2**4+X1-R1**2*X1-2*R1*R2*X1+3*R2**2*X1+X2+R1**2*X2
73324 & -R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2-64*(-1+R1**4
73325 & +2*R1*R2+2*R1**3*R2-6*R1**2*R2**2+2*R1*R2**3+R2**4+X1
73326 & -R1**2*X1+R2**2*X1+X2+3*R1**2*X2-2*R1*R2*X2-R2**2*X2
73327 & -X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)+16*(-R1**2-R1**4
73328 & -2*R1**3*R2-R2**2+6*R1**2*R2**2-2*R1*R2**3-R2**4+R1**2*X1
73329 & +R1*R2*X1-2*R2**2*X1-2*R1**2*X2+R1*R2*X2+R2**2*X2+X1*X2)/
73330 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))
73331 RFO2=RFO2
73332 & +8*(-1+R1**4+2*R1*R2-2*R1**3*R2-2*R2**2+2*R1*R2**3-R2**4
73333 & -2*R1**2*X1+2*R2**2*X1+X1**2+X2-3*R1**2*X2+2*R1*R2*X2
73334 & +R2**2*X2+X1*X2)/((-1-R1**2+R2**2+X1)*(-2+X1+X2))
73335 & +8*(-1-2*R1**2-R1**4+2*R1*R2+2*R1**3*R2-2*R1*R2**3
73336 & +R2**4+X1+R1**2*X1+2*R1*R2*X1-3*R2**2*X1+2*R1**2*X2
73337 & -2*R2**2*X2+X1*X2+X2**2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
73338 RFO2=9D0*RFO2/64D0
73339 ISSET2=1
73340 ENDIF
73341 IF(ICOMBI.EQ.4) THEN
73342 RLO4=PS*(1-R1**2-R2**2)
73343 RFO4=128*(1+R1**2+R2**2-X1-X2)*(X1+X2)/(9*(-2+X1+X2)**2)-32*(-1
73344 & +R1**4-6*R1**2*R2**2+R2**4+X1-R1**2*X1+3*R2**2*X1+X2
73345 & +R1**2*X2-R2**2*X2-X1*X2)/(-1-R1**2+R2**2+X1)**2
73346 & -32*(R1**2+R1**4+R2**2-6*R1**2*R2**2+R2**4-R1**2*X1
73347 & +2*R2**2*X1+2*R1**2*X2-R2**2*X2-X1*X2)/
73348 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))-128*(-1+R1**4
73349 & -6*R1**2*R2**2+R2**4+X1-R1**2*X1+R2**2*X1+X2+3*R1**2*X2
73350 & -R2**2*X2-X1*X2)/(9*(-1+R1**2-R2**2+X2)**2)
73351 & +16*(-1+R1**4-2*R2**2-R2**4-2*R1**2*X1+2*R2**2*X1+X1**2
73352 & +X2-3*R1**2*X2+R2**2*X2+X1*X2)/
73353 & ((-1-R1**2+R2**2+X1)*(-2+X1+ X2))
73354 RFO4=RFO4+16*(-1-2*R1**2-R1**4+R2**4+X1+R1**2*X1-3*R2**2*X1
73355 & +2*R1**2*X2-2*R2**2*X2+X1*X2+X2**2)/
73356 & (9*(1-R1**2+R2**2-X2)*(-2+X1+X2))
73357 RFO4=9D0*RFO4/128D0
73358 ISSET4=1
73359 ENDIF
73360
73361C...q -> ~q ~g.
73362 ELSEIF(ICLASS.EQ.15) THEN
73363 IF(ICOMBI.EQ.1.OR.ICOMBI.EQ.3) THEN
73364 RLO1=PS*(1D0-R1**2+R2**2+2D0*R2)
73365 RFO1=32*(2*R2+X2)*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
73366 & +8*(-1-R1**2-2*R1**2*R2-R2**2-2*R2**3+X1+R2*X1+R2**2*X1
73367 & +3*X2/2-R1**2*X2/2+R2*X2-R2**2*X2/2-X1*X2/2)/
73368 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2-2*R2
73369 & -2*R1**2*R2-6*R2**2-2*R2**3-3*X1-R1**2*X1+2*R2*X1
73370 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
73371 & (-1-R1**2+R2**2+X1)**2+32*(4+4*R1**2-4*R2**2-5*X1
73372 & -R1**2*X1-2*R2*X1+R2**2*X1+X1**2-3*X2-R1**2*X2-2*R2*X2
73373 & +R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
73374 RFO1=RFO1+8*(3+3*R1**2-R2+R1**2*R2-5*R2**2-R2**3-4*X1-R1**2*X1
73375 & +2*R2**2*X1+X1**2-2*X2-R2*X2+R2**2*X2+X1*X2)/
73376 & ((-1-R1**2+R2**2+X1)*(2-X1-X2))+8*(-1-R1**2+R2+R1**2*R2
73377 & -R2**2-R2**3+X1+R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
73378 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
73379 RFO1=9D0*RFO1/32D0
73380 ISSET1=1
73381 END IF
73382 IF(ICOMBI.EQ.2.OR.ICOMBI.EQ.3) THEN
73383 RLO2=PS*(1D0-R1**2+R2**2-2D0*R2)
73384 RFO2=32*(2*R2-X2)*(1+R1**2+R2**2-X2)/(9*(-1+R1**2-R2**2+X2)**2)
73385 & +8*(-1-R1**2+2*R1**2*R2-R2**2+2*R2**3+X1-R2*X1+R2**2*X1
73386 & +3*X2/2-R1**2*X2/2-R2*X2-R2**2*X2/2-X1*X2/2)/
73387 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+8*(2+2*R1**2+2*R2
73388 & +2*R1**2*R2-6*R2**2+2*R2**3-3*X1-R1**2*X1-2*R2*X1
73389 & +3*R2**2*X1+X1**2-X2-R1**2*X2+R2**2*X2+X1*X2)/
73390 & (-1-R1**2+R2**2+X1)**2+8*(3+3*R1**2+R2-R1**2*R2-5*R2**2
73391 & +R2**3-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2*X2+R2**2*X2
73392 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
73393 RFO2=RFO2+32*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+2*R2*X1+R2**2*X1
73394 & +X1**2-3*X2-R1**2*X2+2*R2*X2+R2**2*X2+X1*X2)/
73395 & (9*(-2+X1+X2)**2)+8*(-1-R1**2-R2-R1**2*R2-R2**2+R2**3+X1
73396 & -R2*X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2-X2**2/2)/
73397 & (9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
73398 RFO2=9D0*RFO2/32D0
73399 ISSET2=1
73400 END IF
73401 IF(ICOMBI.EQ.4) THEN
73402 RLO4=PS*(1D0-R1**2+R2**2)
73403 RFO4=64*X2*(-1-R1**2-R2**2+X2)/(9*(-1+R1**2-R2**2+X2)**2)
73404 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+3*X2/2-R1**2*X2/2
73405 & -R2**2*X2/2-X1*X2/2)/
73406 & ((-1-R1**2+R2**2+X1)*(-1+R1**2-R2**2+X2))+16*(3+3*R1**2
73407 & -5*R2**2-4*X1-R1**2*X1+2*R2**2*X1+X1**2-2*X2+R2**2*X2
73408 & +X1*X2)/((-1-R1**2+R2**2+X1)*(2-X1-X2))
73409 & +64*(4+4*R1**2-4*R2**2-5*X1-R1**2*X1+R2**2*X1+X1**2-3*X2
73410 & -R1**2*X2+R2**2*X2+X1*X2)/(9*(-2+X1+X2)**2)
73411 RFO4=RFO4+16*(2+2*R1**2-6*R2**2-3*X1-R1**2*X1+3*R2**2*X1+X1**2
73412 & -X2-R1**2*X2+R2**2*X2+X1*X2)/(-1-R1**2+R2**2+X1)**2
73413 & +16*(-1-R1**2-R2**2+X1+R2**2*X1+2*X2+R1**2*X2-X1*X2/2
73414 & -X2**2/2)/(9*(2-X1-X2)*(-1+R1**2-R2**2+X2))
73415 RFO4=9D0*RFO4/64D0
73416 ISSET4=1
73417 END IF
73418
73419C...g -> ~g ~g. Use (9/4)*eikonal. May be changed in the future.
73420 ELSEIF(ICLASS.EQ.16) THEN
73421 RLO=PS
73422 IF(ICOMBI.EQ.0.OR.ICOMBI.EQ.1) THEN
73423 ANUM=0D0
73424 ELSEIF(ICOMBI.EQ.2) THEN
73425 ANUM=(2D0-X1-X2)**2
73426 ELSEIF(ICOMBI.EQ.3) THEN
73427 ANUM=ALPCOR*(2D0-X1-X2)**2
73428 ELSE
73429 ANUM=0.5D0*(2D0-X1-X2)**2
73430 ENDIF
73431 RFO=PS*2D0*((X1+X2-1D0+ANUM-R1**2-R2**2)/
73432 & ((1D0+R1**2-R2**2-X1)*(1D0+R2**2-R1**2-X2))-
73433 & R1**2/(1D0+R2**2-R1**2-X2)**2-
73434 & R2**2/(1D0+R1**2-R2**2-X1)**2)
73435 RFO=9D0*RFO/4D0
73436 ICOMBI=0
73437 ENDIF
73438
73439C...Find relevant LO and FO expression.
73440 IF(ICOMBI.EQ.0) THEN
73441 ELSEIF(ICOMBI.EQ.1.AND.ISSET1.EQ.1) THEN
73442 RLO=RLO1
73443 RFO=RFO1
73444 ELSEIF(ICOMBI.EQ.2.AND.ISSET2.EQ.1) THEN
73445 RLO=RLO2
73446 RFO=RFO2
73447 ELSEIF(ICOMBI.EQ.3.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
73448 RLO=ALPCOR*RLO1+(1D0-ALPCOR)*RLO2
73449 RFO=ALPCOR*RFO1+(1D0-ALPCOR)*RFO2
73450 ELSEIF(ISSET4.EQ.1) THEN
73451 RLO=RLO4
73452 RFO=RFO4
73453 ELSEIF(ICOMBI.EQ.4.AND.ISSET1.EQ.1.AND.ISSET2.EQ.1) THEN
73454 RLO=0.5D0*(RLO1+RLO2)
73455 RFO=0.5D0*(RFO1+RFO2)
73456 ELSEIF(ISSET1.EQ.1) THEN
73457 RLO=RLO1
73458 RFO=RFO1
73459 ELSE
73460 CALL PYERRM(16,'(PYMAEL:) not implemented ME code')
73461 RLO=1D0
73462 RFO=0D0
73463 ENDIF
73464
73465C...Output.
73466 PYMAEL=RFO/RLO
73467
73468 RETURN
73469 END
73470
73471C*********************************************************************
73472
73473C...PYBOEI
73474C...Modifies an event so as to approximately take into account
73475C...Bose-Einstein effects according to a simple phenomenological
73476C...parametrization.
73477
73478 SUBROUTINE PYBOEI(NSAV)
73479
73480C...Double precision and integer declarations.
73481 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73482 IMPLICIT INTEGER(I-N)
73483 INTEGER PYK,PYCHGE,PYCOMP
73484C...Parameter statement to help give large particle numbers.
73485 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
73486 &KEXCIT=4000000,KDIMEN=5000000)
73487C...Commonblocks.
73488 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73489 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73490 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
73491 COMMON/PYINT1/MINT(400),VINT(400)
73492 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYINT1/
73493C...Local arrays and data.
73494 DIMENSION DPS(4),KFBE(9),NBE(0:10),BEI(100),BEI3(100),
73495 &BEIW(100),BEI3W(100)
73496 DATA KFBE/211,-211,111,321,-321,130,310,221,331/
73497C...Statement function: squared invariant mass.
73498 SDIP(I,J)=((P(I,4)+P(J,4))**2-(P(I,3)+P(J,3))**2-
73499 &(P(I,2)+P(J,2))**2-(P(I,1)+P(J,1))**2)
73500
73501C...Boost event to overall CM frame. Calculate CM energy.
73502 IF((MSTJ(51).NE.1.AND.MSTJ(51).NE.2).OR.N-NSAV.LE.1) RETURN
73503 DO 100 J=1,4
73504 DPS(J)=0D0
73505 100 CONTINUE
73506 DO 120 I=1,N
73507 KFA=IABS(K(I,2))
73508 IF(K(I,1).LE.10.AND.((KFA.GT.10.AND.KFA.LE.20).OR.KFA.EQ.22)
73509 & .AND.K(I,3).GT.0) THEN
73510 KFMA=IABS(K(K(I,3),2))
73511 IF(KFMA.GT.10.AND.KFMA.LE.80) K(I,1)=-K(I,1)
73512 ENDIF
73513 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 120
73514 DO 110 J=1,4
73515 DPS(J)=DPS(J)+P(I,J)
73516 110 CONTINUE
73517 120 CONTINUE
73518 CALL PYROBO(0,0,0D0,0D0,-DPS(1)/DPS(4),-DPS(2)/DPS(4),
73519 &-DPS(3)/DPS(4))
73520 PECM=0D0
73521 DO 130 I=1,N
73522 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PECM=PECM+P(I,4)
73523 130 CONTINUE
73524
73525C...Check if we have separated strings
73526
73527C...Reserve copy of particles by species at end of record.
73528 IWP=0
73529 IWN=0
73530 NBE(0)=N+MSTU(3)
73531 NMAX=NBE(0)
73532 SMMIN=PECM
73533 DO 190 IBE=1,MIN(10,MSTJ(52)+1)
73534 NBE(IBE)=NBE(IBE-1)
73535 DO 180 I=NSAV+1,N
73536 IF(IBE.EQ.MIN(10,MSTJ(52)+1)) THEN
73537 DO 140 IIBE=1,IBE-1
73538 IF(K(I,2).EQ.KFBE(IIBE)) GOTO 180
73539 140 CONTINUE
73540 ELSE
73541 IF(K(I,2).NE.KFBE(IBE)) GOTO 180
73542 ENDIF
73543 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 180
73544 IF(NBE(IBE).GE.MSTU(4)-MSTU(32)-5) THEN
73545 CALL PYERRM(11,'(PYBOEI:) no more memory left in PYJETS')
73546 RETURN
73547 ENDIF
73548 NBE(IBE)=NBE(IBE)+1
73549 NMAX=NBE(IBE)
73550 K(NBE(IBE),1)=I
73551 K(NBE(IBE),2)=0
73552 K(NBE(IBE),3)=0
73553 K(NBE(IBE),4)=0
73554 K(NBE(IBE),5)=0
73555 P(NBE(IBE),1)=0.0D0
73556 P(NBE(IBE),2)=0.0D0
73557 P(NBE(IBE),3)=0.0D0
73558 P(NBE(IBE),4)=0.0D0
73559 P(NBE(IBE),5)=0.0D0
73560 SMMIN=MIN(SMMIN,P(I,5))
73561C...Check if particles comes from different W's or Z's
73562 IF((MSTJ(53).NE.0.OR.MSTJ(56).GT.0).AND.MINT(32).EQ.0) THEN
73563 IM=I
73564 150 IF(K(IM,3).GT.0) THEN
73565 IM=K(IM,3)
73566 IF(ABS(K(IM,2)).NE.24.AND.K(IM,2).NE.23) GOTO 150
73567 K(NBE(IBE),5)=IM
73568 IF(IWP.EQ.0.AND.K(IM,2).EQ.24) IWP=IM
73569 IF(IWN.EQ.0.AND.K(IM,2).EQ.-24) IWN=IM
73570 IF(IWP.EQ.0.AND.K(IM,2).EQ.23) IWP=IM
73571 IF(IWN.EQ.0.AND.K(IM,2).EQ.23.AND.IM.NE.IWP) IWN=IM
73572 ENDIF
73573 ENDIF
73574C...Check if particles comes from different strings.
73575 IF(PARJ(94).GT.0.0D0) THEN
73576 IM=I
73577 160 IF(K(IM,3).GT.0) THEN
73578 IM=K(IM,3)
73579 IF(K(IM,2).NE.92.AND.K(IM,2).NE.91) GOTO 160
73580 K(NBE(IBE),5)=IM
73581 ENDIF
73582 ENDIF
73583 DO 170 J=1,3
73584 P(NBE(IBE),J)=0D0
73585 V(NBE(IBE),J)=0D0
73586 170 CONTINUE
73587 P(NBE(IBE),5)=-1.0D0
73588 180 CONTINUE
73589 190 CONTINUE
73590 IF(NBE(MIN(9,MSTJ(52)))-NBE(0).LE.1) GOTO 510
73591
73592C...Calculate separation between W+ and W- or between two Z0's.
73593C...No separation if there has been re-connections.
73594 SIGW=PARJ(93)
73595 IF(IWP.GT.0.AND.IWN.GT.0.AND.MSTJ(56).GT.0.AND.MINT(32).EQ.0) THEN
73596 IF(K(IWP,2).EQ.23) THEN
73597 DMW=PMAS(23,1)
73598 DGW=PMAS(23,2)
73599 ELSE
73600 DMW=PMAS(24,1)
73601 DGW=PMAS(24,2)
73602 ENDIF
73603 DMP=P(IWP,5)
73604 DMN=P(IWN,5)
73605 TAUPD=DMP/SQRT((DMP**2-DMW**2)**2+(DGW*(DMP**2)/DMW)**2)
73606 TAUND=DMN/SQRT((DMN**2-DMW**2)**2+(DGW*(DMN**2)/DMW)**2)
73607 TAUP=-TAUPD*LOG(PYR(IDUM))
73608 TAUN=-TAUND*LOG(PYR(IDUM))
73609 DXP=TAUP*PYP(IWP,8)/DMP
73610 DXN=TAUN*PYP(IWN,8)/DMN
73611 DX=DXP+DXN
73612 SIGW=1.0D0/(1.0D0/PARJ(93)+REAL(MSTJ(56))*DX)
73613 IF(PARJ(94).LT.0.0D0) SIGW=1.0D0/(1.0D0/SIGW-1.0D0/PARJ(94))
73614 ENDIF
73615
73616C...Add separation between strings.
73617 IF(PARJ(94).GT.0.0D0) THEN
73618 SIGW=1.0D0/(1.0D0/SIGW+1.0D0/PARJ(94))
73619 IWP=-1
73620 IWN=-1
73621 ENDIF
73622
73623 IF(MSTJ(57).EQ.1.AND.MSTJ(54).LT.0) THEN
73624 DO 220 IBE=1,MIN(9,MSTJ(52))
73625 DO 210 I1M=NBE(IBE-1)+1,NBE(IBE)
73626 Q2MIN=PECM**2
73627 I1=K(I1M,1)
73628 DO 200 I2M=NBE(IBE-1)+1,NBE(IBE)
73629 IF(I2M.EQ.I1M) GOTO 200
73630 I2=K(I2M,1)
73631 Q2=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-
73632 & (P(I1,2)+P(I2,2))**2-(P(I1,3)+P(I2,3))**2-
73633 & (P(I1,5)+P(I2,5))**2
73634 IF(Q2.GT.0.0D0.AND.Q2.LT.Q2MIN) THEN
73635 Q2MIN=Q2
73636 ENDIF
73637 200 CONTINUE
73638 P(I1M,5)=Q2MIN
73639 210 CONTINUE
73640 220 CONTINUE
73641 ENDIF
73642
73643C...Tabulate integral for subsequent momentum shift.
73644 DO 400 IBE=1,MIN(9,MSTJ(52))
73645 IF(IBE.NE.1.AND.IBE.NE.4.AND.IBE.LE.7) GOTO 270
73646 IF(IBE.EQ.1.AND.MAX(NBE(1)-NBE(0),NBE(2)-NBE(1),NBE(3)-NBE(2))
73647 & .LE.1) GOTO 270
73648 IF(IBE.EQ.4.AND.MAX(NBE(4)-NBE(3),NBE(5)-NBE(4),NBE(6)-NBE(5),
73649 & NBE(7)-NBE(6)).LE.1) GOTO 270
73650 IF(IBE.GE.8.AND.NBE(IBE)-NBE(IBE-1).LE.1) GOTO 270
73651 IF(IBE.EQ.1) PMHQ=2D0*PYMASS(211)
73652 IF(IBE.EQ.4) PMHQ=2D0*PYMASS(321)
73653 IF(IBE.EQ.8) PMHQ=2D0*PYMASS(221)
73654 IF(IBE.EQ.9) PMHQ=2D0*PYMASS(331)
73655 QDEL=0.1D0*MIN(PMHQ,PARJ(93))
73656 QDEL3=0.1D0*MIN(PMHQ,PARJ(93)*3.0D0)
73657 QDELW=0.1D0*MIN(PMHQ,SIGW)
73658 QDEL3W=0.1D0*MIN(PMHQ,SIGW*3.0D0)
73659 IF(MSTJ(51).EQ.1) THEN
73660 NBIN=MIN(100,NINT(9D0*PARJ(93)/QDEL))
73661 NBIN3=MIN(100,NINT(27D0*PARJ(93)/QDEL3))
73662 NBINW=MIN(100,NINT(9D0*SIGW/QDELW))
73663 NBIN3W=MIN(100,NINT(27D0*SIGW/QDEL3W))
73664 BEEX=EXP(0.5D0*QDEL/PARJ(93))
73665 BEEX3=EXP(0.5D0*QDEL3/(3.0D0*PARJ(93)))
73666 BEEXW=EXP(0.5D0*QDELW/SIGW)
73667 BEEX3W=EXP(0.5D0*QDEL3W/(3.0D0*SIGW))
73668 BERT=EXP(-QDEL/PARJ(93))
73669 BERT3=EXP(-QDEL3/(3.0D0*PARJ(93)))
73670 BERTW=EXP(-QDELW/SIGW)
73671 BERT3W=EXP(-QDEL3W/(3.0D0*SIGW))
73672 ELSE
73673 NBIN=MIN(100,NINT(3D0*PARJ(93)/QDEL))
73674 NBIN3=MIN(100,NINT(9D0*PARJ(93)/QDEL3))
73675 NBINW=MIN(100,NINT(3D0*SIGW/QDELW))
73676 NBIN3W=MIN(100,NINT(9D0*SIGW/QDEL3W))
73677 ENDIF
73678 DO 230 IBIN=1,NBIN
73679 QBIN=QDEL*(IBIN-0.5D0)
73680 BEI(IBIN)=QDEL*(QBIN**2+QDEL**2/12D0)/SQRT(QBIN**2+PMHQ**2)
73681 IF(MSTJ(51).EQ.1) THEN
73682 BEEX=BEEX*BERT
73683 BEI(IBIN)=BEI(IBIN)*BEEX
73684 ELSE
73685 BEI(IBIN)=BEI(IBIN)*EXP(-(QBIN/PARJ(93))**2)
73686 ENDIF
73687 IF(IBIN.GE.2) BEI(IBIN)=BEI(IBIN)+BEI(IBIN-1)
73688 230 CONTINUE
73689 DO 240 IBIN=1,NBIN3
73690 QBIN=QDEL3*(IBIN-0.5D0)
73691 BEI3(IBIN)=QDEL3*(QBIN**2+QDEL3**2/12D0)/SQRT(QBIN**2+PMHQ**2)
73692 IF(MSTJ(51).EQ.1) THEN
73693 BEEX3=BEEX3*BERT3
73694 BEI3(IBIN)=BEI3(IBIN)*BEEX3
73695 ELSE
73696 BEI3(IBIN)=BEI3(IBIN)*EXP(-(QBIN/(3.0D0*PARJ(93)))**2)
73697 ENDIF
73698 IF(IBIN.GE.2) BEI3(IBIN)=BEI3(IBIN)+BEI3(IBIN-1)
73699 240 CONTINUE
73700 DO 250 IBIN=1,NBINW
73701 QBIN=QDELW*(IBIN-0.5D0)
73702 BEIW(IBIN)=QDELW*(QBIN**2+QDELW**2/12D0)/SQRT(QBIN**2+PMHQ**2)
73703 IF(MSTJ(51).EQ.1) THEN
73704 BEEXW=BEEXW*BERTW
73705 BEIW(IBIN)=BEIW(IBIN)*BEEXW
73706 ELSE
73707 BEIW(IBIN)=BEIW(IBIN)*EXP(-(QBIN/SIGW)**2)
73708 ENDIF
73709 IF(IBIN.GE.2) BEIW(IBIN)=BEIW(IBIN)+BEIW(IBIN-1)
73710 250 CONTINUE
73711 DO 260 IBIN=1,NBIN3W
73712 QBIN=QDEL3W*(IBIN-0.5D0)
73713 BEI3W(IBIN)=QDEL3W*(QBIN**2+QDEL3W**2/12D0)/
73714 & SQRT(QBIN**2+PMHQ**2)
73715 IF(MSTJ(51).EQ.1) THEN
73716 BEEX3W=BEEX3W*BERT3W
73717 BEI3W(IBIN)=BEI3W(IBIN)*BEEX3W
73718 ELSE
73719 BEI3W(IBIN)=BEI3W(IBIN)*EXP(-(QBIN/(3.0D0*SIGW))**2)
73720 ENDIF
73721 IF(IBIN.GE.2) BEI3W(IBIN)=BEI3W(IBIN)+BEI3W(IBIN-1)
73722 260 CONTINUE
73723
73724C...Loop through particle pairs and find old relative momentum.
73725 270 DO 390 I1M=NBE(IBE-1)+1,NBE(IBE)-1
73726 I1=K(I1M,1)
73727 DO 380 I2M=I1M+1,NBE(IBE)
73728 IF(MSTJ(53).EQ.1.AND.K(I1M,5).NE.K(I2M,5)) GOTO 380
73729 IF(MSTJ(53).EQ.2.AND.K(I1M,5).EQ.K(I2M,5)) GOTO 380
73730 I2=K(I2M,1)
73731 Q2OLD=(P(I1,4)+P(I2,4))**2-(P(I1,1)+P(I2,1))**2-(P(I1,2)+
73732 & P(I2,2))**2-(P(I1,3)+P(I2,3))**2-(P(I1,5)+P(I2,5))**2
73733 IF(Q2OLD.LE.0.0D0) GOTO 380
73734 QOLD=SQRT(Q2OLD)
73735
73736C...Calculate new relative momentum.
73737 QMOV=0.0D0
73738 QMOV3=0.0D0
73739 QMOVW=0.0D0
73740 QMOV3W=0.0D0
73741 IF(QOLD.LT.1D-3*QDEL) THEN
73742 GOTO 280
73743 ELSEIF(QOLD.LE.QDEL) THEN
73744 QMOV=QOLD/3D0
73745 ELSEIF(QOLD.LT.(NBIN-0.1D0)*QDEL) THEN
73746 RBIN=QOLD/QDEL
73747 IBIN=RBIN
73748 RINP=(RBIN**3-IBIN**3)/(3*IBIN*(IBIN+1)+1)
73749 QMOV=(BEI(IBIN)+RINP*(BEI(IBIN+1)-BEI(IBIN)))*
73750 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
73751 ELSE
73752 QMOV=BEI(NBIN)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
73753 ENDIF
73754 280 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV))**(2D0/3D0)
73755 IF(QOLD.LT.1D-3*QDEL3) THEN
73756 GOTO 290
73757 ELSEIF(QOLD.LE.QDEL3) THEN
73758 QMOV3=QOLD/3D0
73759 ELSEIF(QOLD.LT.(NBIN3-0.1D0)*QDEL3) THEN
73760 RBIN3=QOLD/QDEL3
73761 IBIN3=RBIN3
73762 RINP3=(RBIN3**3-IBIN3**3)/(3*IBIN3*(IBIN3+1)+1)
73763 QMOV3=(BEI3(IBIN3)+RINP3*(BEI3(IBIN3+1)-BEI3(IBIN3)))*
73764 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
73765 ELSE
73766 QMOV3=BEI3(NBIN3)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
73767 ENDIF
73768 290 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3))**(2D0/3D0)
73769 RSCALE=1.0D0
73770 IF(MSTJ(54).EQ.2)
73771 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*PARJ(93)))**2)
73772 IF((IWP.NE.-1.AND.MSTJ(56).LE.0).OR.IWP.EQ.0.OR.IWN.EQ.0.OR.
73773 & K(I1M,5).EQ.K(I2M,5)) GOTO 320
73774
73775 IF(QOLD.LT.1D-3*QDELW) THEN
73776 GOTO 300
73777 ELSEIF(QOLD.LE.QDELW) THEN
73778 QMOVW=QOLD/3D0
73779 ELSEIF(QOLD.LT.(NBINW-0.1D0)*QDELW) THEN
73780 RBINW=QOLD/QDELW
73781 IBINW=RBINW
73782 RINPW=(RBINW**3-IBINW**3)/(3*IBINW*(IBINW+1)+1)
73783 QMOVW=(BEIW(IBINW)+RINPW*(BEIW(IBINW+1)-BEIW(IBINW)))*
73784 & SQRT(Q2OLD+PMHQ**2)/Q2OLD
73785 ELSE
73786 QMOVW=BEIW(NBINW)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
73787 ENDIF
73788 300 Q2NEW=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOVW))**(2D0/3D0)
73789 IF(QOLD.LT.1D-3*QDEL3W) THEN
73790 GOTO 310
73791 ELSEIF(QOLD.LE.QDEL3W) THEN
73792 QMOV3W=QOLD/3D0
73793 ELSEIF(QOLD.LT.(NBIN3W-0.1D0)*QDEL3W) THEN
73794 RBIN3W=QOLD/QDEL3W
73795 IBIN3W=RBIN3W
73796 RINP3W=(RBIN3W**3-IBIN3W**3)/(3*IBIN3W*(IBIN3W+1)+1)
73797 QMOV3W=(BEI3W(IBIN3W)+RINP3W*(BEI3W(IBIN3W+1)-
73798 & BEI3W(IBIN3W)))*SQRT(Q2OLD+PMHQ**2)/Q2OLD
73799 ELSE
73800 QMOV3W=BEI3W(NBIN3W)*SQRT(Q2OLD+PMHQ**2)/Q2OLD
73801 ENDIF
73802 310 Q2NEW3=Q2OLD*(QOLD/(QOLD+3D0*PARJ(92)*QMOV3W))**(2D0/3D0)
73803 IF(MSTJ(54).EQ.2)
73804 & RSCALE=1.0D0-EXP(-(QOLD/(2D0*SIGW))**2)
73805
73806 320 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW)
73807 DO 330 J=1,3
73808 P(I1M,J)=P(I1M,J)+P(NMAX+1,J)
73809 P(I2M,J)=P(I2M,J)+P(NMAX+2,J)
73810 330 CONTINUE
73811 IF(MSTJ(54).GE.1) THEN
73812 CALL PYBESQ(I1,I2,NMAX,Q2OLD,Q2NEW3)
73813 DO 340 J=1,3
73814 V(I1M,J)=V(I1M,J)+P(NMAX+1,J)*RSCALE
73815 V(I2M,J)=V(I2M,J)+P(NMAX+2,J)*RSCALE
73816 340 CONTINUE
73817 ELSEIF(MSTJ(54).LE.-1) THEN
73818 EDEL=P(I1,4)+P(I2,4)-
73819 & SQRT(MAX(Q2NEW-Q2OLD+(P(I1,4)+P(I2,4))**2,0.0D0))
73820 A2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
73821 & (P(I1,3)-P(I2,3))**2
73822 WMAX=-1.0D20
73823 MI3=0
73824 MI4=0
73825 S12=SDIP(I1,I2)
73826 SM1=(P(I1,5)+SMMIN)**2
73827 DO 360 I3M=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
73828 IF(I3M.EQ.I1M.OR.I3M.EQ.I2M) GOTO 360
73829 IF(MSTJ(53).EQ.1.AND.K(I3M,5).NE.K(I1M,5)) GOTO 360
73830 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
73831 & K(I3M,5).NE.K(I1M,5)) GOTO 360
73832 I3=K(I3M,1)
73833 IF(K(I3,2).EQ.K(I1,2)) GOTO 360
73834 S13=SDIP(I1,I3)
73835 S23=SDIP(I2,I3)
73836 SM3=(P(I3,5)+SMMIN)**2
73837 IF(MSTJ(54).EQ.-2) THEN
73838 WI=(MIN(S12*SM3,S13*MIN(SM1,SM3),
73839 & S23*MIN(SM1,SM3))*SM1)
73840 ELSE
73841 WI=((P(I1,4)+P(I2,4)+P(I3,4))**2-
73842 & (P(I1,3)+P(I2,3)+P(I3,3))**2-
73843 & (P(I1,2)+P(I2,2)+P(I3,2))**2-
73844 & (P(I1,1)+P(I2,1)+P(I3,1))**2)
73845 ENDIF
73846 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0) THEN
73847 IF (WMAX*WI.GE.(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2))))
73848 & GOTO 360
73849 ELSE
73850 IF(WMAX*WI.GE.1.0) GOTO 360
73851 ENDIF
73852 DO 350 I4M=I3M+1,NBE(MIN(10,MSTJ(52)+1))
73853 IF(I4M.EQ.I1M.OR.I4M.EQ.I2M) GOTO 350
73854 IF(MSTJ(53).EQ.1.AND.K(I4M,5).NE.K(I1M,5)) GOTO 350
73855 IF(MSTJ(53).EQ.-2.AND.K(I1M,5).EQ.K(I2M,5).AND.
73856 & K(I4M,5).NE.K(I1M,5)) GOTO 350
73857 I4=K(I4M,1)
73858 IF(K(I3,2).EQ.K(I4,2).OR.K(I4,2).EQ.K(I1,2))
73859 & GOTO 350
73860 IF((P(I3,4)+P(I4,4)+EDEL)**2.LT.
73861 & (P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
73862 & (P(I3,3)+P(I4,3))**2+(P(I3,5)+P(I4,5))**2)
73863 & GOTO 350
73864 IF(MSTJ(54).EQ.-2) THEN
73865 S14=SDIP(I1,I4)
73866 S24=SDIP(I2,I4)
73867 S34=SDIP(I3,I4)
73868 W=S12*MIN(MIN(S23,S24),MIN(S13,S14))*S34
73869 W=MIN(W,S13*MIN(MIN(S23,S34),S12)*S24)
73870 W=MIN(W,S14*MIN(MIN(S24,S34),S12)*S23)
73871 W=MIN(W,MIN(S23,S24)*S13*S14)
73872 W=1.0D0/W
73873 ELSE
73874C...weight=1-cos(theta)/mtot2
73875 S1234=(P(I1,4)+P(I2,4)+P(I3,4)+P(I4,4))**2-
73876 & (P(I1,3)+P(I2,3)+P(I3,3)+P(I4,3))**2-
73877 & (P(I1,2)+P(I2,2)+P(I3,2)+P(I4,2))**2-
73878 & (P(I1,1)+P(I2,1)+P(I3,1)+P(I4,1))**2
73879 W=1.0D0/S1234
73880 IF(W.LE.WMAX) GOTO 350
73881 ENDIF
73882 IF(MSTJ(57).EQ.1.AND.P(I3M,5).GT.0)
73883 & W=W*(1.0D0-EXP(-P(I3M,5)/(PARJ(93)**2)))
73884 IF(MSTJ(57).EQ.1.AND.P(I4M,5).GT.0)
73885 & W=W*(1.0D0-EXP(-P(I4M,5)/(PARJ(93)**2)))
73886 IF(W.LE.WMAX) GOTO 350
73887 MI3=I3M
73888 MI4=I4M
73889 WMAX=W
73890 350 CONTINUE
73891 360 CONTINUE
73892 IF(MI4.EQ.0) GOTO 380
73893 I3=K(MI3,1)
73894 I4=K(MI4,1)
73895 EOLD=P(I3,4)+P(I4,4)
73896 ENEW=EOLD+EDEL
73897 P2=(P(I3,1)+P(I4,1))**2+(P(I3,2)+P(I4,2))**2+
73898 & (P(I3,3)+P(I4,3))**2
73899 Q2NEWP=MAX(0.0D0,ENEW**2-P2-(P(I3,5)+P(I4,5))**2)
73900 Q2OLDP=MAX(0.0D0,EOLD**2-P2-(P(I3,5)+P(I4,5))**2)
73901 CALL PYBESQ(I3,I4,NMAX,Q2OLDP,Q2NEWP)
73902 DO 370 J=1,3
73903 V(MI3,J)=V(MI3,J)+P(NMAX+1,J)
73904 V(MI4,J)=V(MI4,J)+P(NMAX+2,J)
73905 370 CONTINUE
73906 ENDIF
73907 380 CONTINUE
73908 390 CONTINUE
73909 400 CONTINUE
73910
73911C...Shift momenta and recalculate energies.
73912 ESUMP=0.0D0
73913 ESUM=0.0D0
73914 PROD=0.0D0
73915 DO 430 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
73916 I=K(IM,1)
73917 ESUMP=ESUMP+P(I,4)
73918 DO 410 J=1,3
73919 P(I,J)=P(I,J)+P(IM,J)
73920 410 CONTINUE
73921 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
73922 ESUM=ESUM+P(I,4)
73923 DO 420 J=1,3
73924 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
73925 420 CONTINUE
73926 430 CONTINUE
73927
73928 PARJ(96)=0.0D0
73929 IF(MSTJ(54).NE.0.AND.PROD.NE.0.0D0) THEN
73930 440 ALPHA=(ESUMP-ESUM)/PROD
73931 PARJ(96)=PARJ(96)+ALPHA
73932 PROD=0.0D0
73933 ESUM=0.0D0
73934 DO 470 IM=NBE(0)+1,NBE(MIN(10,MSTJ(52)+1))
73935 I=K(IM,1)
73936 DO 450 J=1,3
73937 P(I,J)=P(I,J)+ALPHA*V(IM,J)
73938 450 CONTINUE
73939 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
73940 ESUM=ESUM+P(I,4)
73941 DO 460 J=1,3
73942 PROD=PROD+V(IM,J)*P(I,J)/P(I,4)
73943 460 CONTINUE
73944 470 CONTINUE
73945 IF(PROD.NE.0.0D0.AND.ABS(ESUMP-ESUM)/PECM.GT.0.00001D0)
73946 & GOTO 440
73947 ENDIF
73948
73949C...Rescale all momenta for energy conservation.
73950 PES=0D0
73951 PQS=0D0
73952 DO 480 I=1,N
73953 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 480
73954 PES=PES+P(I,4)
73955 PQS=PQS+P(I,5)**2/P(I,4)
73956 480 CONTINUE
73957 PARJ(95)=PES-PECM
73958 FAC=(PECM-PQS)/(PES-PQS)
73959 DO 500 I=1,N
73960 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 500
73961 DO 490 J=1,3
73962 P(I,J)=FAC*P(I,J)
73963 490 CONTINUE
73964 P(I,4)=SQRT(P(I,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
73965 500 CONTINUE
73966
73967C...Boost back to correct reference frame.
73968 510 CALL PYROBO(0,0,0D0,0D0,DPS(1)/DPS(4),DPS(2)/DPS(4),DPS(3)/DPS(4))
73969 DO 520 I=1,N
73970 IF(K(I,1).LT.0) K(I,1)=-K(I,1)
73971 520 CONTINUE
73972
73973 RETURN
73974 END
73975
73976C*********************************************************************
73977
73978C...PYBESQ
73979C...Calculates the momentum shift in a system of two particles assuming
73980C...the relative momentum squared should be shifted to Q2NEW. NI is the
73981C...last position occupied in /PYJETS/.
73982
73983 SUBROUTINE PYBESQ(I1,I2,NI,Q2OLD,Q2NEW)
73984
73985C...Double precision and integer declarations.
73986 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
73987 IMPLICIT INTEGER(I-N)
73988 INTEGER PYK,PYCHGE,PYCOMP
73989C...Parameter statement to help give large particle numbers.
73990 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
73991 &KEXCIT=4000000,KDIMEN=5000000)
73992C...Commonblocks.
73993 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
73994 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
73995 SAVE /PYJETS/,/PYDAT1/
73996C...Local arrays and data.
73997 DIMENSION DP(5)
73998 SAVE HC1
73999
74000 IF(MSTJ(55).EQ.0) THEN
74001 DQ2=Q2NEW-Q2OLD
74002 DP2=(P(I1,1)-P(I2,1))**2+(P(I1,2)-P(I2,2))**2+
74003 & (P(I1,3)-P(I2,3))**2
74004 DP12=P(I1,1)**2+P(I1,2)**2+P(I1,3)**2
74005 & -P(I2,1)**2-P(I2,2)**2-P(I2,3)**2
74006 SE=P(I1,4)+P(I2,4)
74007 DE=P(I1,4)-P(I2,4)
74008 DQ2SE=DQ2+SE**2
74009 DA=SE*DE*DP12-DP2*DQ2SE
74010 DB=DP2*DQ2SE-DP12**2
74011 HA=(DA+SQRT(MAX(DA**2+DQ2*(DQ2+SE**2-DE**2)*DB,0D0)))/(2D0*DB)
74012 DO 100 J=1,3
74013 PD=HA*(P(I1,J)-P(I2,J))
74014 P(NI+1,J)=PD
74015 P(NI+2,J)=-PD
74016 100 CONTINUE
74017 RETURN
74018 ENDIF
74019
74020 K(NI+1,1)=1
74021 K(NI+2,1)=1
74022 DO 110 J=1,5
74023 P(NI+1,J)=P(I1,J)
74024 P(NI+2,J)=P(I2,J)
74025 DP(J)=P(I1,J)+P(I2,J)
74026 110 CONTINUE
74027
74028C...Boost to cms and rotate first particle to z-axis
74029 CALL PYROBO(NI+1,NI+2,0.0D0,0.0D0,
74030 &-DP(1)/DP(4),-DP(2)/DP(4),-DP(3)/DP(4))
74031 PHI=PYANGL(P(NI+1,1),P(NI+1,2))
74032 THE=PYANGL(P(NI+1,3),SQRT(P(NI+1,1)**2+P(NI+1,2)**2))
74033 S=Q2NEW+(P(I1,5)+P(I2,5))**2
74034 PZ=0.5D0*SQRT(Q2NEW*(S-(P(I1,5)-P(I2,5))**2)/S)
74035 P(NI+1,1)=0.0D0
74036 P(NI+1,2)=0.0D0
74037 P(NI+1,3)=PZ
74038 P(NI+1,4)=SQRT(PZ**2+P(I1,5)**2)
74039 P(NI+2,1)=0.0D0
74040 P(NI+2,2)=0.0D0
74041 P(NI+2,3)=-PZ
74042 P(NI+2,4)=SQRT(PZ**2+P(I2,5)**2)
74043 DP(4)=SQRT(DP(1)**2+DP(2)**2+DP(3)**2+S)
74044 CALL PYROBO(NI+1,NI+2,THE,PHI,
74045 &DP(1)/DP(4),DP(2)/DP(4),DP(3)/DP(4))
74046
74047 DO 120 J=1,3
74048 P(NI+1,J)=P(NI+1,J)-P(I1,J)
74049 P(NI+2,J)=P(NI+2,J)-P(I2,J)
74050 120 CONTINUE
74051
74052 RETURN
74053 END
74054
74055C*********************************************************************
74056
74057C...PYMASS
74058C...Gives the mass of a particle/parton.
74059
74060 FUNCTION PYMASS(KF)
74061
74062C...Double precision and integer declarations.
74063 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74064 IMPLICIT INTEGER(I-N)
74065 INTEGER PYK,PYCHGE,PYCOMP
74066C...Commonblocks.
74067 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74068 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74069 SAVE /PYDAT1/,/PYDAT2/
74070
74071C...Reset variables. Compressed code. Special case for popcorn diquarks.
74072 PYMASS=0D0
74073 KFA=IABS(KF)
74074 KC=PYCOMP(KF)
74075 IF(KC.EQ.0) THEN
74076 MSTJ(93)=0
74077 RETURN
74078 ENDIF
74079
74080C...Guarantee use of constituent masses for internal checks.
74081 IF((MSTJ(93).EQ.1.OR.MSTJ(93).EQ.2).AND.
74082 &(KFA.LE.10.OR.MOD(KFA/10,10).EQ.0)) THEN
74083 IF(KFA.LE.5) THEN
74084 PYMASS=PARF(100+KFA)
74085 IF(MSTJ(93).EQ.2) PYMASS=MAX(0D0,PYMASS-PARF(121))
74086 ELSEIF(KFA.LE.10) THEN
74087 PYMASS=PMAS(KFA,1)
74088 ELSEIF(MSTJ(93).EQ.1) THEN
74089 PYMASS=PARF(100+MOD(KFA/1000,10))+PARF(100+MOD(KFA/100,10))
74090 ELSE
74091 PYMASS=MAX(0D0,PMAS(KC,1)-PARF(122)-2D0*PARF(112)/3D0)
74092 ENDIF
74093
74094C...Other masses can be read directly off table.
74095 ELSE
74096 PYMASS=PMAS(KC,1)
74097 ENDIF
74098
74099C...Optional mass broadening according to truncated Breit-Wigner
74100C...(either in m or in m^2).
74101 IF(MSTJ(24).GE.1.AND.PMAS(KC,2).GT.1D-4) THEN
74102 IF(MSTJ(24).EQ.1.OR.(MSTJ(24).EQ.2.AND.KFA.GT.100)) THEN
74103 PYMASS=PYMASS+0.5D0*PMAS(KC,2)*TAN((2D0*PYR(0)-1D0)*
74104 & ATAN(2D0*PMAS(KC,3)/PMAS(KC,2)))
74105 ELSE
74106 PM0=PYMASS
74107 PMLOW=ATAN((MAX(0D0,PM0-PMAS(KC,3))**2-PM0**2)/
74108 & (PM0*PMAS(KC,2)))
74109 PMUPP=ATAN(((PM0+PMAS(KC,3))**2-PM0**2)/(PM0*PMAS(KC,2)))
74110 PYMASS=SQRT(MAX(0D0,PM0**2+PM0*PMAS(KC,2)*TAN(PMLOW+
74111 & (PMUPP-PMLOW)*PYR(0))))
74112 ENDIF
74113 ENDIF
74114 MSTJ(93)=0
74115
74116 RETURN
74117 END
74118
74119C*********************************************************************
74120
74121C...PYMRUN
74122C...Gives the running, current-algebra mass of a d, u, s, c or b quark,
74123C...for Higgs couplings. Everything else sent on to PYMASS.
74124
74125 FUNCTION PYMRUN(KF,Q2)
74126
74127C...Double precision and integer declarations.
74128 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74129 IMPLICIT INTEGER(I-N)
74130 INTEGER PYK,PYCHGE,PYCOMP
74131C...Commonblocks.
74132 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74133 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74134 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
74135 SAVE /PYDAT1/,/PYDAT2/,/PYPARS/
74136
74137C...Most masses not handled here.
74138 KFA=IABS(KF)
74139 IF(KFA.EQ.0.OR.KFA.GT.6) THEN
74140 PYMRUN=PYMASS(KF)
74141
74142C...Current-algebra masses, but no Q2 dependence.
74143 ELSEIF(MSTP(37).NE.1.OR.MSTP(2).LE.0) THEN
74144 PYMRUN=PARF(90+KFA)
74145
74146C...Running current-algebra masses.
74147 ELSE
74148 AS=PYALPS(Q2)
74149 PYMRUN=PARF(90+KFA)*
74150 & (LOG(MAX(4D0,PARP(37)**2*PARF(90+KFA)**2/PARU(117)**2))/
74151 & LOG(MAX(4D0,Q2/PARU(117)**2)))**(12D0/(33D0-2D0*MSTU(118)))
74152 ENDIF
74153
74154 RETURN
74155 END
74156
74157C*********************************************************************
74158
74159C...PYNAME
74160C...Gives the particle/parton name as a character string.
74161
74162 SUBROUTINE PYNAME(KF,CHAU)
74163
74164C...Double precision and integer declarations.
74165 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74166 IMPLICIT INTEGER(I-N)
74167 INTEGER PYK,PYCHGE,PYCOMP
74168C...Commonblocks.
74169 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74170 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74171 COMMON/PYDAT4/CHAF(500,2)
74172 CHARACTER CHAF*16
74173 SAVE /PYDAT1/,/PYDAT2/,/PYDAT4/
74174C...Local character variable.
74175 CHARACTER CHAU*16
74176
74177C...Read out code with distinction particle/antiparticle.
74178 CHAU=' '
74179 KC=PYCOMP(KF)
74180 IF(KC.NE.0) CHAU=CHAF(KC,(3-ISIGN(1,KF))/2)
74181
74182
74183 RETURN
74184 END
74185
74186C*********************************************************************
74187
74188C...PYCHGE
74189C...Gives three times the charge for a particle/parton.
74190
74191 FUNCTION PYCHGE(KF)
74192
74193C...Double precision and integer declarations.
74194 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74195 IMPLICIT INTEGER(I-N)
74196 INTEGER PYK,PYCHGE,PYCOMP
74197C...Commonblocks.
74198 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74199 SAVE /PYDAT2/
74200
74201C...Read out charge and change sign for antiparticle.
74202 PYCHGE=0
74203 KC=PYCOMP(KF)
74204 IF(KC.NE.0) PYCHGE=KCHG(KC,1)*ISIGN(1,KF)
74205
74206 RETURN
74207 END
74208
74209C*********************************************************************
74210
74211C...PYCOMP
74212C...Compress the standard KF codes for use in mass and decay arrays;
74213C...also checks whether a given code actually is defined.
74214
74215 FUNCTION PYCOMP(KF)
74216
74217C...Double precision and integer declarations.
74218 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74219 IMPLICIT INTEGER(I-N)
74220 INTEGER PYK,PYCHGE,PYCOMP
74221C...Commonblocks.
74222 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74223 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74224 SAVE /PYDAT1/,/PYDAT2/
74225C...Local arrays and saved data.
74226 DIMENSION KFORD(100:500),KCORD(101:500)
74227 SAVE KFORD,KCORD,NFORD,KFLAST,KCLAST
74228
74229C...Whenever necessary reorder codes for faster search.
74230 IF(MSTU(20).EQ.0) THEN
74231 NFORD=100
74232 KFORD(100)=0
74233 DO 120 I=101,500
74234 KFA=KCHG(I,4)
74235 IF(KFA.LE.100) GOTO 120
74236 NFORD=NFORD+1
74237 DO 100 I1=NFORD-1,0,-1
74238 IF(KFA.GE.KFORD(I1)) GOTO 110
74239 KFORD(I1+1)=KFORD(I1)
74240 KCORD(I1+1)=KCORD(I1)
74241 100 CONTINUE
74242 110 KFORD(I1+1)=KFA
74243 KCORD(I1+1)=I
74244 120 CONTINUE
74245 MSTU(20)=1
74246 KFLAST=0
74247 KCLAST=0
74248 ENDIF
74249
74250C...Fast action if same code as in latest call.
74251 IF(KF.EQ.KFLAST) THEN
74252 PYCOMP=KCLAST
74253 RETURN
74254 ENDIF
74255
74256C...Starting values. Remove internal diquark flags.
74257 PYCOMP=0
74258 KFA=IABS(KF)
74259 IF(MOD(KFA/10,10).EQ.0.AND.KFA.LT.100000
74260 & .AND.MOD(KFA/1000,10).GT.0) KFA=MOD(KFA,10000)
74261
74262C...Simple cases: direct translation.
74263 IF(KFA.GT.KFORD(NFORD)) THEN
74264 ELSEIF(KFA.LE.100) THEN
74265 PYCOMP=KFA
74266
74267C...Else binary search.
74268 ELSE
74269 IMIN=100
74270 IMAX=NFORD+1
74271 130 IAVG=(IMIN+IMAX)/2
74272 IF(KFORD(IAVG).GT.KFA) THEN
74273 IMAX=IAVG
74274 IF(IMAX.GT.IMIN+1) GOTO 130
74275 ELSEIF(KFORD(IAVG).LT.KFA) THEN
74276 IMIN=IAVG
74277 IF(IMAX.GT.IMIN+1) GOTO 130
74278 ELSE
74279 PYCOMP=KCORD(IAVG)
74280 ENDIF
74281 ENDIF
74282
74283C...Check if antiparticle allowed.
74284 IF(PYCOMP.NE.0.AND.KF.LT.0) THEN
74285 IF(KCHG(PYCOMP,3).EQ.0) PYCOMP=0
74286 ENDIF
74287
74288C...Save codes for possible future fast action.
74289 KFLAST=KF
74290 KCLAST=PYCOMP
74291
74292 RETURN
74293 END
74294
74295C*********************************************************************
74296
74297C...PYERRM
74298C...Informs user of errors in program execution.
74299
74300 SUBROUTINE PYERRM(MERR,CHMESS)
74301
74302C...Double precision and integer declarations.
74303 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74304 IMPLICIT INTEGER(I-N)
74305 INTEGER PYK,PYCHGE,PYCOMP
74306C...Commonblocks.
74307 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74308 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74309 SAVE /PYJETS/,/PYDAT1/
74310C...Local character variable.
74311 CHARACTER CHMESS*(*)
74312
74313C...Write first few warnings, then be silent.
74314 IF(MERR.LE.10) THEN
74315 MSTU(27)=MSTU(27)+1
74316 MSTU(28)=MERR
74317 IF(MSTU(25).EQ.1.AND.MSTU(27).LE.MSTU(26)) WRITE(MSTU(11),5000)
74318 & MERR,MSTU(31),CHMESS
74319
74320C...Write first few errors, then be silent or stop program.
74321 ELSEIF(MERR.LE.20) THEN
74322 IF(MSTU(29).EQ.0) MSTU(23)=MSTU(23)+1
74323 MSTU(30)=MSTU(30)+1
74324 MSTU(24)=MERR-10
74325 IF(MSTU(21).GE.1.AND.MSTU(23).LE.MSTU(22)) WRITE(MSTU(11),5100)
74326 & MERR-10,MSTU(31),CHMESS
74327 IF(MSTU(21).GE.2.AND.MSTU(23).GT.MSTU(22)) THEN
74328 WRITE(MSTU(11),5100) MERR-10,MSTU(31),CHMESS
74329 WRITE(MSTU(11),5200)
74330 IF(MERR.NE.17) CALL PYLIST(2)
74331 CALL PYSTOP(3)
74332 ENDIF
74333
74334C...Stop program in case of irreparable error.
74335 ELSE
74336 WRITE(MSTU(11),5300) MERR-20,MSTU(31),CHMESS
74337 CALL PYSTOP(3)
74338 ENDIF
74339
74340C...Formats for output.
74341 5000 FORMAT(/5X,'Advisory warning type',I2,' given after',I9,
74342 &' PYEXEC calls:'/5X,A)
74343 5100 FORMAT(/5X,'Error type',I2,' has occured after',I9,
74344 &' PYEXEC calls:'/5X,A)
74345 5200 FORMAT(5X,'Execution will be stopped after listing of last ',
74346 &'event!')
74347 5300 FORMAT(/5X,'Fatal error type',I2,' has occured after',I9,
74348 &' PYEXEC calls:'/5X,A/5X,'Execution will now be stopped!')
74349
74350 RETURN
74351 END
74352
74353C*********************************************************************
74354
74355C...PYALEM
74356C...Calculates the running alpha_electromagnetic.
74357
74358 FUNCTION PYALEM(Q2)
74359
74360C...Double precision and integer declarations.
74361 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74362 IMPLICIT INTEGER(I-N)
74363 INTEGER PYK,PYCHGE,PYCOMP
74364C...Commonblocks.
74365 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74366 SAVE /PYDAT1/
74367
74368C...Calculate real part of photon vacuum polarization.
74369C...For leptons simplify by using asymptotic (Q^2 >> m^2) expressions.
74370C...For hadrons use parametrization of H. Burkhardt et al.
74371C...See R. Kleiss et al, CERN 89-08, vol. 3, pp. 129-131.
74372 AEMPI=PARU(101)/(3D0*PARU(1))
74373 IF(MSTU(101).LE.0.OR.Q2.LT.2D-6) THEN
74374 RPIGG=0D0
74375 ELSEIF(MSTU(101).EQ.2.AND.Q2.LT.PARU(104)) THEN
74376 RPIGG=0D0
74377 ELSEIF(MSTU(101).EQ.2) THEN
74378 RPIGG=1D0-PARU(101)/PARU(103)
74379 ELSEIF(Q2.LT.0.09D0) THEN
74380 RPIGG=AEMPI*(13.4916D0+LOG(Q2))+0.00835D0*LOG(1D0+Q2)
74381 ELSEIF(Q2.LT.9D0) THEN
74382 RPIGG=AEMPI*(16.3200D0+2D0*LOG(Q2))+
74383 & 0.00238D0*LOG(1D0+3.927D0*Q2)
74384 ELSEIF(Q2.LT.1D4) THEN
74385 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00165D0+
74386 & 0.00299D0*LOG(1D0+Q2)
74387 ELSE
74388 RPIGG=AEMPI*(13.4955D0+3D0*LOG(Q2))+0.00221D0+
74389 & 0.00293D0*LOG(1D0+Q2)
74390 ENDIF
74391
74392C...Calculate running alpha_em.
74393 PYALEM=PARU(101)/(1D0-RPIGG)
74394 PARU(108)=PYALEM
74395
74396 RETURN
74397 END
74398
74399C*********************************************************************
74400
74401C...PYALPS
74402C...Gives the value of alpha_strong.
74403
74404 FUNCTION PYALPS(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 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74413 SAVE /PYDAT1/,/PYDAT2/
74414C...Coefficients for second-order threshold matching.
74415C...From W.J. Marciano, Phys. Rev. D29 (1984) 580.
74416 DIMENSION STEPDN(6),STEPUP(6)
74417c DATA STEPDN/0D0,0D0,(2D0*107D0/2025D0),(2D0*963D0/14375D0),
74418c &(2D0*321D0/3703D0),0D0/
74419c DATA STEPUP/0D0,0D0,0D0,(-2D0*107D0/1875D0),
74420c &(-2D0*963D0/13225D0),(-2D0*321D0/3381D0)/
74421 DATA STEPDN/0D0,0D0,0.10568D0,0.13398D0,0.17337D0,0D0/
74422 DATA STEPUP/0D0,0D0,0D0,-0.11413D0,-0.14563D0,-0.18988D0/
74423
74424C...Constant alpha_strong trivial. Pick artificial Lambda.
74425 IF(MSTU(111).LE.0) THEN
74426 PYALPS=PARU(111)
74427 MSTU(118)=MSTU(112)
74428 PARU(117)=0.2D0
74429 IF(Q2.GT.0.04D0) PARU(117)=SQRT(Q2)*EXP(-6D0*PARU(1)/
74430 & ((33D0-2D0*MSTU(112))*PARU(111)))
74431 PARU(118)=PARU(111)
74432 RETURN
74433 ENDIF
74434
74435C...Find effective Q2, number of flavours and Lambda.
74436 Q2EFF=Q2
74437 IF(MSTU(115).GE.2) Q2EFF=MAX(Q2,PARU(114))
74438 NF=MSTU(112)
74439 ALAM2=PARU(112)**2
74440 100 IF(NF.GT.MAX(3,MSTU(113))) THEN
74441 Q2THR=PARU(113)*PMAS(NF,1)**2
74442 IF(Q2EFF.LT.Q2THR) THEN
74443 NF=NF-1
74444 Q2RAT=Q2THR/ALAM2
74445 ALAM2=ALAM2*Q2RAT**(2D0/(33D0-2D0*NF))
74446 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPDN(NF)
74447 GOTO 100
74448 ENDIF
74449 ENDIF
74450 110 IF(NF.LT.MIN(6,MSTU(114))) THEN
74451 Q2THR=PARU(113)*PMAS(NF+1,1)**2
74452 IF(Q2EFF.GT.Q2THR) THEN
74453 NF=NF+1
74454 Q2RAT=Q2THR/ALAM2
74455 ALAM2=ALAM2*Q2RAT**(-2D0/(33D0-2D0*NF))
74456 IF(MSTU(111).EQ.2) ALAM2=ALAM2*LOG(Q2RAT)**STEPUP(NF)
74457 GOTO 110
74458 ENDIF
74459 ENDIF
74460 IF(MSTU(115).EQ.1) Q2EFF=Q2EFF+ALAM2
74461 PARU(117)=SQRT(ALAM2)
74462
74463C...Evaluate first or second order alpha_strong.
74464 B0=(33D0-2D0*NF)/6D0
74465 ALGQ=LOG(MAX(1.0001D0,Q2EFF/ALAM2))
74466 IF(MSTU(111).EQ.1) THEN
74467 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ))
74468 ELSE
74469 B1=(153D0-19D0*NF)/6D0
74470 PYALPS=MIN(PARU(115),PARU(2)/(B0*ALGQ)*(1D0-B1*LOG(ALGQ)/
74471 & (B0**2*ALGQ)))
74472 ENDIF
74473 MSTU(118)=NF
74474 PARU(118)=PYALPS
74475
74476 RETURN
74477 END
74478
74479C*********************************************************************
74480
74481C...PYANGL
74482C...Reconstructs an angle from given x and y coordinates.
74483
74484 FUNCTION PYANGL(X,Y)
74485
74486C...Double precision and integer declarations.
74487 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74488 IMPLICIT INTEGER(I-N)
74489 INTEGER PYK,PYCHGE,PYCOMP
74490C...Commonblocks.
74491 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74492 SAVE /PYDAT1/
74493
74494 PYANGL=0D0
74495 R=SQRT(X**2+Y**2)
74496 IF(R.LT.1D-20) RETURN
74497 IF(ABS(X)/R.LT.0.8D0) THEN
74498 PYANGL=SIGN(ACOS(X/R),Y)
74499 ELSE
74500 PYANGL=ASIN(Y/R)
74501 IF(X.LT.0D0.AND.PYANGL.GE.0D0) THEN
74502 PYANGL=PARU(1)-PYANGL
74503 ELSEIF(X.LT.0D0) THEN
74504 PYANGL=-PARU(1)-PYANGL
74505 ENDIF
74506 ENDIF
74507
74508 RETURN
74509 END
74510
74511C*********************************************************************
74512C*********************************************************************
74513
74514C...PYROBO
74515C...Performs rotations and boosts.
74516
74517 SUBROUTINE PYROBO(IMI,IMA,THE,PHI,BEX,BEY,BEZ)
74518
74519C...Double precision and integer declarations.
74520 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74521 IMPLICIT INTEGER(I-N)
74522 INTEGER PYK,PYCHGE,PYCOMP
74523C...Commonblocks.
74524 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74525 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74526 SAVE /PYJETS/,/PYDAT1/
74527C...Local arrays.
74528 DIMENSION ROT(3,3),PR(3),VR(3),DP(4),DV(4)
74529
74530C...Find and check range of rotation/boost.
74531 IMIN=IMI
74532 IF(IMIN.LE.0) IMIN=1
74533 IF(MSTU(1).GT.0) IMIN=MSTU(1)
74534 IMAX=IMA
74535 IF(IMAX.LE.0) IMAX=N
74536 IF(MSTU(2).GT.0) IMAX=MSTU(2)
74537 IF(IMIN.GT.MSTU(4).OR.IMAX.GT.MSTU(4)) THEN
74538 CALL PYERRM(11,'(PYROBO:) range outside PYJETS memory')
74539 RETURN
74540 ENDIF
74541
74542C...Optional resetting of V (when not set before.)
74543 IF(MSTU(33).NE.0) THEN
74544 DO 110 I=MIN(IMIN,MSTU(4)),MIN(IMAX,MSTU(4))
74545 DO 100 J=1,5
74546 V(I,J)=0D0
74547 100 CONTINUE
74548 110 CONTINUE
74549 MSTU(33)=0
74550 ENDIF
74551
74552C...Rotate, typically from z axis to direction (theta,phi).
74553 IF(THE**2+PHI**2.GT.1D-20) THEN
74554 ROT(1,1)=COS(THE)*COS(PHI)
74555 ROT(1,2)=-SIN(PHI)
74556 ROT(1,3)=SIN(THE)*COS(PHI)
74557 ROT(2,1)=COS(THE)*SIN(PHI)
74558 ROT(2,2)=COS(PHI)
74559 ROT(2,3)=SIN(THE)*SIN(PHI)
74560 ROT(3,1)=-SIN(THE)
74561 ROT(3,2)=0D0
74562 ROT(3,3)=COS(THE)
74563 DO 140 I=IMIN,IMAX
74564 IF(K(I,1).LE.0) GOTO 140
74565 DO 120 J=1,3
74566 PR(J)=P(I,J)
74567 VR(J)=V(I,J)
74568 120 CONTINUE
74569 DO 130 J=1,3
74570 P(I,J)=ROT(J,1)*PR(1)+ROT(J,2)*PR(2)+ROT(J,3)*PR(3)
74571 V(I,J)=ROT(J,1)*VR(1)+ROT(J,2)*VR(2)+ROT(J,3)*VR(3)
74572 130 CONTINUE
74573 140 CONTINUE
74574 ENDIF
74575
74576C...Boost, typically from rest to momentum/energy=beta.
74577 IF(BEX**2+BEY**2+BEZ**2.GT.1D-20) THEN
74578 DBX=BEX
74579 DBY=BEY
74580 DBZ=BEZ
74581 DB=SQRT(DBX**2+DBY**2+DBZ**2)
74582 EPS1=1D0-1D-12
74583 IF(DB.GT.EPS1) THEN
74584C...Rescale boost vector if too close to unity.
74585 CALL PYERRM(3,'(PYROBO:) boost vector too large')
74586 DBX=DBX*(EPS1/DB)
74587 DBY=DBY*(EPS1/DB)
74588 DBZ=DBZ*(EPS1/DB)
74589 DB=EPS1
74590 ENDIF
74591 DGA=1D0/SQRT(1D0-DB**2)
74592 DO 160 I=IMIN,IMAX
74593 IF(K(I,1).LE.0) GOTO 160
74594 DO 150 J=1,4
74595 DP(J)=P(I,J)
74596 DV(J)=V(I,J)
74597 150 CONTINUE
74598 DBP=DBX*DP(1)+DBY*DP(2)+DBZ*DP(3)
74599 DGABP=DGA*(DGA*DBP/(1D0+DGA)+DP(4))
74600 P(I,1)=DP(1)+DGABP*DBX
74601 P(I,2)=DP(2)+DGABP*DBY
74602 P(I,3)=DP(3)+DGABP*DBZ
74603 P(I,4)=DGA*(DP(4)+DBP)
74604 DBV=DBX*DV(1)+DBY*DV(2)+DBZ*DV(3)
74605 DGABV=DGA*(DGA*DBV/(1D0+DGA)+DV(4))
74606 V(I,1)=DV(1)+DGABV*DBX
74607 V(I,2)=DV(2)+DGABV*DBY
74608 V(I,3)=DV(3)+DGABV*DBZ
74609 V(I,4)=DGA*(DV(4)+DBV)
74610 160 CONTINUE
74611 ENDIF
74612
74613 RETURN
74614 END
74615
74616C*********************************************************************
74617
74618C...PYEDIT
74619C...Performs global manipulations on the event record, in particular
74620C...to exclude unstable or undetectable partons/particles.
74621
74622 SUBROUTINE PYEDIT(MEDIT)
74623
74624C...Double precision and integer declarations.
74625 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74626 IMPLICIT INTEGER(I-N)
74627 INTEGER PYK,PYCHGE,PYCOMP
74628C...Parameter statement to help give large particle numbers.
74629 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74630 &KEXCIT=4000000,KDIMEN=5000000)
74631C...Commonblocks.
74632 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74633 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74634 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74635 COMMON/PYCTAG/NCT,MCT(4000,2)
74636 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYCTAG/
74637C...Local arrays.
74638 DIMENSION NS(2),PTS(2),PLS(2)
74639
74640C...Remove unwanted partons/particles.
74641 IF((MEDIT.GE.0.AND.MEDIT.LE.3).OR.MEDIT.EQ.5) THEN
74642 IMAX=N
74643 IF(MSTU(2).GT.0) IMAX=MSTU(2)
74644 I1=MAX(1,MSTU(1))-1
74645 DO 110 I=MAX(1,MSTU(1)),IMAX
74646 IF(K(I,1).EQ.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40)) GOTO 110
74647 IF(MEDIT.EQ.1) THEN
74648 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
74649 ELSEIF(MEDIT.EQ.2) THEN
74650 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
74651 KC=PYCOMP(K(I,2))
74652 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74653 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74654 & K(I,2).EQ.KSUSY1+39) GOTO 110
74655 ELSEIF(MEDIT.EQ.3) THEN
74656 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42) GOTO 110
74657 KC=PYCOMP(K(I,2))
74658 IF(KC.EQ.0) GOTO 110
74659 IF(KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0) GOTO 110
74660 ELSEIF(MEDIT.EQ.5) THEN
74661 IF(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.K(I,1).EQ.52) GOTO 110
74662 KC=PYCOMP(K(I,2))
74663 IF(KC.EQ.0) GOTO 110
74664 IF(K(I,1).GT.10.AND.K(I,1).NE.41.AND.K(I,1).NE.42.AND.
74665 & KCHG(KC,2).EQ.0) GOTO 110
74666 ENDIF
74667
74668C...Pack remaining partons/particles. Origin no longer known.
74669 I1=I1+1
74670 DO 100 J=1,5
74671 K(I1,J)=K(I,J)
74672 P(I1,J)=P(I,J)
74673 V(I1,J)=V(I,J)
74674 100 CONTINUE
74675 K(I1,3)=0
74676 110 CONTINUE
74677 IF(I1.LT.N) MSTU(3)=0
74678 IF(I1.LT.N) MSTU(70)=0
74679 N=I1
74680
74681C...Selective removal of class of entries. New position of retained.
74682 ELSEIF(MEDIT.GE.11.AND.MEDIT.LE.15) THEN
74683 I1=0
74684 DO 120 I=1,N
74685 K(I,3)=MOD(K(I,3),MSTU(5))
74686 IF(MEDIT.EQ.11.AND.K(I,1).LT.0) GOTO 120
74687 IF(MEDIT.EQ.12.AND.K(I,1).EQ.0) GOTO 120
74688 IF(MEDIT.EQ.13.AND.(K(I,1).EQ.11.OR.K(I,1).EQ.12.OR.
74689 & K(I,1).EQ.15.OR.K(I,1).EQ.51).AND.K(I,2).NE.94) GOTO 120
74690 IF(MEDIT.EQ.14.AND.(K(I,1).EQ.13.OR.K(I,1).EQ.14.OR.
74691 & K(I,1).EQ.52.OR.K(I,2).EQ.94)) GOTO 120
74692 IF(MEDIT.EQ.15.AND.K(I,1).GE.21.AND.K(I,1).LE.40) GOTO 120
74693 I1=I1+1
74694 K(I,3)=K(I,3)+MSTU(5)*I1
74695 120 CONTINUE
74696
74697C...Find new event history information and replace old.
74698 DO 140 I=1,N
74699 IF(K(I,1).LE.0.OR.(K(I,1).GE.21.AND.K(I,1).LE.40).OR.
74700 & K(I,3)/MSTU(5).EQ.0) GOTO 140
74701 ID=I
74702 130 IM=MOD(K(ID,3),MSTU(5))
74703 IF(MEDIT.EQ.13.AND.IM.GT.0.AND.IM.LE.N) THEN
74704 IF((K(IM,1).EQ.11.OR.K(IM,1).EQ.12.OR.K(IM,1).EQ.15.OR.
74705 & K(IM,1).EQ.51).AND.K(IM,2).NE.94) THEN
74706 ID=IM
74707 GOTO 130
74708 ENDIF
74709 ELSEIF(MEDIT.EQ.14.AND.IM.GT.0.AND.IM.LE.N) THEN
74710 IF(K(IM,1).EQ.13.OR.K(IM,1).EQ.14.OR.K(IM,1).EQ.52.OR.
74711 & K(IM,2).EQ.94) THEN
74712 ID=IM
74713 GOTO 130
74714 ENDIF
74715 ENDIF
74716 K(I,3)=MSTU(5)*(K(I,3)/MSTU(5))
74717 IF(IM.NE.0) K(I,3)=K(I,3)+K(IM,3)/MSTU(5)
74718 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14.AND.
74719 & K(I,1).NE.42.AND.K(I,1).NE.52) THEN
74720 IF(K(I,4).GT.0.AND.K(I,4).LE.MSTU(4)) K(I,4)=
74721 & K(K(I,4),3)/MSTU(5)
74722 IF(K(I,5).GT.0.AND.K(I,5).LE.MSTU(4)) K(I,5)=
74723 & K(K(I,5),3)/MSTU(5)
74724 ELSE
74725 KCM=MOD(K(I,4)/MSTU(5),MSTU(5))
74726 IF(KCM.GT.0.AND.KCM.LE.MSTU(4).AND.K(I,1).NE.42.AND.
74727 & K(I,1).NE.52) KCM=K(KCM,3)/MSTU(5)
74728 KCD=MOD(K(I,4),MSTU(5))
74729 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
74730 K(I,4)=MSTU(5)**2*(K(I,4)/MSTU(5)**2)+MSTU(5)*KCM+KCD
74731 KCM=MOD(K(I,5)/MSTU(5),MSTU(5))
74732 IF(KCM.GT.0.AND.KCM.LE.MSTU(4)) KCM=K(KCM,3)/MSTU(5)
74733 KCD=MOD(K(I,5),MSTU(5))
74734 IF(KCD.GT.0.AND.KCD.LE.MSTU(4)) KCD=K(KCD,3)/MSTU(5)
74735 K(I,5)=MSTU(5)**2*(K(I,5)/MSTU(5)**2)+MSTU(5)*KCM+KCD
74736 ENDIF
74737 140 CONTINUE
74738
74739C...Pack remaining entries.
74740 I1=0
74741 MSTU90=MSTU(90)
74742 MSTU(90)=0
74743 DO 170 I=1,N
74744 IF(K(I,3)/MSTU(5).EQ.0) GOTO 170
74745 I1=I1+1
74746 DO 150 J=1,5
74747 K(I1,J)=K(I,J)
74748 P(I1,J)=P(I,J)
74749 V(I1,J)=V(I,J)
74750 150 CONTINUE
74751C...Also update LHA1 colour tags
74752 MCT(I1,1)=MCT(I,1)
74753 MCT(I1,2)=MCT(I,2)
74754 K(I1,3)=MOD(K(I1,3),MSTU(5))
74755 DO 160 IZ=1,MSTU90
74756 IF(I.EQ.MSTU(90+IZ)) THEN
74757 MSTU(90)=MSTU(90)+1
74758 MSTU(90+MSTU(90))=I1
74759 PARU(90+MSTU(90))=PARU(90+IZ)
74760 ENDIF
74761 160 CONTINUE
74762 170 CONTINUE
74763 IF(I1.LT.N) MSTU(3)=0
74764 IF(I1.LT.N) MSTU(70)=0
74765 N=I1
74766
74767C...Fill in some missing daughter pointers (lost in colour flow).
74768 ELSEIF(MEDIT.EQ.16) THEN
74769 DO 220 I=1,N
74770 IF(K(I,1).LE.10.OR.(K(I,1).GE.21.AND.K(I,1).LE.50)) GOTO 220
74771 IF(K(I,4).NE.0.OR.K(I,5).NE.0) GOTO 220
74772C...Find daughters who point to mother.
74773 DO 180 I1=I+1,N
74774 IF(K(I1,3).NE.I) THEN
74775 ELSEIF(K(I,4).EQ.0) THEN
74776 K(I,4)=I1
74777 ELSE
74778 K(I,5)=I1
74779 ENDIF
74780 180 CONTINUE
74781 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
74782 IF(K(I,4).NE.0) GOTO 220
74783C...Find daughters who point to documentation version of mother.
74784 IM=K(I,3)
74785 IF(IM.LE.0.OR.IM.GE.I) GOTO 220
74786 IF(K(IM,1).LE.20.OR.K(IM,1).GT.30) GOTO 220
74787 IF(K(IM,2).NE.K(I,2).OR.ABS(P(IM,5)-P(I,5)).GT.1D-2) GOTO 220
74788 DO 190 I1=I+1,N
74789 IF(K(I1,3).NE.IM) THEN
74790 ELSEIF(K(I,4).EQ.0) THEN
74791 K(I,4)=I1
74792 ELSE
74793 K(I,5)=I1
74794 ENDIF
74795 190 CONTINUE
74796 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
74797 IF(K(I,4).NE.0) GOTO 220
74798C...Find daughters who point to documentation daughters who,
74799C...in their turn, point to documentation mother.
74800 ID1=IM
74801 ID2=IM
74802 DO 200 I1=IM+1,I-1
74803 IF(K(I1,3).EQ.IM.AND.K(I1,1).GE.21.AND.K(I1,1).LE.30) THEN
74804 ID2=I1
74805 IF(ID1.EQ.IM) ID1=I1
74806 ENDIF
74807 200 CONTINUE
74808 DO 210 I1=I+1,N
74809 IF(K(I1,3).NE.ID1.AND.K(I1,3).NE.ID2) THEN
74810 ELSEIF(K(I,4).EQ.0) THEN
74811 K(I,4)=I1
74812 ELSE
74813 K(I,5)=I1
74814 ENDIF
74815 210 CONTINUE
74816 IF(K(I,5).EQ.0) K(I,5)=K(I,4)
74817 220 CONTINUE
74818
74819C...Save top entries at bottom of PYJETS commonblock.
74820 ELSEIF(MEDIT.EQ.21) THEN
74821 IF(2*N.GE.MSTU(4)) THEN
74822 CALL PYERRM(11,'(PYEDIT:) no more memory left in PYJETS')
74823 RETURN
74824 ENDIF
74825 DO 240 I=1,N
74826 DO 230 J=1,5
74827 K(MSTU(4)-I,J)=K(I,J)
74828 P(MSTU(4)-I,J)=P(I,J)
74829 V(MSTU(4)-I,J)=V(I,J)
74830 230 CONTINUE
74831 240 CONTINUE
74832 MSTU(32)=N
74833
74834C...Restore bottom entries of commonblock PYJETS to top.
74835 ELSEIF(MEDIT.EQ.22) THEN
74836 DO 260 I=1,MSTU(32)
74837 DO 250 J=1,5
74838 K(I,J)=K(MSTU(4)-I,J)
74839 P(I,J)=P(MSTU(4)-I,J)
74840 V(I,J)=V(MSTU(4)-I,J)
74841 250 CONTINUE
74842 260 CONTINUE
74843 N=MSTU(32)
74844
74845C...Mark primary entries at top of commonblock PYJETS as untreated.
74846 ELSEIF(MEDIT.EQ.23) THEN
74847 I1=0
74848 DO 270 I=1,N
74849 KH=K(I,3)
74850 IF(KH.GE.1) THEN
74851 IF(K(KH,1).GE.21.AND.K(KH,1).LE.30) KH=0
74852 ENDIF
74853 IF(KH.NE.0) GOTO 280
74854 I1=I1+1
74855 IF(K(I,1).GE.11.AND.K(I,1).LE.20) K(I,1)=K(I,1)-10
74856 IF(K(I,1).GE.51.AND.K(I,1).LE.60) K(I,1)=K(I,1)-10
74857 270 CONTINUE
74858 280 N=I1
74859
74860C...Place largest axis along z axis and second largest in xy plane.
74861 ELSEIF(MEDIT.EQ.31.OR.MEDIT.EQ.32) THEN
74862 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61),1),
74863 & P(MSTU(61),2)),0D0,0D0,0D0)
74864 CALL PYROBO(1,N+MSTU(3),-PYANGL(P(MSTU(61),3),
74865 & P(MSTU(61),1)),0D0,0D0,0D0,0D0)
74866 CALL PYROBO(1,N+MSTU(3),0D0,-PYANGL(P(MSTU(61)+1,1),
74867 & P(MSTU(61)+1,2)),0D0,0D0,0D0)
74868 IF(MEDIT.EQ.31) RETURN
74869
74870C...Rotate to put slim jet along +z axis.
74871 DO 290 IS=1,2
74872 NS(IS)=0
74873 PTS(IS)=0D0
74874 PLS(IS)=0D0
74875 290 CONTINUE
74876 DO 300 I=1,N
74877 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 300
74878 IF(MSTU(41).GE.2) THEN
74879 KC=PYCOMP(K(I,2))
74880 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74881 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74882 & K(I,2).EQ.KSUSY1+39) GOTO 300
74883 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
74884 & .EQ.0) GOTO 300
74885 ENDIF
74886 IS=2D0-SIGN(0.5D0,P(I,3))
74887 NS(IS)=NS(IS)+1
74888 PTS(IS)=PTS(IS)+SQRT(P(I,1)**2+P(I,2)**2)
74889 300 CONTINUE
74890 IF(NS(1)*PTS(2)**2.LT.NS(2)*PTS(1)**2)
74891 & CALL PYROBO(1,N+MSTU(3),PARU(1),0D0,0D0,0D0,0D0)
74892
74893C...Rotate to put second largest jet into -z,+x quadrant.
74894 DO 310 I=1,N
74895 IF(P(I,3).GE.0D0) GOTO 310
74896 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 310
74897 IF(MSTU(41).GE.2) THEN
74898 KC=PYCOMP(K(I,2))
74899 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
74900 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
74901 & K(I,2).EQ.KSUSY1+39) GOTO 310
74902 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2))
74903 & .EQ.0) GOTO 310
74904 ENDIF
74905 IS=2D0-SIGN(0.5D0,P(I,1))
74906 PLS(IS)=PLS(IS)-P(I,3)
74907 310 CONTINUE
74908 IF(PLS(2).GT.PLS(1)) CALL PYROBO(1,N+MSTU(3),0D0,PARU(1),
74909 & 0D0,0D0,0D0)
74910 ENDIF
74911
74912 RETURN
74913 END
74914
74915C*********************************************************************
74916
74917C...PYLIST
74918C...Gives program heading, or lists an event, or particle
74919C...data, or current parameter values.
74920
74921 SUBROUTINE PYLIST(MLIST)
74922
74923C...Double precision and integer declarations.
74924 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
74925 IMPLICIT INTEGER(I-N)
74926 INTEGER PYK,PYCHGE,PYCOMP
74927C...Parameter statement to help give large particle numbers.
74928 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
74929 &KEXCIT=4000000,KDIMEN=5000000)
74930
74931C...HEPEVT commonblock.
74932 PARAMETER (NMXHEP=4000)
74933 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
74934 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
74935 DOUBLE PRECISION PHEP,VHEP
74936 SAVE /HEPEVT/
74937
74938C...User process event common block.
74939 INTEGER MAXNUP
74940 PARAMETER (MAXNUP=500)
74941 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
74942 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
74943 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
74944 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
74945 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
74946 SAVE /HEPEUP/
74947
74948C...Commonblocks.
74949 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
74950 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
74951 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
74952 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
74953 COMMON/PYCTAG/NCT,MCT(4000,2)
74954 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYCTAG/
74955C...Local arrays, character variables and data.
74956 CHARACTER CHAP*16,CHAC*16,CHAN*16,CHAD(5)*16,CHDL(7)*4
74957 DIMENSION PS(6)
74958 DATA CHDL/'(())',' ','()','!!','<>','==','(==)'/
74959
74960C...Initialization printout: version number and date of last change.
74961 IF(MLIST.EQ.0.OR.MSTU(12).EQ.1) THEN
74962 CALL PYLOGO
74963 MSTU(12)=12345
74964 IF(MLIST.EQ.0) RETURN
74965 ENDIF
74966
74967C...List event data, including additional lines after N.
74968 IF(MLIST.GE.1.AND.MLIST.LE.4) THEN
74969 IF(MLIST.EQ.1) WRITE(MSTU(11),5100)
74970 IF(MLIST.EQ.2) WRITE(MSTU(11),5200)
74971 IF(MLIST.EQ.3) WRITE(MSTU(11),5300)
74972 IF(MLIST.EQ.4) WRITE(MSTU(11),5400)
74973 LMX=12
74974 IF(MLIST.GE.2) LMX=16
74975 ISTR=0
74976 IMAX=N
74977 IF(MSTU(2).GT.0) IMAX=MSTU(2)
74978 DO 120 I=MAX(1,MSTU(1)),MAX(IMAX,N+MAX(0,MSTU(3)))
74979 IF(I.GT.IMAX.AND.I.LE.N) GOTO 120
74980 IF(MSTU(15).EQ.0.AND.K(I,1).LE.0) GOTO 120
74981 IF(MSTU(15).EQ.1.AND.K(I,1).LT.0) GOTO 120
74982
74983C...Get particle name, pad it and check it is not too long.
74984 CALL PYNAME(K(I,2),CHAP)
74985 LEN=0
74986 DO 100 LEM=1,16
74987 IF(CHAP(LEM:LEM).NE.' ') LEN=LEM
74988 100 CONTINUE
74989 MDL=(K(I,1)+19)/10
74990 LDL=0
74991 IF(MDL.EQ.2.OR.MDL.GE.8) THEN
74992 CHAC=CHAP
74993 IF(LEN.GT.LMX) CHAC(LMX:LMX)='?'
74994 ELSE
74995 LDL=1
74996 IF(MDL.EQ.1.OR.MDL.EQ.7) LDL=2
74997 IF(LEN.EQ.0) THEN
74998 CHAC=CHDL(MDL)(1:2*LDL)//' '
74999 ELSE
75000 CHAC=CHDL(MDL)(1:LDL)//CHAP(1:MIN(LEN,LMX-2*LDL))//
75001 & CHDL(MDL)(LDL+1:2*LDL)//' '
75002 IF(LEN+2*LDL.GT.LMX) CHAC(LMX:LMX)='?'
75003 ENDIF
75004 ENDIF
75005
75006C...Add information on string connection.
75007 IF(K(I,1).EQ.1.OR.K(I,1).EQ.2.OR.K(I,1).EQ.11.OR.K(I,1).EQ.12)
75008 & THEN
75009 KC=PYCOMP(K(I,2))
75010 KCC=0
75011 IF(KC.NE.0) KCC=KCHG(KC,2)
75012 IF(IABS(K(I,2)).EQ.39) THEN
75013 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='X'
75014 ELSEIF(KCC.NE.0.AND.ISTR.EQ.0) THEN
75015 ISTR=1
75016 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='A'
75017 ELSEIF(KCC.NE.0.AND.(K(I,1).EQ.2.OR.K(I,1).EQ.12)) THEN
75018 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='I'
75019 ELSEIF(KCC.NE.0) THEN
75020 ISTR=0
75021 IF(LEN+2*LDL+3.LE.LMX) CHAC(LMX-1:LMX-1)='V'
75022 ENDIF
75023 ENDIF
75024 IF((K(I,1).EQ.41.OR.K(I,1).EQ.51).AND.LEN+2*LDL+3.LE.LMX)
75025 & CHAC(LMX-1:LMX-1)='I'
75026
75027C...Write data for particle/jet.
75028 IF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.9999D0) THEN
75029 WRITE(MSTU(11),5500) I,CHAC(1:12),(K(I,J1),J1=1,3),
75030 & (P(I,J2),J2=1,5)
75031 ELSEIF(MLIST.EQ.1.AND.ABS(P(I,4)).LT.99999D0) THEN
75032 WRITE(MSTU(11),5600) I,CHAC(1:12),(K(I,J1),J1=1,3),
75033 & (P(I,J2),J2=1,5)
75034 ELSEIF(MLIST.EQ.1) THEN
75035 WRITE(MSTU(11),5700) I,CHAC(1:12),(K(I,J1),J1=1,3),
75036 & (P(I,J2),J2=1,5)
75037 ELSEIF(MSTU(5).EQ.10000.AND.(K(I,1).EQ.3.OR.K(I,1).EQ.13.OR.
75038 & K(I,1).EQ.14.OR.K(I,1).EQ.42.OR.K(I,1).EQ.52)) THEN
75039 IF(MLIST.NE.4) WRITE(MSTU(11),5800) I,CHAC,(K(I,J1),J1=1,3),
75040 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
75041 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5),10000),
75042 & (P(I,J2),J2=1,5)
75043 IF(MLIST.EQ.4) WRITE(MSTU(11),5900) I,CHAC,(K(I,J1),J1=1,3),
75044 & K(I,4)/100000000,MOD(K(I,4)/10000,10000),MOD(K(I,4),10000),
75045 & K(I,5)/100000000,MOD(K(I,5)/10000,10000),MOD(K(I,5)
75046 & ,10000),MCT(I,1),MCT(I,2)
75047 ELSE
75048 IF(MLIST.NE.4) WRITE(MSTU(11),6000) I,CHAC,(K(I,J1),J1=1,5),
75049 & (P(I,J2),J2=1,5)
75050 IF(MLIST.EQ.4) WRITE(MSTU(11),6100) I,CHAC,(K(I,J1),J1=1,5)
75051 & ,MCT(I,1),MCT(I,2)
75052 ENDIF
75053 IF(MLIST.EQ.3) WRITE(MSTU(11),6200) (V(I,J),J=1,5)
75054
75055C...Insert extra separator lines specified by user.
75056 IF(MSTU(70).GE.1) THEN
75057 ISEP=0
75058 DO 110 J=1,MIN(10,MSTU(70))
75059 IF(I.EQ.MSTU(70+J)) ISEP=1
75060 110 CONTINUE
75061 IF(ISEP.EQ.1) THEN
75062 IF(MLIST.EQ.1) WRITE(MSTU(11),6300)
75063 IF(MLIST.EQ.2.OR.MLIST.EQ.3) WRITE(MSTU(11),6400)
75064 IF(MLIST.EQ.4) WRITE(MSTU(11),6500)
75065 ENDIF
75066 ENDIF
75067 120 CONTINUE
75068
75069C...Sum of charges and momenta.
75070 DO 130 J=1,6
75071 PS(J)=PYP(0,J)
75072 130 CONTINUE
75073 IF(MLIST.EQ.1.AND.ABS(PS(4)).LT.9999D0) THEN
75074 WRITE(MSTU(11),6600) PS(6),(PS(J),J=1,5)
75075 ELSEIF(MLIST.EQ.1.AND.ABS(PS(4)).LT.99999D0) THEN
75076 WRITE(MSTU(11),6700) PS(6),(PS(J),J=1,5)
75077 ELSEIF(MLIST.EQ.1) THEN
75078 WRITE(MSTU(11),6800) PS(6),(PS(J),J=1,5)
75079 ELSEIF(MLIST.LE.3) THEN
75080 WRITE(MSTU(11),6900) PS(6),(PS(J),J=1,5)
75081 ELSE
75082 WRITE(MSTU(11),7000) PS(6)
75083 ENDIF
75084
75085C...Simple listing of HEPEVT entries (mainly for test purposes).
75086 ELSEIF(MLIST.EQ.5) THEN
75087 WRITE(MSTU(11),7100)
75088 DO 140 I=1,NHEP
75089 IF(ISTHEP(I).EQ.0) GOTO 140
75090 WRITE(MSTU(11),7200) I,ISTHEP(I),IDHEP(I),JMOHEP(1,I),
75091 & JMOHEP(2,I),JDAHEP(1,I),JDAHEP(2,I),(PHEP(J,I),J=1,5)
75092 140 CONTINUE
75093
75094
75095C...Simple listing of user-process entries (mainly for test purposes).
75096 ELSEIF(MLIST.EQ.7) THEN
75097 WRITE(MSTU(11),7300)
75098 DO 150 I=1,NUP
75099 WRITE(MSTU(11),7400) I,ISTUP(I),IDUP(I),MOTHUP(1,I),
75100 & MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),(PUP(J,I),J=1,5)
75101 150 CONTINUE
75102
75103C...Give simple list of KF codes defined in program.
75104 ELSEIF(MLIST.EQ.11) THEN
75105 WRITE(MSTU(11),7500)
75106 DO 160 KF=1,80
75107 CALL PYNAME(KF,CHAP)
75108 CALL PYNAME(-KF,CHAN)
75109 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
75110 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
75111 160 CONTINUE
75112 DO 190 KFLS=1,3,2
75113 DO 180 KFLA=1,5
75114 DO 170 KFLB=1,KFLA-(3-KFLS)/2
75115 KF=1000*KFLA+100*KFLB+KFLS
75116 CALL PYNAME(KF,CHAP)
75117 CALL PYNAME(-KF,CHAN)
75118 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
75119 170 CONTINUE
75120 180 CONTINUE
75121 190 CONTINUE
75122 DO 220 KMUL=0,5
75123 KFLS=3
75124 IF(KMUL.EQ.0.OR.KMUL.EQ.3) KFLS=1
75125 IF(KMUL.EQ.5) KFLS=5
75126 KFLR=0
75127 IF(KMUL.EQ.2.OR.KMUL.EQ.3) KFLR=1
75128 IF(KMUL.EQ.4) KFLR=2
75129 DO 210 KFLB=1,5
75130 DO 200 KFLC=1,KFLB-1
75131 KF=10000*KFLR+100*KFLB+10*KFLC+KFLS
75132 CALL PYNAME(KF,CHAP)
75133 CALL PYNAME(-KF,CHAN)
75134 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
75135 IF(KF.EQ.311) THEN
75136 KFK=130
75137 CALL PYNAME(KFK,CHAP)
75138 WRITE(MSTU(11),7600) KFK,CHAP
75139 KFK=310
75140 CALL PYNAME(KFK,CHAP)
75141 WRITE(MSTU(11),7600) KFK,CHAP
75142 ENDIF
75143 200 CONTINUE
75144 KF=10000*KFLR+110*KFLB+KFLS
75145 CALL PYNAME(KF,CHAP)
75146 WRITE(MSTU(11),7600) KF,CHAP
75147 210 CONTINUE
75148 220 CONTINUE
75149 KF=100443
75150 CALL PYNAME(KF,CHAP)
75151 WRITE(MSTU(11),7600) KF,CHAP
75152 KF=100553
75153 CALL PYNAME(KF,CHAP)
75154 WRITE(MSTU(11),7600) KF,CHAP
75155 DO 260 KFLSP=1,3
75156 KFLS=2+2*(KFLSP/3)
75157 DO 250 KFLA=1,5
75158 DO 240 KFLB=1,KFLA
75159 DO 230 KFLC=1,KFLB
75160 IF(KFLSP.EQ.1.AND.(KFLA.EQ.KFLB.OR.KFLB.EQ.KFLC))
75161 & GOTO 230
75162 IF(KFLSP.EQ.2.AND.KFLA.EQ.KFLC) GOTO 230
75163 IF(KFLSP.EQ.1) KF=1000*KFLA+100*KFLC+10*KFLB+KFLS
75164 IF(KFLSP.GE.2) KF=1000*KFLA+100*KFLB+10*KFLC+KFLS
75165 CALL PYNAME(KF,CHAP)
75166 CALL PYNAME(-KF,CHAN)
75167 WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
75168 230 CONTINUE
75169 240 CONTINUE
75170 250 CONTINUE
75171 260 CONTINUE
75172 DO 270 KC=1,500
75173 KF=KCHG(KC,4)
75174 IF(KF.LT.1000000) GOTO 270
75175 CALL PYNAME(KF,CHAP)
75176 CALL PYNAME(-KF,CHAN)
75177 IF(CHAP.NE.' '.AND.CHAN.EQ.' ') WRITE(MSTU(11),7600) KF,CHAP
75178 IF(CHAN.NE.' ') WRITE(MSTU(11),7600) KF,CHAP,-KF,CHAN
75179 270 CONTINUE
75180
75181C...List parton/particle data table. Check whether to be listed.
75182 ELSEIF(MLIST.EQ.12) THEN
75183 WRITE(MSTU(11),7700)
75184 DO 300 KC=1,MSTU(6)
75185 KF=KCHG(KC,4)
75186 IF(KF.EQ.0) GOTO 300
75187 IF(KF.LT.MSTU(1).OR.(MSTU(2).GT.0.AND.KF.GT.MSTU(2)))
75188 & GOTO 300
75189
75190C...Find particle name and mass. Print information.
75191 CALL PYNAME(KF,CHAP)
75192 IF(KF.LE.100.AND.CHAP.EQ.' '.AND.MDCY(KC,2).EQ.0) GOTO 300
75193 CALL PYNAME(-KF,CHAN)
75194 WRITE(MSTU(11),7800) KF,KC,CHAP,CHAN,(KCHG(KC,J1),J1=1,3),
75195 & (PMAS(KC,J2),J2=1,4),MDCY(KC,1)
75196
75197C...Particle decay: channel number, branching ratios, matrix element,
75198C...decay products.
75199 DO 290 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
75200 DO 280 J=1,5
75201 CALL PYNAME(KFDP(IDC,J),CHAD(J))
75202 280 CONTINUE
75203 WRITE(MSTU(11),7900) IDC,MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
75204 & (CHAD(J),J=1,5)
75205 290 CONTINUE
75206 300 CONTINUE
75207
75208C...List parameter value table.
75209 ELSEIF(MLIST.EQ.13) THEN
75210 WRITE(MSTU(11),8000)
75211 DO 310 I=1,200
75212 WRITE(MSTU(11),8100) I,MSTU(I),PARU(I),MSTJ(I),PARJ(I),PARF(I)
75213 310 CONTINUE
75214 ENDIF
75215
75216C...Format statements for output on unit MSTU(11) (by default 6).
75217 5100 FORMAT(///28X,'Event listing (summary)'//4X,'I particle/jet KS',
75218 &5X,'KF orig p_x p_y p_z E m'/)
75219 5200 FORMAT(///28X,'Event listing (standard)'//4X,'I particle/jet',
75220 &' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
75221 &' P(I,2) P(I,3) P(I,4) P(I,5)'/)
75222 5300 FORMAT(///28X,'Event listing (with vertices)'//4X,'I particle/j',
75223 &'et K(I,1) K(I,2) K(I,3) K(I,4) K(I,5) P(I,1)',
75224 &' P(I,2) P(I,3) P(I,4) P(I,5)'/73X,
75225 &'V(I,1) V(I,2) V(I,3) V(I,4) V(I,5)'/)
75226 5400 FORMAT(///28X,'Event listing (no momenta)'//4X,'I particle/jet',
75227 & ' K(I,1) K(I,2) K(I,3) K(I,4) K(I,5)',1X
75228 & ,' C tag AC tag'/)
75229 5500 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.3)
75230 5600 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.2)
75231 5700 FORMAT(1X,I4,1X,A12,1X,I2,I8,1X,I4,5F9.1)
75232 5800 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),5F13.5)
75233 5900 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I1,2I4),1X,2I8)
75234 6000 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),5F13.5)
75235 6100 FORMAT(1X,I4,2X,A16,1X,I3,1X,I9,1X,I4,2(3X,I9),1X,2I8)
75236 6200 FORMAT(66X,5(1X,F12.3))
75237 6300 FORMAT(1X,78('='))
75238 6400 FORMAT(1X,130('='))
75239 6500 FORMAT(1X,65('='))
75240 6600 FORMAT(19X,'sum:',F6.2,5X,5F9.3)
75241 6700 FORMAT(19X,'sum:',F6.2,5X,5F9.2)
75242 6800 FORMAT(19X,'sum:',F6.2,5X,5F9.1)
75243 6900 FORMAT(19X,'sum charge:',F6.2,3X,'sum momentum and inv. mass:',
75244 &5F13.5)
75245 7000 FORMAT(19X,'sum charge:',F6.2)
75246 7100 FORMAT(/10X,'Event listing of HEPEVT common block (simplified)'
75247 &//' I IST ID Mothers Daughters p_x p_y p_z',
75248 &' E m')
75249 7200 FORMAT(1X,I4,I2,I8,4I5,5F9.3)
75250 7300 FORMAT(/10X,'Event listing of user process at input (simplified)'
75251 &//' I IST ID Mothers Colours p_x p_y p_z',
75252 &' E m')
75253 7400 FORMAT(1X,I3,I3,I8,2I4,2I5,5F9.3)
75254 7500 FORMAT(///20X,'List of KF codes in program'/)
75255 7600 FORMAT(4X,I9,4X,A16,6X,I9,4X,A16)
75256 7700 FORMAT(///30X,'Particle/parton data table'//8X,'KF',5X,'KC',4X,
75257 &'particle',8X,'antiparticle',6X,'chg col anti',8X,'mass',7X,
75258 &'width',7X,'w-cut',5X,'lifetime',1X,'decay'/11X,'IDC',1X,'on/off',
75259 &1X,'ME',3X,'Br.rat.',4X,'decay products')
75260 7800 FORMAT(/1X,I9,3X,I4,4X,A16,A16,3I5,1X,F12.5,2(1X,F11.5),
75261 &1X,1P,E13.5,3X,I2)
75262 7900 FORMAT(10X,I4,2X,I3,2X,I3,2X,F10.6,4X,5A16)
75263 8000 FORMAT(///20X,'Parameter value table'//4X,'I',3X,'MSTU(I)',
75264 &8X,'PARU(I)',3X,'MSTJ(I)',8X,'PARJ(I)',8X,'PARF(I)')
75265 8100 FORMAT(1X,I4,1X,I9,1X,F14.5,1X,I9,1X,F14.5,1X,F14.5)
75266
75267 RETURN
75268 END
75269
75270C*********************************************************************
75271
75272C...PYLOGO
75273C...Writes a logo for the program.
75274
75275 SUBROUTINE PYLOGO
75276
75277C...Double precision and integer declarations.
75278 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75279 IMPLICIT INTEGER(I-N)
75280 INTEGER PYK,PYCHGE,PYCOMP
75281C...Parameter for length of information block.
75282 PARAMETER (IREFER=19)
75283C...Commonblocks.
75284 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75285 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
75286 SAVE /PYDAT1/,/PYPARS/
75287C...Local arrays and character variables.
75288 INTEGER IDATI(6)
75289 CHARACTER MONTH(12)*3, LOGO(48)*32, REFER(2*IREFER)*36, LINE*79,
75290 &VERS*1, SUBV*3, DATE*2, YEAR*4, HOUR*2, MINU*2, SECO*2
75291
75292C...Data on months, logo, titles, and references.
75293 DATA MONTH/'Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep',
75294 &'Oct','Nov','Dec'/
75295 DATA (LOGO(J),J=1,19)/
75296 &' *......* ',
75297 &' *:::!!:::::::::::* ',
75298 &' *::::::!!::::::::::::::* ',
75299 &' *::::::::!!::::::::::::::::* ',
75300 &' *:::::::::!!:::::::::::::::::* ',
75301 &' *:::::::::!!:::::::::::::::::* ',
75302 &' *::::::::!!::::::::::::::::*! ',
75303 &' *::::::!!::::::::::::::* !! ',
75304 &' !! *:::!!:::::::::::* !! ',
75305 &' !! !* -><- * !! ',
75306 &' !! !! !! ',
75307 &' !! !! !! ',
75308 &' !! !! ',
75309 &' !! lh !! ',
75310 &' !! !! ',
75311 &' !! hh !! ',
75312 &' !! ll !! ',
75313 &' !! !! ',
75314 &' !! '/
75315 DATA (LOGO(J),J=20,38)/
75316 &'Welcome to the Lund Monte Carlo!',
75317 &' ',
75318 &'PPP Y Y TTTTT H H III A ',
75319 &'P P Y Y T H H I A A ',
75320 &'PPP Y T HHHHH I AAAAA',
75321 &'P Y T H H I A A',
75322 &'P Y T H H III A A',
75323 &' ',
75324 &'This is PYTHIA version x.xxx ',
75325 &'Last date of change: xx xxx 201x',
75326 &' ',
75327 &'Now is xx xxx 201x at xx:xx:xx ',
75328 &' ',
75329 &'Disclaimer: this program comes ',
75330 &'without any guarantees. Beware ',
75331 &'of errors and use common sense ',
75332 &'when interpreting results. ',
75333 &' ',
75334 &'Copyright T. Sjostrand (2011) '/
75335 DATA (REFER(J),J=1,14)/
75336 &'An archive of program versions and d',
75337 &'ocumentation is found on the web: ',
75338 &'http://www.thep.lu.se/~torbjorn/Pyth',
75339 &'ia.html ',
75340 &' ',
75341 &' ',
75342 &'When you cite this program, the offi',
75343 &'cial reference is to the 6.4 manual:',
75344 &'T. Sjostrand, S. Mrenna and P. Skand',
75345 &'s, JHEP05 (2006) 026 ',
75346 &'(LU TP 06-13, FERMILAB-PUB-06-052-CD',
75347 &'-T) [hep-ph/0603175]. ',
75348 &' ',
75349 &' '/
75350 DATA (REFER(J),J=15,32)/
75351 &'Also remember that the program, to a',
75352 &' large extent, represents original ',
75353 &'physics research. Other publications',
75354 &' of special relevance to your ',
75355 &'studies may therefore deserve separa',
75356 &'te mention. ',
75357 &' ',
75358 &' ',
75359 &'Main author: Torbjorn Sjostrand; Dep',
75360 &'artment of Theoretical Physics, ',
75361 &' Lund University, Solvegatan 14A, S',
75362 &'-223 62 Lund, Sweden; ',
75363 &' phone: + 46 - 46 - 222 48 16; e-ma',
75364 &'il: torbjorn@thep.lu.se ',
75365 &'Author: Stephen Mrenna; Computing Di',
75366 &'vision, GDS Group, ',
75367 &' Fermi National Accelerator Laborat',
75368 &'ory, MS 234, Batavia, IL 60510, USA;'/
75369 DATA (REFER(J),J=33,2*IREFER)/
75370 &' phone: + 1 - 630 - 840 - 2556; e-m',
75371 &'ail: mrenna@fnal.gov ',
75372 &'Author: Peter Skands; CERN/PH-TH, CH',
75373 &'-1211 Geneva, Switzerland ',
75374 &' phone: + 41 - 22 - 767 24 47; e-ma',
75375 &'il: peter.skands@cern.ch '/
75376
75377C...Check that PYDATA linked (check we are in the year 20xx)
75378 IF(MSTP(183)/100.NE.20) THEN
75379 WRITE(*,'(1X,A)')
75380 & 'Error: PYDATA has not been linked.'
75381 WRITE(*,'(1X,A)') 'Execution stopped!'
75382 CALL PYSTOP(8)
75383
75384C...Write current version number and current date+time.
75385 ELSE
75386 WRITE(VERS,'(I1)') MSTP(181)
75387 LOGO(28)(24:24)=VERS
75388 WRITE(SUBV,'(I3)') MSTP(182)
75389 LOGO(28)(26:28)=SUBV
75390 IF(MSTP(182).LT.100) LOGO(28)(26:26)='0'
75391 WRITE(DATE,'(I2)') MSTP(185)
75392 LOGO(29)(22:23)=DATE
75393 LOGO(29)(25:27)=MONTH(MSTP(184))
75394 WRITE(YEAR,'(I4)') MSTP(183)
75395 LOGO(29)(29:32)=YEAR
75396 CALL PYTIME(IDATI)
75397 IF(IDATI(1).LE.0) THEN
75398 LOGO(31)=' '
75399 ELSE
75400 WRITE(DATE,'(I2)') IDATI(3)
75401 LOGO(31)(8:9)=DATE
75402 LOGO(31)(11:13)=MONTH(MAX(1,MIN(12,IDATI(2))))
75403 WRITE(YEAR,'(I4)') IDATI(1)
75404 LOGO(31)(15:18)=YEAR
75405 WRITE(HOUR,'(I2)') IDATI(4)
75406 LOGO(31)(23:24)=HOUR
75407 WRITE(MINU,'(I2)') IDATI(5)
75408 LOGO(31)(26:27)=MINU
75409 IF(IDATI(5).LT.10) LOGO(31)(26:26)='0'
75410 WRITE(SECO,'(I2)') IDATI(6)
75411 LOGO(31)(29:30)=SECO
75412 IF(IDATI(6).LT.10) LOGO(31)(29:29)='0'
75413 ENDIF
75414 ENDIF
75415
75416C...Loop over lines in header. Define page feed and side borders.
75417 DO 100 ILIN=1,29+IREFER
75418 LINE=' '
75419 IF(ILIN.EQ.1) THEN
75420 LINE(1:1)='1'
75421 ELSE
75422 LINE(2:3)='**'
75423 LINE(78:79)='**'
75424 ENDIF
75425
75426C...Separator lines and logos.
75427 IF(ILIN.EQ.2.OR.ILIN.EQ.3.OR.ILIN.GE.28+IREFER) THEN
75428 LINE(4:77)='***********************************************'//
75429 & '***************************'
75430 ELSEIF(ILIN.GE.6.AND.ILIN.LE.24) THEN
75431 LINE(6:37)=LOGO(ILIN-5)
75432 LINE(44:75)=LOGO(ILIN+14)
75433 ELSEIF(ILIN.GE.26.AND.ILIN.LE.25+IREFER) THEN
75434 LINE(5:40)=REFER(2*ILIN-51)
75435 LINE(41:76)=REFER(2*ILIN-50)
75436 ENDIF
75437
75438C...Write lines to appropriate unit.
75439 WRITE(MSTU(11),'(A79)') LINE
75440 100 CONTINUE
75441
75442 RETURN
75443 END
75444
75445C*********************************************************************
75446
75447C...PYUPDA
75448C...Facilitates the updating of particle and decay data
75449C...by allowing it to be done in an external file.
75450
75451 SUBROUTINE PYUPDA(MUPDA,LFN)
75452
75453C...Double precision and integer declarations.
75454 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75455 IMPLICIT INTEGER(I-N)
75456 INTEGER PYK,PYCHGE,PYCOMP
75457C...Commonblocks.
75458 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75459 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75460 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
75461 COMMON/PYDAT4/CHAF(500,2)
75462 CHARACTER CHAF*16
75463 COMMON/PYINT4/MWID(500),WIDS(500,5)
75464 SAVE /PYDAT1/,/PYDAT2/,/PYDAT3/,/PYDAT4/,/PYINT4/
75465C...Local arrays, character variables and data.
75466 CHARACTER CHINL*120,CHKF*9,CHVAR(22)*9,CHLIN*72,
75467 &CHBLK(20)*72,CHOLD*16,CHTMP*16,CHNEW*16,CHCOM*24
75468 DATA CHVAR/ 'KCHG(I,1)','KCHG(I,2)','KCHG(I,3)','KCHG(I,4)',
75469 &'PMAS(I,1)','PMAS(I,2)','PMAS(I,3)','PMAS(I,4)','MDCY(I,1)',
75470 &'MDCY(I,2)','MDCY(I,3)','MDME(I,1)','MDME(I,2)','BRAT(I) ',
75471 &'KFDP(I,1)','KFDP(I,2)','KFDP(I,3)','KFDP(I,4)','KFDP(I,5)',
75472 &'CHAF(I,1)','CHAF(I,2)','MWID(I) '/
75473
75474C...Write header if not yet done.
75475 IF(MSTU(12).NE.12345) CALL PYLIST(0)
75476
75477C...Write information on file for editing.
75478 IF(MUPDA.EQ.1) THEN
75479 DO 110 KC=1,500
75480 WRITE(LFN,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
75481 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
75482 & MWID(KC),MDCY(KC,1)
75483 DO 100 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
75484 WRITE(LFN,5100) MDME(IDC,1),MDME(IDC,2),BRAT(IDC),
75485 & (KFDP(IDC,J),J=1,5)
75486 100 CONTINUE
75487 110 CONTINUE
75488
75489C...Read complete set of information from edited file or
75490C...read partial set of new or updated information from edited file.
75491 ELSEIF(MUPDA.EQ.2.OR.MUPDA.EQ.3) THEN
75492
75493C...Reset counters.
75494 KCC=100
75495 NDC=0
75496 CHKF=' '
75497 IF(MUPDA.EQ.2) THEN
75498 DO 120 I=1,MSTU(6)
75499 KCHG(I,4)=0
75500 120 CONTINUE
75501 ELSE
75502 DO 130 KC=1,MSTU(6)
75503 IF(KC.GT.100.AND.KCHG(KC,4).GT.100) KCC=KC
75504 NDC=MAX(NDC,MDCY(KC,2)+MDCY(KC,3)-1)
75505 130 CONTINUE
75506 ENDIF
75507
75508C...Begin of loop: read new line; unknown whether particle or
75509C...decay data.
75510 140 READ(LFN,5200,END=190) CHINL
75511
75512C...Identify particle code and whether already defined (for MUPDA=3).
75513 IF(CHINL(2:10).NE.' ') THEN
75514 CHKF=CHINL(2:10)
75515 READ(CHKF,5300) KF
75516 IF(MUPDA.EQ.2) THEN
75517 IF(KF.LE.100) THEN
75518 KC=KF
75519 ELSE
75520 KCC=KCC+1
75521 KC=KCC
75522 ENDIF
75523 ELSE
75524 KCREP=0
75525 IF(KF.LE.100) THEN
75526 KCREP=KF
75527 ELSE
75528 DO 150 KCR=101,KCC
75529 IF(KCHG(KCR,4).EQ.KF) KCREP=KCR
75530 150 CONTINUE
75531 ENDIF
75532C...Remove duplicate old decay data.
75533 IF(KCREP.NE.0.AND.MDCY(KCREP,3).GT.0) THEN
75534 IDCREP=MDCY(KCREP,2)
75535 NDCREP=MDCY(KCREP,3)
75536 DO 160 I=1,KCC
75537 IF(MDCY(I,2).GT.IDCREP) MDCY(I,2)=MDCY(I,2)-NDCREP
75538 160 CONTINUE
75539 DO 180 I=IDCREP,NDC-NDCREP
75540 MDME(I,1)=MDME(I+NDCREP,1)
75541 MDME(I,2)=MDME(I+NDCREP,2)
75542 BRAT(I)=BRAT(I+NDCREP)
75543 DO 170 J=1,5
75544 KFDP(I,J)=KFDP(I+NDCREP,J)
75545 170 CONTINUE
75546 180 CONTINUE
75547 NDC=NDC-NDCREP
75548 KC=KCREP
75549 ELSEIF(KCREP.NE.0) THEN
75550 KC=KCREP
75551 ELSE
75552 KCC=KCC+1
75553 KC=KCC
75554 ENDIF
75555 ENDIF
75556
75557C...Study line with particle data.
75558 IF(KC.GT.MSTU(6)) CALL PYERRM(27,
75559 & '(PYUPDA:) Particle arrays full by KF ='//CHKF)
75560 READ(CHINL,5000) KCHG(KC,4),(CHAF(KC,J1),J1=1,2),
75561 & (KCHG(KC,J2),J2=1,3),(PMAS(KC,J3),J3=1,4),
75562 & MWID(KC),MDCY(KC,1)
75563 MDCY(KC,2)=0
75564 MDCY(KC,3)=0
75565
75566C...Study line with decay data.
75567 ELSE
75568 NDC=NDC+1
75569 IF(NDC.GT.MSTU(7)) CALL PYERRM(27,
75570 & '(PYUPDA:) Decay data arrays full by KF ='//CHKF)
75571 IF(MDCY(KC,2).EQ.0) MDCY(KC,2)=NDC
75572 MDCY(KC,3)=MDCY(KC,3)+1
75573 READ(CHINL,5100) MDME(NDC,1),MDME(NDC,2),BRAT(NDC),
75574 & (KFDP(NDC,J),J=1,5)
75575 ENDIF
75576
75577C...End of loop; ensure that PYCOMP tables are updated.
75578 GOTO 140
75579 190 CONTINUE
75580 MSTU(20)=0
75581
75582C...Perform possible tests that new information is consistent.
75583 DO 220 KC=1,MSTU(6)
75584 KF=KCHG(KC,4)
75585 IF(KF.EQ.0) GOTO 220
75586 WRITE(CHKF,5300) KF
75587 IF(MIN(PMAS(KC,1),PMAS(KC,2),PMAS(KC,3),PMAS(KC,1)-PMAS(KC,3),
75588 & PMAS(KC,4)).LT.0D0.OR.MDCY(KC,3).LT.0) CALL PYERRM(17,
75589 & '(PYUPDA:) Mass/width/life/(# channels) wrong for KF ='//CHKF)
75590 BRSUM=0D0
75591 DO 210 IDC=MDCY(KC,2),MDCY(KC,2)+MDCY(KC,3)-1
75592 IF(MDME(IDC,2).GT.80) GOTO 210
75593 KQ=KCHG(KC,1)
75594 PMS=PMAS(KC,1)-PMAS(KC,3)-PARJ(64)
75595 MERR=0
75596 DO 200 J=1,5
75597 KP=KFDP(IDC,J)
75598 IF(KP.EQ.0.OR.KP.EQ.81.OR.IABS(KP).EQ.82) THEN
75599 IF(KP.EQ.81) KQ=0
75600 ELSEIF(PYCOMP(KP).EQ.0) THEN
75601 MERR=3
75602 ELSE
75603 KQ=KQ-PYCHGE(KP)
75604 KPC=PYCOMP(KP)
75605 PMS=PMS-PMAS(KPC,1)
75606 IF(MSTJ(24).GT.0) PMS=PMS+0.5D0*MIN(PMAS(KPC,2),
75607 & PMAS(KPC,3))
75608 ENDIF
75609 200 CONTINUE
75610 IF(KQ.NE.0) MERR=MAX(2,MERR)
75611 IF(MWID(KC).EQ.0.AND.KF.NE.311.AND.PMS.LT.0D0)
75612 & MERR=MAX(1,MERR)
75613 IF(MERR.EQ.3) CALL PYERRM(17,
75614 & '(PYUPDA:) Unknown particle code in decay of KF ='//CHKF)
75615 IF(MERR.EQ.2) CALL PYERRM(17,
75616 & '(PYUPDA:) Charge not conserved in decay of KF ='//CHKF)
75617 IF(MERR.EQ.1) CALL PYERRM(7,
75618 & '(PYUPDA:) Kinematically unallowed decay of KF ='//CHKF)
75619 BRSUM=BRSUM+BRAT(IDC)
75620 210 CONTINUE
75621 WRITE(CHTMP,5500) BRSUM
75622 IF(ABS(BRSUM).GT.0.0005D0.AND.ABS(BRSUM-1D0).GT.0.0005D0)
75623 & CALL PYERRM(7,'(PYUPDA:) Sum of branching ratios is '//
75624 & CHTMP(9:16)//' for KF ='//CHKF)
75625 220 CONTINUE
75626
75627C...Write DATA statements for inclusion in program.
75628 ELSEIF(MUPDA.EQ.4) THEN
75629
75630C...Find out how many codes and decay channels are actually used.
75631 KCC=0
75632 NDC=0
75633 DO 230 I=1,MSTU(6)
75634 IF(KCHG(I,4).NE.0) THEN
75635 KCC=I
75636 NDC=MAX(NDC,MDCY(I,2)+MDCY(I,3)-1)
75637 ENDIF
75638 230 CONTINUE
75639
75640C...Initialize writing of DATA statements for inclusion in program.
75641 DO 300 IVAR=1,22
75642 NDIM=MSTU(6)
75643 IF(IVAR.GE.12.AND.IVAR.LE.19) NDIM=MSTU(7)
75644 NLIN=1
75645 CHLIN=' '
75646 CHLIN(7:35)='DATA ('//CHVAR(IVAR)//',I= 1, )/'
75647 LLIN=35
75648 CHOLD='START'
75649
75650C...Loop through variables for conversion to characters.
75651 DO 280 IDIM=1,NDIM
75652 IF(IVAR.EQ.1) WRITE(CHTMP,5400) KCHG(IDIM,1)
75653 IF(IVAR.EQ.2) WRITE(CHTMP,5400) KCHG(IDIM,2)
75654 IF(IVAR.EQ.3) WRITE(CHTMP,5400) KCHG(IDIM,3)
75655 IF(IVAR.EQ.4) WRITE(CHTMP,5400) KCHG(IDIM,4)
75656 IF(IVAR.EQ.5) WRITE(CHTMP,5500) PMAS(IDIM,1)
75657 IF(IVAR.EQ.6) WRITE(CHTMP,5500) PMAS(IDIM,2)
75658 IF(IVAR.EQ.7) WRITE(CHTMP,5500) PMAS(IDIM,3)
75659 IF(IVAR.EQ.8) WRITE(CHTMP,5500) PMAS(IDIM,4)
75660 IF(IVAR.EQ.9) WRITE(CHTMP,5400) MDCY(IDIM,1)
75661 IF(IVAR.EQ.10) WRITE(CHTMP,5400) MDCY(IDIM,2)
75662 IF(IVAR.EQ.11) WRITE(CHTMP,5400) MDCY(IDIM,3)
75663 IF(IVAR.EQ.12) WRITE(CHTMP,5400) MDME(IDIM,1)
75664 IF(IVAR.EQ.13) WRITE(CHTMP,5400) MDME(IDIM,2)
75665 IF(IVAR.EQ.14) WRITE(CHTMP,5600) BRAT(IDIM)
75666 IF(IVAR.EQ.15) WRITE(CHTMP,5400) KFDP(IDIM,1)
75667 IF(IVAR.EQ.16) WRITE(CHTMP,5400) KFDP(IDIM,2)
75668 IF(IVAR.EQ.17) WRITE(CHTMP,5400) KFDP(IDIM,3)
75669 IF(IVAR.EQ.18) WRITE(CHTMP,5400) KFDP(IDIM,4)
75670 IF(IVAR.EQ.19) WRITE(CHTMP,5400) KFDP(IDIM,5)
75671 IF(IVAR.EQ.20) CHTMP=CHAF(IDIM,1)
75672 IF(IVAR.EQ.21) CHTMP=CHAF(IDIM,2)
75673 IF(IVAR.EQ.22) WRITE(CHTMP,5400) MWID(IDIM)
75674
75675C...Replace variables beyond what is properly defined.
75676 IF(IVAR.LE.4) THEN
75677 IF(IDIM.GT.KCC) CHTMP=' 0'
75678 ELSEIF(IVAR.LE.8) THEN
75679 IF(IDIM.GT.KCC) CHTMP=' 0.0'
75680 ELSEIF(IVAR.LE.11) THEN
75681 IF(IDIM.GT.KCC) CHTMP=' 0'
75682 ELSEIF(IVAR.LE.13) THEN
75683 IF(IDIM.GT.NDC) CHTMP=' 0'
75684 ELSEIF(IVAR.LE.14) THEN
75685 IF(IDIM.GT.NDC) CHTMP=' 0.0'
75686 ELSEIF(IVAR.LE.19) THEN
75687 IF(IDIM.GT.NDC) CHTMP=' 0'
75688 ELSEIF(IVAR.LE.21) THEN
75689 IF(IDIM.GT.KCC) CHTMP=' '
75690 ELSE
75691 IF(IDIM.GT.KCC) CHTMP=' 0'
75692 ENDIF
75693
75694C...Length of variable, trailing decimal zeros, quotation marks.
75695 LLOW=1
75696 LHIG=1
75697 DO 240 LL=1,16
75698 IF(CHTMP(17-LL:17-LL).NE.' ') LLOW=17-LL
75699 IF(CHTMP(LL:LL).NE.' ') LHIG=LL
75700 240 CONTINUE
75701 CHNEW=CHTMP(LLOW:LHIG)//' '
75702 LNEW=1+LHIG-LLOW
75703 IF((IVAR.GE.5.AND.IVAR.LE.8).OR.IVAR.EQ.14) THEN
75704 LNEW=LNEW+1
75705 250 LNEW=LNEW-1
75706 IF(LNEW.GE.2.AND.CHNEW(LNEW:LNEW).EQ.'0') GOTO 250
75707 IF(CHNEW(LNEW:LNEW).EQ.'.') LNEW=LNEW-1
75708 IF(LNEW.EQ.0) THEN
75709 CHNEW(1:3)='0D0'
75710 LNEW=3
75711 ELSE
75712 CHNEW(LNEW+1:LNEW+2)='D0'
75713 LNEW=LNEW+2
75714 ENDIF
75715 ELSEIF(IVAR.EQ.20.OR.IVAR.EQ.21) THEN
75716 DO 260 LL=LNEW,1,-1
75717 IF(CHNEW(LL:LL).EQ.'''') THEN
75718 CHTMP=CHNEW
75719 CHNEW=CHTMP(1:LL)//''''//CHTMP(LL+1:11)
75720 LNEW=LNEW+1
75721 ENDIF
75722 260 CONTINUE
75723 LNEW=MIN(14,LNEW)
75724 CHTMP=CHNEW
75725 CHNEW(1:LNEW+2)=''''//CHTMP(1:LNEW)//''''
75726 LNEW=LNEW+2
75727 ENDIF
75728
75729C...Form composite character string, often including repetition counter.
75730 IF(CHNEW.NE.CHOLD) THEN
75731 NRPT=1
75732 CHOLD=CHNEW
75733 CHCOM=CHNEW
75734 LCOM=LNEW
75735 ELSE
75736 LRPT=LNEW+1
75737 IF(NRPT.GE.2) LRPT=LNEW+3
75738 IF(NRPT.GE.10) LRPT=LNEW+4
75739 IF(NRPT.GE.100) LRPT=LNEW+5
75740 IF(NRPT.GE.1000) LRPT=LNEW+6
75741 LLIN=LLIN-LRPT
75742 NRPT=NRPT+1
75743 WRITE(CHTMP,5400) NRPT
75744 LRPT=1
75745 IF(NRPT.GE.10) LRPT=2
75746 IF(NRPT.GE.100) LRPT=3
75747 IF(NRPT.GE.1000) LRPT=4
75748 CHCOM(1:LRPT+1+LNEW)=CHTMP(17-LRPT:16)//'*'//CHNEW(1:LNEW)
75749 LCOM=LRPT+1+LNEW
75750 ENDIF
75751
75752C...Add characters to end of line, to new line (after storing old line),
75753C...or to new block of lines (after writing old block).
75754 IF(LLIN+LCOM.LE.70) THEN
75755 CHLIN(LLIN+1:LLIN+LCOM+1)=CHCOM(1:LCOM)//','
75756 LLIN=LLIN+LCOM+1
75757 ELSEIF(NLIN.LE.19) THEN
75758 CHLIN(LLIN+1:72)=' '
75759 CHBLK(NLIN)=CHLIN
75760 NLIN=NLIN+1
75761 CHLIN(6:6+LCOM+1)='&'//CHCOM(1:LCOM)//','
75762 LLIN=6+LCOM+1
75763 ELSE
75764 CHLIN(LLIN:72)='/'//' '
75765 CHBLK(NLIN)=CHLIN
75766 WRITE(CHTMP,5400) IDIM-NRPT
75767 CHBLK(1)(30:33)=CHTMP(13:16)
75768 DO 270 ILIN=1,NLIN
75769 WRITE(LFN,5700) CHBLK(ILIN)
75770 270 CONTINUE
75771 NLIN=1
75772 CHLIN=' '
75773 CHLIN(7:35+LCOM+1)='DATA ('//CHVAR(IVAR)//
75774 & ',I= , )/'//CHCOM(1:LCOM)//','
75775 WRITE(CHTMP,5400) IDIM-NRPT+1
75776 CHLIN(25:28)=CHTMP(13:16)
75777 LLIN=35+LCOM+1
75778 ENDIF
75779 280 CONTINUE
75780
75781C...Write final block of lines.
75782 CHLIN(LLIN:72)='/'//' '
75783 CHBLK(NLIN)=CHLIN
75784 WRITE(CHTMP,5400) NDIM
75785 CHBLK(1)(30:33)=CHTMP(13:16)
75786 DO 290 ILIN=1,NLIN
75787 WRITE(LFN,5700) CHBLK(ILIN)
75788 290 CONTINUE
75789 300 CONTINUE
75790 ENDIF
75791
75792C...Formats for reading and writing particle data.
75793 5000 FORMAT(1X,I9,2X,A16,2X,A16,3I3,3F12.5,1P,E13.5,2I3)
75794 5100 FORMAT(10X,2I5,F12.6,5I10)
75795 5200 FORMAT(A120)
75796 5300 FORMAT(I9)
75797 5400 FORMAT(I16)
75798 5500 FORMAT(F16.5)
75799 5600 FORMAT(F16.6)
75800 5700 FORMAT(A72)
75801
75802 RETURN
75803 END
75804
75805C*********************************************************************
75806
75807C...PYK
75808C...Provides various integer-valued event related data.
75809
75810 FUNCTION PYK(I,J)
75811
75812C...Double precision and integer declarations.
75813 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75814 IMPLICIT INTEGER(I-N)
75815 INTEGER PYK,PYCHGE,PYCOMP
75816C...Commonblocks.
75817 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75818 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75819 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75820 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75821
75822C...Default value. For I=0 number of entries, number of stable entries
75823C...or 3 times total charge.
75824 PYK=0
75825 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
75826 ELSEIF(I.EQ.0.AND.J.EQ.1) THEN
75827 PYK=N
75828 ELSEIF(I.EQ.0.AND.(J.EQ.2.OR.J.EQ.6)) THEN
75829 DO 100 I1=1,N
75830 IF(J.EQ.2.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+1
75831 IF(J.EQ.6.AND.K(I1,1).GE.1.AND.K(I1,1).LE.10) PYK=PYK+
75832 & PYCHGE(K(I1,2))
75833 100 CONTINUE
75834 ELSEIF(I.EQ.0) THEN
75835
75836C...For I > 0 direct readout of K matrix or charge.
75837 ELSEIF(J.LE.5) THEN
75838 PYK=K(I,J)
75839 ELSEIF(J.EQ.6) THEN
75840 PYK=PYCHGE(K(I,2))
75841
75842C...Status (existing/fragmented/decayed), parton/hadron separation.
75843 ELSEIF(J.LE.8) THEN
75844 IF(K(I,1).GE.1.AND.K(I,1).LE.10) PYK=1
75845 IF(J.EQ.8) PYK=PYK*K(I,2)
75846 ELSEIF(J.LE.12) THEN
75847 KFA=IABS(K(I,2))
75848 KC=PYCOMP(KFA)
75849 KQ=0
75850 IF(KC.NE.0) KQ=KCHG(KC,2)
75851 IF(J.EQ.9.AND.KC.NE.0.AND.KQ.NE.0) PYK=K(I,2)
75852 IF(J.EQ.10.AND.KC.NE.0.AND.KQ.EQ.0) PYK=K(I,2)
75853 IF(J.EQ.11) PYK=KC
75854 IF(J.EQ.12) PYK=KQ*ISIGN(1,K(I,2))
75855
75856C...Heaviest flavour in hadron/diquark.
75857 ELSEIF(J.EQ.13) THEN
75858 KFA=IABS(K(I,2))
75859 PYK=MOD(KFA/100,10)*(-1)**MOD(KFA/100,10)
75860 IF(KFA.LT.10) PYK=KFA
75861 IF(MOD(KFA/1000,10).NE.0) PYK=MOD(KFA/1000,10)
75862 PYK=PYK*ISIGN(1,K(I,2))
75863
75864C...Particle history: generation, ancestor, rank.
75865 ELSEIF(J.LE.15) THEN
75866 I2=I
75867 I1=I
75868 110 PYK=PYK+1
75869 I2=I1
75870 I1=K(I1,3)
75871 IF(I1.GT.0) THEN
75872 IF(K(I1,1).GT.0.AND.K(I1,1).LE.20) GOTO 110
75873 ENDIF
75874 IF(J.EQ.15) PYK=I2
75875 ELSEIF(J.EQ.16) THEN
75876 KFA=IABS(K(I,2))
75877 IF(K(I,1).LE.20.AND.((KFA.GE.11.AND.KFA.LE.20).OR.KFA.EQ.22.OR.
75878 & (KFA.GT.100.AND.MOD(KFA/10,10).NE.0))) THEN
75879 I1=I
75880 120 I2=I1
75881 I1=K(I1,3)
75882 IF(I1.GT.0) THEN
75883 KFAM=IABS(K(I1,2))
75884 ILP=1
75885 IF(KFAM.NE.0.AND.KFAM.LE.10) ILP=0
75886 IF(KFAM.EQ.21.OR.KFAM.EQ.91.OR.KFAM.EQ.92.OR.KFAM.EQ.93)
75887 & ILP=0
75888 IF(KFAM.GT.100.AND.MOD(KFAM/10,10).EQ.0) ILP=0
75889 IF(ILP.EQ.1) GOTO 120
75890 ENDIF
75891 IF(K(I1,1).EQ.12) THEN
75892 DO 130 I3=I1+1,I2
75893 IF(K(I3,3).EQ.K(I2,3).AND.K(I3,2).NE.91.AND.K(I3,2).NE.92
75894 & .AND.K(I3,2).NE.93) PYK=PYK+1
75895 130 CONTINUE
75896 ELSE
75897 I3=I2
75898 140 PYK=PYK+1
75899 I3=I3+1
75900 IF(I3.LT.N.AND.K(I3,3).EQ.K(I2,3)) GOTO 140
75901 ENDIF
75902 ENDIF
75903
75904C...Particle coming from collapsing jet system or not.
75905 ELSEIF(J.EQ.17) THEN
75906 I1=I
75907 150 PYK=PYK+1
75908 I3=I1
75909 I1=K(I1,3)
75910 I0=MAX(1,I1)
75911 KC=PYCOMP(K(I0,2))
75912 IF(I1.EQ.0.OR.K(I0,1).LE.0.OR.K(I0,1).GT.20.OR.KC.EQ.0) THEN
75913 IF(PYK.EQ.1) PYK=-1
75914 IF(PYK.GT.1) PYK=0
75915 RETURN
75916 ENDIF
75917 IF(KCHG(KC,2).EQ.0) GOTO 150
75918 IF(K(I1,1).NE.12) PYK=0
75919 IF(K(I1,1).NE.12) RETURN
75920 I2=I1
75921 160 I2=I2+1
75922 IF(I2.LT.N.AND.K(I2,1).NE.11) GOTO 160
75923 K3M=K(I3-1,3)
75924 IF(K3M.GE.I1.AND.K3M.LE.I2) PYK=0
75925 K3P=K(I3+1,3)
75926 IF(I3.LT.N.AND.K3P.GE.I1.AND.K3P.LE.I2) PYK=0
75927
75928C...Number of decay products. Colour flow.
75929 ELSEIF(J.EQ.18) THEN
75930 IF(K(I,1).EQ.11.OR.K(I,1).EQ.12) PYK=MAX(0,K(I,5)-K(I,4)+1)
75931 IF(K(I,4).EQ.0.OR.K(I,5).EQ.0) PYK=0
75932 ELSEIF(J.LE.22) THEN
75933 IF(K(I,1).NE.3.AND.K(I,1).NE.13.AND.K(I,1).NE.14) RETURN
75934 IF(J.EQ.19) PYK=MOD(K(I,4)/MSTU(5),MSTU(5))
75935 IF(J.EQ.20) PYK=MOD(K(I,5)/MSTU(5),MSTU(5))
75936 IF(J.EQ.21) PYK=MOD(K(I,4),MSTU(5))
75937 IF(J.EQ.22) PYK=MOD(K(I,5),MSTU(5))
75938 ELSE
75939 ENDIF
75940
75941 RETURN
75942 END
75943
75944C*********************************************************************
75945
75946C...PYP
75947C...Provides various real-valued event related data.
75948
75949 FUNCTION PYP(I,J)
75950
75951C...Double precision and integer declarations.
75952 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
75953 IMPLICIT INTEGER(I-N)
75954 INTEGER PYK,PYCHGE,PYCOMP
75955C...Commonblocks.
75956 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
75957 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
75958 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
75959 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
75960C...Local array.
75961 DIMENSION PSUM(4)
75962
75963C...Set default value. For I = 0 sum of momenta or charges,
75964C...or invariant mass of system.
75965 PYP=0D0
75966 IF(I.LT.0.OR.I.GT.MSTU(4).OR.J.LE.0) THEN
75967 ELSEIF(I.EQ.0.AND.J.LE.4) THEN
75968 DO 100 I1=1,N
75969 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+P(I1,J)
75970 100 CONTINUE
75971 ELSEIF(I.EQ.0.AND.J.EQ.5) THEN
75972 DO 120 J1=1,4
75973 PSUM(J1)=0D0
75974 DO 110 I1=1,N
75975 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PSUM(J1)=PSUM(J1)+
75976 & P(I1,J1)
75977 110 CONTINUE
75978 120 CONTINUE
75979 PYP=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-PSUM(3)**2))
75980 ELSEIF(I.EQ.0.AND.J.EQ.6) THEN
75981 DO 130 I1=1,N
75982 IF(K(I1,1).GT.0.AND.K(I1,1).LE.10) PYP=PYP+PYCHGE(K(I1,2))/3D0
75983 130 CONTINUE
75984 ELSEIF(I.EQ.0) THEN
75985
75986C...Direct readout of P matrix.
75987 ELSEIF(J.LE.5) THEN
75988 PYP=P(I,J)
75989
75990C...Charge, total momentum, transverse momentum, transverse mass.
75991 ELSEIF(J.LE.12) THEN
75992 IF(J.EQ.6) PYP=PYCHGE(K(I,2))/3D0
75993 IF(J.EQ.7.OR.J.EQ.8) PYP=P(I,1)**2+P(I,2)**2+P(I,3)**2
75994 IF(J.EQ.9.OR.J.EQ.10) PYP=P(I,1)**2+P(I,2)**2
75995 IF(J.EQ.11.OR.J.EQ.12) PYP=P(I,5)**2+P(I,1)**2+P(I,2)**2
75996 IF(J.EQ.8.OR.J.EQ.10.OR.J.EQ.12) PYP=SQRT(PYP)
75997
75998C...Theta and phi angle in radians or degrees.
75999 ELSEIF(J.LE.16) THEN
76000 IF(J.LE.14) PYP=PYANGL(P(I,3),SQRT(P(I,1)**2+P(I,2)**2))
76001 IF(J.GE.15) PYP=PYANGL(P(I,1),P(I,2))
76002 IF(J.EQ.14.OR.J.EQ.16) PYP=PYP*180D0/PARU(1)
76003
76004C...True rapidity, rapidity with pion mass, pseudorapidity.
76005 ELSEIF(J.LE.19) THEN
76006 PMR=0D0
76007 IF(J.EQ.17) PMR=P(I,5)
76008 IF(J.EQ.18) PMR=PYMASS(211)
76009 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
76010 PYP=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
76011 & 1D20)),P(I,3))
76012
76013C...Energy and momentum fractions (only to be used in CM frame).
76014 ELSEIF(J.LE.25) THEN
76015 IF(J.EQ.20) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)/PARU(21)
76016 IF(J.EQ.21) PYP=2D0*P(I,3)/PARU(21)
76017 IF(J.EQ.22) PYP=2D0*SQRT(P(I,1)**2+P(I,2)**2)/PARU(21)
76018 IF(J.EQ.23) PYP=2D0*P(I,4)/PARU(21)
76019 IF(J.EQ.24) PYP=(P(I,4)+P(I,3))/PARU(21)
76020 IF(J.EQ.25) PYP=(P(I,4)-P(I,3))/PARU(21)
76021 ENDIF
76022
76023 RETURN
76024 END
76025
76026C*********************************************************************
76027
76028C...PYSPHE
76029C...Performs sphericity tensor analysis to give sphericity,
76030C...aplanarity and the related event axes.
76031
76032 SUBROUTINE PYSPHE(SPH,APL)
76033
76034C...Double precision and integer declarations.
76035 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76036 IMPLICIT INTEGER(I-N)
76037 INTEGER PYK,PYCHGE,PYCOMP
76038C...Parameter statement to help give large particle numbers.
76039 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
76040 &KEXCIT=4000000,KDIMEN=5000000)
76041C...Commonblocks.
76042 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76043 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76044 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76045 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76046C...Local arrays.
76047 DIMENSION SM(3,3),SV(3,3)
76048
76049C...Calculate matrix to be diagonalized.
76050 NP=0
76051 DO 110 J1=1,3
76052 DO 100 J2=J1,3
76053 SM(J1,J2)=0D0
76054 100 CONTINUE
76055 110 CONTINUE
76056 PS=0D0
76057 DO 140 I=1,N
76058 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
76059 IF(MSTU(41).GE.2) THEN
76060 KC=PYCOMP(K(I,2))
76061 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76062 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76063 & K(I,2).EQ.KSUSY1+39) GOTO 140
76064 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
76065 & GOTO 140
76066 ENDIF
76067 NP=NP+1
76068 PA=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
76069 PWT=1D0
76070 IF(ABS(PARU(41)-2D0).GT.0.001D0) PWT=
76071 & MAX(1D-10,PA)**(PARU(41)-2D0)
76072 DO 130 J1=1,3
76073 DO 120 J2=J1,3
76074 SM(J1,J2)=SM(J1,J2)+PWT*P(I,J1)*P(I,J2)
76075 120 CONTINUE
76076 130 CONTINUE
76077 PS=PS+PWT*PA**2
76078 140 CONTINUE
76079
76080C...Very low multiplicities (0 or 1) not considered.
76081 IF(NP.LE.1) THEN
76082 CALL PYERRM(8,'(PYSPHE:) too few particles for analysis')
76083 SPH=-1D0
76084 APL=-1D0
76085 RETURN
76086 ENDIF
76087 DO 160 J1=1,3
76088 DO 150 J2=J1,3
76089 SM(J1,J2)=SM(J1,J2)/PS
76090 150 CONTINUE
76091 160 CONTINUE
76092
76093C...Find eigenvalues to matrix (third degree equation).
76094 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
76095 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
76096 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
76097 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
76098 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
76099 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
76100 P(N+1,4)=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
76101 P(N+3,4)=1D0/3D0+SQRT(-SQ)*MIN(2D0*SP,-SQRT(3D0*(1D0-SP**2))-SP)
76102 P(N+2,4)=1D0-P(N+1,4)-P(N+3,4)
76103 IF(P(N+2,4).LT.1D-5) THEN
76104 CALL PYERRM(8,'(PYSPHE:) all particles back-to-back')
76105 SPH=-1D0
76106 APL=-1D0
76107 RETURN
76108 ENDIF
76109
76110C...Find first and last eigenvector by solving equation system.
76111 DO 240 I=1,3,2
76112 DO 180 J1=1,3
76113 SV(J1,J1)=SM(J1,J1)-P(N+I,4)
76114 DO 170 J2=J1+1,3
76115 SV(J1,J2)=SM(J1,J2)
76116 SV(J2,J1)=SM(J1,J2)
76117 170 CONTINUE
76118 180 CONTINUE
76119 SMAX=0D0
76120 DO 200 J1=1,3
76121 DO 190 J2=1,3
76122 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 190
76123 JA=J1
76124 JB=J2
76125 SMAX=ABS(SV(J1,J2))
76126 190 CONTINUE
76127 200 CONTINUE
76128 SMAX=0D0
76129 DO 220 J3=JA+1,JA+2
76130 J1=J3-3*((J3-1)/3)
76131 RL=SV(J1,JB)/SV(JA,JB)
76132 DO 210 J2=1,3
76133 SV(J1,J2)=SV(J1,J2)-RL*SV(JA,J2)
76134 IF(ABS(SV(J1,J2)).LE.SMAX) GOTO 210
76135 JC=J1
76136 SMAX=ABS(SV(J1,J2))
76137 210 CONTINUE
76138 220 CONTINUE
76139 JB1=JB+1-3*(JB/3)
76140 JB2=JB+2-3*((JB+1)/3)
76141 P(N+I,JB1)=-SV(JC,JB2)
76142 P(N+I,JB2)=SV(JC,JB1)
76143 P(N+I,JB)=-(SV(JA,JB1)*P(N+I,JB1)+SV(JA,JB2)*P(N+I,JB2))/
76144 & SV(JA,JB)
76145 PA=SQRT(P(N+I,1)**2+P(N+I,2)**2+P(N+I,3)**2)
76146 SGN=(-1D0)**INT(PYR(0)+0.5D0)
76147 DO 230 J=1,3
76148 P(N+I,J)=SGN*P(N+I,J)/PA
76149 230 CONTINUE
76150 240 CONTINUE
76151
76152C...Middle axis orthogonal to other two. Fill other codes.
76153 SGN=(-1D0)**INT(PYR(0)+0.5D0)
76154 P(N+2,1)=SGN*(P(N+1,2)*P(N+3,3)-P(N+1,3)*P(N+3,2))
76155 P(N+2,2)=SGN*(P(N+1,3)*P(N+3,1)-P(N+1,1)*P(N+3,3))
76156 P(N+2,3)=SGN*(P(N+1,1)*P(N+3,2)-P(N+1,2)*P(N+3,1))
76157 DO 260 I=1,3
76158 K(N+I,1)=31
76159 K(N+I,2)=95
76160 K(N+I,3)=I
76161 K(N+I,4)=0
76162 K(N+I,5)=0
76163 P(N+I,5)=0D0
76164 DO 250 J=1,5
76165 V(I,J)=0D0
76166 250 CONTINUE
76167 260 CONTINUE
76168
76169C...Calculate sphericity and aplanarity. Select storing option.
76170 SPH=1.5D0*(P(N+2,4)+P(N+3,4))
76171 APL=1.5D0*P(N+3,4)
76172 MSTU(61)=N+1
76173 MSTU(62)=NP
76174 IF(MSTU(43).LE.1) MSTU(3)=3
76175 IF(MSTU(43).GE.2) N=N+3
76176
76177 RETURN
76178 END
76179
76180C*********************************************************************
76181
76182C...PYTHRU
76183C...Performs thrust analysis to give thrust, oblateness
76184C...and the related event axes.
76185
76186 SUBROUTINE PYTHRU(THR,OBL)
76187
76188C...Double precision and integer declarations.
76189 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76190 IMPLICIT INTEGER(I-N)
76191 INTEGER PYK,PYCHGE,PYCOMP
76192C...Parameter statement to help give large particle numbers.
76193 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
76194 &KEXCIT=4000000,KDIMEN=5000000)
76195C...Commonblocks.
76196 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76197 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76198 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76199 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76200C...Local arrays.
76201 DIMENSION TDI(3),TPR(3)
76202
76203C...Take copy of particles that are to be considered in thrust analysis.
76204 NP=0
76205 PS=0D0
76206 DO 100 I=1,N
76207 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 100
76208 IF(MSTU(41).GE.2) THEN
76209 KC=PYCOMP(K(I,2))
76210 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76211 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76212 & K(I,2).EQ.KSUSY1+39) GOTO 100
76213 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
76214 & GOTO 100
76215 ENDIF
76216 IF(N+NP+MSTU(44)+15.GE.MSTU(4)-MSTU(32)-5) THEN
76217 CALL PYERRM(11,'(PYTHRU:) no more memory left in PYJETS')
76218 THR=-2D0
76219 OBL=-2D0
76220 RETURN
76221 ENDIF
76222 NP=NP+1
76223 K(N+NP,1)=23
76224 P(N+NP,1)=P(I,1)
76225 P(N+NP,2)=P(I,2)
76226 P(N+NP,3)=P(I,3)
76227 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
76228 P(N+NP,5)=1D0
76229 IF(ABS(PARU(42)-1D0).GT.0.001D0) P(N+NP,5)=
76230 & P(N+NP,4)**(PARU(42)-1D0)
76231 PS=PS+P(N+NP,4)*P(N+NP,5)
76232 100 CONTINUE
76233
76234C...Very low multiplicities (0 or 1) not considered.
76235 IF(NP.LE.1) THEN
76236 CALL PYERRM(8,'(PYTHRU:) too few particles for analysis')
76237 THR=-1D0
76238 OBL=-1D0
76239 RETURN
76240 ENDIF
76241
76242C...Loop over thrust and major. T axis along z direction in latter case.
76243 DO 320 ILD=1,2
76244 IF(ILD.EQ.2) THEN
76245 K(N+NP+1,1)=31
76246 PHI=PYANGL(P(N+NP+1,1),P(N+NP+1,2))
76247 MSTU(33)=1
76248 CALL PYROBO(N+1,N+NP+1,0D0,-PHI,0D0,0D0,0D0)
76249 THE=PYANGL(P(N+NP+1,3),P(N+NP+1,1))
76250 CALL PYROBO(N+1,N+NP+1,-THE,0D0,0D0,0D0,0D0)
76251 ENDIF
76252
76253C...Find and order particles with highest p (pT for major).
76254 DO 110 ILF=N+NP+4,N+NP+MSTU(44)+4
76255 P(ILF,4)=0D0
76256 110 CONTINUE
76257 DO 160 I=N+1,N+NP
76258 IF(ILD.EQ.2) P(I,4)=SQRT(P(I,1)**2+P(I,2)**2)
76259 DO 130 ILF=N+NP+MSTU(44)+3,N+NP+4,-1
76260 IF(P(I,4).LE.P(ILF,4)) GOTO 140
76261 DO 120 J=1,5
76262 P(ILF+1,J)=P(ILF,J)
76263 120 CONTINUE
76264 130 CONTINUE
76265 ILF=N+NP+3
76266 140 DO 150 J=1,5
76267 P(ILF+1,J)=P(I,J)
76268 150 CONTINUE
76269 160 CONTINUE
76270
76271C...Find and order initial axes with highest thrust (major).
76272 DO 170 ILG=N+NP+MSTU(44)+5,N+NP+MSTU(44)+15
76273 P(ILG,4)=0D0
76274 170 CONTINUE
76275 NC=2**(MIN(MSTU(44),NP)-1)
76276 DO 250 ILC=1,NC
76277 DO 180 J=1,3
76278 TDI(J)=0D0
76279 180 CONTINUE
76280 DO 200 ILF=1,MIN(MSTU(44),NP)
76281 SGN=P(N+NP+ILF+3,5)
76282 IF(2**ILF*((ILC+2**(ILF-1)-1)/2**ILF).GE.ILC) SGN=-SGN
76283 DO 190 J=1,4-ILD
76284 TDI(J)=TDI(J)+SGN*P(N+NP+ILF+3,J)
76285 190 CONTINUE
76286 200 CONTINUE
76287 TDS=TDI(1)**2+TDI(2)**2+TDI(3)**2
76288 DO 220 ILG=N+NP+MSTU(44)+MIN(ILC,10)+4,N+NP+MSTU(44)+5,-1
76289 IF(TDS.LE.P(ILG,4)) GOTO 230
76290 DO 210 J=1,4
76291 P(ILG+1,J)=P(ILG,J)
76292 210 CONTINUE
76293 220 CONTINUE
76294 ILG=N+NP+MSTU(44)+4
76295 230 DO 240 J=1,3
76296 P(ILG+1,J)=TDI(J)
76297 240 CONTINUE
76298 P(ILG+1,4)=TDS
76299 250 CONTINUE
76300
76301C...Iterate direction of axis until stable maximum.
76302 P(N+NP+ILD,4)=0D0
76303 ILG=0
76304 260 ILG=ILG+1
76305 THP=0D0
76306 270 THPS=THP
76307 DO 280 J=1,3
76308 IF(THP.LE.1D-10) TDI(J)=P(N+NP+MSTU(44)+4+ILG,J)
76309 IF(THP.GT.1D-10) TDI(J)=TPR(J)
76310 TPR(J)=0D0
76311 280 CONTINUE
76312 DO 300 I=N+1,N+NP
76313 SGN=SIGN(P(I,5),TDI(1)*P(I,1)+TDI(2)*P(I,2)+TDI(3)*P(I,3))
76314 DO 290 J=1,4-ILD
76315 TPR(J)=TPR(J)+SGN*P(I,J)
76316 290 CONTINUE
76317 300 CONTINUE
76318 THP=SQRT(TPR(1)**2+TPR(2)**2+TPR(3)**2)/PS
76319 IF(THP.GE.THPS+PARU(48)) GOTO 270
76320
76321C...Save good axis. Try new initial axis until a number of tries agree.
76322 IF(THP.LT.P(N+NP+ILD,4)-PARU(48).AND.ILG.LT.MIN(10,NC)) GOTO 260
76323 IF(THP.GT.P(N+NP+ILD,4)+PARU(48)) THEN
76324 IAGR=0
76325 SGN=(-1D0)**INT(PYR(0)+0.5D0)
76326 DO 310 J=1,3
76327 P(N+NP+ILD,J)=SGN*TPR(J)/(PS*THP)
76328 310 CONTINUE
76329 P(N+NP+ILD,4)=THP
76330 P(N+NP+ILD,5)=0D0
76331 ENDIF
76332 IAGR=IAGR+1
76333 IF(IAGR.LT.MSTU(45).AND.ILG.LT.MIN(10,NC)) GOTO 260
76334 320 CONTINUE
76335
76336C...Find minor axis and value by orthogonality.
76337 SGN=(-1D0)**INT(PYR(0)+0.5D0)
76338 P(N+NP+3,1)=-SGN*P(N+NP+2,2)
76339 P(N+NP+3,2)=SGN*P(N+NP+2,1)
76340 P(N+NP+3,3)=0D0
76341 THP=0D0
76342 DO 330 I=N+1,N+NP
76343 THP=THP+P(I,5)*ABS(P(N+NP+3,1)*P(I,1)+P(N+NP+3,2)*P(I,2))
76344 330 CONTINUE
76345 P(N+NP+3,4)=THP/PS
76346 P(N+NP+3,5)=0D0
76347
76348C...Fill axis information. Rotate back to original coordinate system.
76349 DO 350 ILD=1,3
76350 K(N+ILD,1)=31
76351 K(N+ILD,2)=96
76352 K(N+ILD,3)=ILD
76353 K(N+ILD,4)=0
76354 K(N+ILD,5)=0
76355 DO 340 J=1,5
76356 P(N+ILD,J)=P(N+NP+ILD,J)
76357 V(N+ILD,J)=0D0
76358 340 CONTINUE
76359 350 CONTINUE
76360 CALL PYROBO(N+1,N+3,THE,PHI,0D0,0D0,0D0)
76361
76362C...Calculate thrust and oblateness. Select storing option.
76363 THR=P(N+1,4)
76364 OBL=P(N+2,4)-P(N+3,4)
76365 MSTU(61)=N+1
76366 MSTU(62)=NP
76367 IF(MSTU(43).LE.1) MSTU(3)=3
76368 IF(MSTU(43).GE.2) N=N+3
76369
76370 RETURN
76371 END
76372
76373C*********************************************************************
76374
76375C...PYCLUS
76376C...Subdivides the particle content of an event into jets/clusters.
76377
76378 SUBROUTINE PYCLUS(NJET)
76379
76380C...Double precision and integer declarations.
76381 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76382 IMPLICIT INTEGER(I-N)
76383 INTEGER PYK,PYCHGE,PYCOMP
76384C...Parameter statement to help give large particle numbers.
76385 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
76386 &KEXCIT=4000000,KDIMEN=5000000)
76387C...Commonblocks.
76388 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76389 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76390 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76391 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76392C...Local arrays and saved variables.
76393 DIMENSION PS(5)
76394 SAVE NSAV,NP,PS,PSS,RINIT,NPRE,NREM
76395
76396C...Functions: distance measure in pT, (pseudo)mass or Durham pT.
76397 R2T(I1,I2)=(P(I1,5)*P(I2,5)-P(I1,1)*P(I2,1)-P(I1,2)*P(I2,2)-
76398 &P(I1,3)*P(I2,3))*2D0*P(I1,5)*P(I2,5)/(0.0001D0+P(I1,5)+P(I2,5))**2
76399 R2M(I1,I2)=2D0*P(I1,4)*P(I2,4)*(1D0-(P(I1,1)*P(I2,1)+P(I1,2)*
76400 &P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
76401 R2D(I1,I2)=2D0*MIN(P(I1,4),P(I2,4))**2*(1D0-(P(I1,1)*P(I2,1)+
76402 &P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/MAX(1D-10,P(I1,5)*P(I2,5)))
76403
76404C...If first time, reset. If reentering, skip preliminaries.
76405 IF(MSTU(48).LE.0) THEN
76406 NP=0
76407 DO 100 J=1,5
76408 PS(J)=0D0
76409 100 CONTINUE
76410 PSS=0D0
76411 PIMASS=PMAS(PYCOMP(211),1)
76412 ELSE
76413 NJET=NSAV
76414 IF(MSTU(43).GE.2) N=N-NJET
76415 DO 110 I=N+1,N+NJET
76416 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
76417 110 CONTINUE
76418 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
76419 R2ACC=PARU(44)**2
76420 ELSE
76421 R2ACC=PARU(45)*PS(5)**2
76422 ENDIF
76423 NLOOP=0
76424 GOTO 300
76425 ENDIF
76426
76427C...Find which particles are to be considered in cluster search.
76428 DO 140 I=1,N
76429 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 140
76430 IF(MSTU(41).GE.2) THEN
76431 KC=PYCOMP(K(I,2))
76432 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76433 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76434 & K(I,2).EQ.KSUSY1+39) GOTO 140
76435 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
76436 & GOTO 140
76437 ENDIF
76438 IF(N+2*NP.GE.MSTU(4)-MSTU(32)-5) THEN
76439 CALL PYERRM(11,'(PYCLUS:) no more memory left in PYJETS')
76440 NJET=-1
76441 RETURN
76442 ENDIF
76443
76444C...Take copy of these particles, with space left for jets later on.
76445 NP=NP+1
76446 K(N+NP,3)=I
76447 DO 120 J=1,5
76448 P(N+NP,J)=P(I,J)
76449 120 CONTINUE
76450 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
76451 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
76452 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
76453 P(N+NP,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
76454 DO 130 J=1,4
76455 PS(J)=PS(J)+P(N+NP,J)
76456 130 CONTINUE
76457 PSS=PSS+P(N+NP,5)
76458 140 CONTINUE
76459 DO 160 I=N+1,N+NP
76460 K(I+NP,3)=K(I,3)
76461 DO 150 J=1,5
76462 P(I+NP,J)=P(I,J)
76463 150 CONTINUE
76464 160 CONTINUE
76465 PS(5)=SQRT(MAX(0D0,PS(4)**2-PS(1)**2-PS(2)**2-PS(3)**2))
76466
76467C...Very low multiplicities not considered.
76468 IF(NP.LT.MSTU(47)) THEN
76469 CALL PYERRM(8,'(PYCLUS:) too few particles for analysis')
76470 NJET=-1
76471 RETURN
76472 ENDIF
76473
76474C...Find precluster configuration. If too few jets, make harder cuts.
76475 NLOOP=0
76476 IF(MSTU(46).LE.3.OR.MSTU(46).EQ.5) THEN
76477 R2ACC=PARU(44)**2
76478 ELSE
76479 R2ACC=PARU(45)*PS(5)**2
76480 ENDIF
76481 RINIT=1.25D0*PARU(43)
76482 IF(NP.LE.MSTU(47)+2) RINIT=0D0
76483 170 RINIT=0.8D0*RINIT
76484 NPRE=0
76485 NREM=NP
76486 DO 180 I=N+NP+1,N+2*NP
76487 K(I,4)=0
76488 180 CONTINUE
76489
76490C...Sum up small momentum region. Jet if enough absolute momentum.
76491 IF(MSTU(46).LE.2) THEN
76492 DO 190 J=1,4
76493 P(N+1,J)=0D0
76494 190 CONTINUE
76495 DO 210 I=N+NP+1,N+2*NP
76496 IF(P(I,5).GT.2D0*RINIT) GOTO 210
76497 NREM=NREM-1
76498 K(I,4)=1
76499 DO 200 J=1,4
76500 P(N+1,J)=P(N+1,J)+P(I,J)
76501 200 CONTINUE
76502 210 CONTINUE
76503 P(N+1,5)=SQRT(P(N+1,1)**2+P(N+1,2)**2+P(N+1,3)**2)
76504 IF(P(N+1,5).GT.2D0*RINIT) NPRE=1
76505 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
76506 IF(NREM.EQ.0) GOTO 170
76507 ENDIF
76508
76509C...Find fastest remaining particle.
76510 220 NPRE=NPRE+1
76511 PMAX=0D0
76512 DO 230 I=N+NP+1,N+2*NP
76513 IF(K(I,4).NE.0.OR.P(I,5).LE.PMAX) GOTO 230
76514 IMAX=I
76515 PMAX=P(I,5)
76516 230 CONTINUE
76517 DO 240 J=1,5
76518 P(N+NPRE,J)=P(IMAX,J)
76519 240 CONTINUE
76520 NREM=NREM-1
76521 K(IMAX,4)=NPRE
76522
76523C...Sum up precluster around it according to pT separation.
76524 IF(MSTU(46).LE.2) THEN
76525 DO 260 I=N+NP+1,N+2*NP
76526 IF(K(I,4).NE.0) GOTO 260
76527 R2=R2T(I,IMAX)
76528 IF(R2.GT.RINIT**2) GOTO 260
76529 NREM=NREM-1
76530 K(I,4)=NPRE
76531 DO 250 J=1,4
76532 P(N+NPRE,J)=P(N+NPRE,J)+P(I,J)
76533 250 CONTINUE
76534 260 CONTINUE
76535 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
76536
76537C...Sum up precluster around it according to mass or
76538C...Durham pT separation.
76539 ELSE
76540 270 IMIN=0
76541 R2MIN=RINIT**2
76542 DO 280 I=N+NP+1,N+2*NP
76543 IF(K(I,4).NE.0) GOTO 280
76544 IF(MSTU(46).LE.4) THEN
76545 R2=R2M(I,N+NPRE)
76546 ELSE
76547 R2=R2D(I,N+NPRE)
76548 ENDIF
76549 IF(R2.GE.R2MIN) GOTO 280
76550 IMIN=I
76551 R2MIN=R2
76552 280 CONTINUE
76553 IF(IMIN.NE.0) THEN
76554 DO 290 J=1,4
76555 P(N+NPRE,J)=P(N+NPRE,J)+P(IMIN,J)
76556 290 CONTINUE
76557 P(N+NPRE,5)=SQRT(P(N+NPRE,1)**2+P(N+NPRE,2)**2+P(N+NPRE,3)**2)
76558 NREM=NREM-1
76559 K(IMIN,4)=NPRE
76560 GOTO 270
76561 ENDIF
76562 ENDIF
76563
76564C...Check if more preclusters to be found. Start over if too few.
76565 IF(RINIT.GE.0.2D0*PARU(43).AND.NPRE+NREM.LT.MSTU(47)) GOTO 170
76566 IF(NREM.GT.0) GOTO 220
76567 NJET=NPRE
76568
76569C...Reassign all particles to nearest jet. Sum up new jet momenta.
76570 300 TSAV=0D0
76571 PSJT=0D0
76572 310 IF(MSTU(46).LE.1) THEN
76573 DO 330 I=N+1,N+NJET
76574 DO 320 J=1,4
76575 V(I,J)=0D0
76576 320 CONTINUE
76577 330 CONTINUE
76578 DO 360 I=N+NP+1,N+2*NP
76579 R2MIN=PSS**2
76580 DO 340 IJET=N+1,N+NJET
76581 IF(P(IJET,5).LT.RINIT) GOTO 340
76582 R2=R2T(I,IJET)
76583 IF(R2.GE.R2MIN) GOTO 340
76584 IMIN=IJET
76585 R2MIN=R2
76586 340 CONTINUE
76587 K(I,4)=IMIN-N
76588 DO 350 J=1,4
76589 V(IMIN,J)=V(IMIN,J)+P(I,J)
76590 350 CONTINUE
76591 360 CONTINUE
76592 PSJT=0D0
76593 DO 380 I=N+1,N+NJET
76594 DO 370 J=1,4
76595 P(I,J)=V(I,J)
76596 370 CONTINUE
76597 P(I,5)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
76598 PSJT=PSJT+P(I,5)
76599 380 CONTINUE
76600 ENDIF
76601
76602C...Find two closest jets.
76603 R2MIN=2D0*MAX(R2ACC,PS(5)**2)
76604 DO 400 ITRY1=N+1,N+NJET-1
76605 DO 390 ITRY2=ITRY1+1,N+NJET
76606 IF(MSTU(46).LE.2) THEN
76607 R2=R2T(ITRY1,ITRY2)
76608 ELSEIF(MSTU(46).LE.4) THEN
76609 R2=R2M(ITRY1,ITRY2)
76610 ELSE
76611 R2=R2D(ITRY1,ITRY2)
76612 ENDIF
76613 IF(R2.GE.R2MIN) GOTO 390
76614 IMIN1=ITRY1
76615 IMIN2=ITRY2
76616 R2MIN=R2
76617 390 CONTINUE
76618 400 CONTINUE
76619
76620C...If allowed, join two closest jets and start over.
76621 IF(NJET.GT.MSTU(47).AND.R2MIN.LT.R2ACC) THEN
76622 IREC=MIN(IMIN1,IMIN2)
76623 IDEL=MAX(IMIN1,IMIN2)
76624 DO 410 J=1,4
76625 P(IREC,J)=P(IMIN1,J)+P(IMIN2,J)
76626 410 CONTINUE
76627 P(IREC,5)=SQRT(P(IREC,1)**2+P(IREC,2)**2+P(IREC,3)**2)
76628 DO 430 I=IDEL+1,N+NJET
76629 DO 420 J=1,5
76630 P(I-1,J)=P(I,J)
76631 420 CONTINUE
76632 430 CONTINUE
76633 IF(MSTU(46).GE.2) THEN
76634 DO 440 I=N+NP+1,N+2*NP
76635 IORI=N+K(I,4)
76636 IF(IORI.EQ.IDEL) K(I,4)=IREC-N
76637 IF(IORI.GT.IDEL) K(I,4)=K(I,4)-1
76638 440 CONTINUE
76639 ENDIF
76640 NJET=NJET-1
76641 GOTO 300
76642
76643C...Divide up broad jet if empty cluster in list of final ones.
76644 ELSEIF(NJET.EQ.MSTU(47).AND.MSTU(46).LE.1.AND.NLOOP.LE.2) THEN
76645 DO 450 I=N+1,N+NJET
76646 K(I,5)=0
76647 450 CONTINUE
76648 DO 460 I=N+NP+1,N+2*NP
76649 K(N+K(I,4),5)=K(N+K(I,4),5)+1
76650 460 CONTINUE
76651 IEMP=0
76652 DO 470 I=N+1,N+NJET
76653 IF(K(I,5).EQ.0) IEMP=I
76654 470 CONTINUE
76655 IF(IEMP.NE.0) THEN
76656 NLOOP=NLOOP+1
76657 ISPL=0
76658 R2MAX=0D0
76659 DO 480 I=N+NP+1,N+2*NP
76660 IF(K(N+K(I,4),5).LE.1.OR.P(I,5).LT.RINIT) GOTO 480
76661 IJET=N+K(I,4)
76662 R2=R2T(I,IJET)
76663 IF(R2.LE.R2MAX) GOTO 480
76664 ISPL=I
76665 R2MAX=R2
76666 480 CONTINUE
76667 IF(ISPL.NE.0) THEN
76668 IJET=N+K(ISPL,4)
76669 DO 490 J=1,4
76670 P(IEMP,J)=P(ISPL,J)
76671 P(IJET,J)=P(IJET,J)-P(ISPL,J)
76672 490 CONTINUE
76673 P(IEMP,5)=P(ISPL,5)
76674 P(IJET,5)=SQRT(P(IJET,1)**2+P(IJET,2)**2+P(IJET,3)**2)
76675 IF(NLOOP.LE.2) GOTO 300
76676 ENDIF
76677 ENDIF
76678 ENDIF
76679
76680C...If generalized thrust has not yet converged, continue iteration.
76681 IF(MSTU(46).LE.1.AND.NLOOP.LE.2.AND.PSJT/PSS.GT.TSAV+PARU(48))
76682 &THEN
76683 TSAV=PSJT/PSS
76684 GOTO 310
76685 ENDIF
76686
76687C...Reorder jets according to energy.
76688 DO 510 I=N+1,N+NJET
76689 DO 500 J=1,5
76690 V(I,J)=P(I,J)
76691 500 CONTINUE
76692 510 CONTINUE
76693 DO 540 INEW=N+1,N+NJET
76694 PEMAX=0D0
76695 DO 520 ITRY=N+1,N+NJET
76696 IF(V(ITRY,4).LE.PEMAX) GOTO 520
76697 IMAX=ITRY
76698 PEMAX=V(ITRY,4)
76699 520 CONTINUE
76700 K(INEW,1)=31
76701 K(INEW,2)=97
76702 K(INEW,3)=INEW-N
76703 K(INEW,4)=0
76704 DO 530 J=1,5
76705 P(INEW,J)=V(IMAX,J)
76706 530 CONTINUE
76707 V(IMAX,4)=-1D0
76708 K(IMAX,5)=INEW
76709 540 CONTINUE
76710
76711C...Clean up particle-jet assignments and jet information.
76712 DO 550 I=N+NP+1,N+2*NP
76713 IORI=K(N+K(I,4),5)
76714 K(I,4)=IORI-N
76715 IF(K(K(I,3),1).NE.3) K(K(I,3),4)=IORI-N
76716 K(IORI,4)=K(IORI,4)+1
76717 550 CONTINUE
76718 IEMP=0
76719 PSJT=0D0
76720 DO 570 I=N+1,N+NJET
76721 K(I,5)=0
76722 PSJT=PSJT+P(I,5)
76723 P(I,5)=SQRT(MAX(P(I,4)**2-P(I,5)**2,0D0))
76724 DO 560 J=1,5
76725 V(I,J)=0D0
76726 560 CONTINUE
76727 IF(K(I,4).EQ.0) IEMP=I
76728 570 CONTINUE
76729
76730C...Select storing option. Output variables. Check for failure.
76731 MSTU(61)=N+1
76732 MSTU(62)=NP
76733 MSTU(63)=NPRE
76734 PARU(61)=PS(5)
76735 PARU(62)=PSJT/PSS
76736 PARU(63)=SQRT(R2MIN)
76737 IF(NJET.LE.1) PARU(63)=0D0
76738 IF(IEMP.NE.0) THEN
76739 CALL PYERRM(8,'(PYCLUS:) failed to reconstruct as requested')
76740 NJET=-1
76741 RETURN
76742 ENDIF
76743 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
76744 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
76745 NSAV=NJET
76746
76747 RETURN
76748 END
76749
76750C*********************************************************************
76751
76752C...PYCELL
76753C...Provides a simple way of jet finding in eta-phi-ET coordinates,
76754C...as used for calorimeters at hadron colliders.
76755
76756 SUBROUTINE PYCELL(NJET)
76757
76758C...Double precision and integer declarations.
76759 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76760 IMPLICIT INTEGER(I-N)
76761 INTEGER PYK,PYCHGE,PYCOMP
76762C...Parameter statement to help give large particle numbers.
76763 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
76764 &KEXCIT=4000000,KDIMEN=5000000)
76765C...Commonblocks.
76766 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76767 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76768 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76769 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76770
76771C...Loop over all particles. Find cell that was hit by given particle.
76772 PTLRAT=1D0/SINH(PARU(51))**2
76773 NP=0
76774 NC=N
76775 DO 110 I=1,N
76776 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
76777 IF(P(I,1)**2+P(I,2)**2.LE.PTLRAT*P(I,3)**2) GOTO 110
76778 IF(MSTU(41).GE.2) THEN
76779 KC=PYCOMP(K(I,2))
76780 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
76781 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
76782 & K(I,2).EQ.KSUSY1+39) GOTO 110
76783 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
76784 & GOTO 110
76785 ENDIF
76786 NP=NP+1
76787 PT=SQRT(P(I,1)**2+P(I,2)**2)
76788 ETA=SIGN(LOG((SQRT(PT**2+P(I,3)**2)+ABS(P(I,3)))/PT),P(I,3))
76789 IETA=MAX(1,MIN(MSTU(51),1+INT(MSTU(51)*0.5D0*
76790 & (ETA/PARU(51)+1D0))))
76791 PHI=PYANGL(P(I,1),P(I,2))
76792 IPHI=MAX(1,MIN(MSTU(52),1+INT(MSTU(52)*0.5D0*
76793 & (PHI/PARU(1)+1D0))))
76794 IETPH=MSTU(52)*IETA+IPHI
76795
76796C...Add to cell already hit, or book new cell.
76797 DO 100 IC=N+1,NC
76798 IF(IETPH.EQ.K(IC,3)) THEN
76799 K(IC,4)=K(IC,4)+1
76800 P(IC,5)=P(IC,5)+PT
76801 GOTO 110
76802 ENDIF
76803 100 CONTINUE
76804 IF(NC.GE.MSTU(4)-MSTU(32)-5) THEN
76805 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
76806 NJET=-2
76807 RETURN
76808 ENDIF
76809 NC=NC+1
76810 K(NC,3)=IETPH
76811 K(NC,4)=1
76812 K(NC,5)=2
76813 P(NC,1)=(PARU(51)/MSTU(51))*(2*IETA-1-MSTU(51))
76814 P(NC,2)=(PARU(1)/MSTU(52))*(2*IPHI-1-MSTU(52))
76815 P(NC,5)=PT
76816 110 CONTINUE
76817
76818C...Smear true bin content by calorimeter resolution.
76819 IF(MSTU(53).GE.1) THEN
76820 DO 130 IC=N+1,NC
76821 PEI=P(IC,5)
76822 IF(MSTU(53).EQ.2) PEI=P(IC,5)*COSH(P(IC,1))
76823 120 PEF=PEI+PARU(55)*SQRT(-2D0*LOG(MAX(1D-10,PYR(0)))*PEI)*
76824 & COS(PARU(2)*PYR(0))
76825 IF(PEF.LT.0D0.OR.PEF.GT.PARU(56)*PEI) GOTO 120
76826 P(IC,5)=PEF
76827 IF(MSTU(53).EQ.2) P(IC,5)=PEF/COSH(P(IC,1))
76828 130 CONTINUE
76829 ENDIF
76830
76831C...Remove cells below threshold.
76832 IF(PARU(58).GT.0D0) THEN
76833 NCC=NC
76834 NC=N
76835 DO 140 IC=N+1,NCC
76836 IF(P(IC,5).GT.PARU(58)) THEN
76837 NC=NC+1
76838 K(NC,3)=K(IC,3)
76839 K(NC,4)=K(IC,4)
76840 K(NC,5)=K(IC,5)
76841 P(NC,1)=P(IC,1)
76842 P(NC,2)=P(IC,2)
76843 P(NC,5)=P(IC,5)
76844 ENDIF
76845 140 CONTINUE
76846 ENDIF
76847
76848C...Find initiator cell: the one with highest pT of not yet used ones.
76849 NJ=NC
76850 150 ETMAX=0D0
76851 DO 160 IC=N+1,NC
76852 IF(K(IC,5).NE.2) GOTO 160
76853 IF(P(IC,5).LE.ETMAX) GOTO 160
76854 ICMAX=IC
76855 ETA=P(IC,1)
76856 PHI=P(IC,2)
76857 ETMAX=P(IC,5)
76858 160 CONTINUE
76859 IF(ETMAX.LT.PARU(52)) GOTO 220
76860 IF(NJ.GE.MSTU(4)-MSTU(32)-5) THEN
76861 CALL PYERRM(11,'(PYCELL:) no more memory left in PYJETS')
76862 NJET=-2
76863 RETURN
76864 ENDIF
76865 K(ICMAX,5)=1
76866 NJ=NJ+1
76867 K(NJ,4)=0
76868 K(NJ,5)=1
76869 P(NJ,1)=ETA
76870 P(NJ,2)=PHI
76871 P(NJ,3)=0D0
76872 P(NJ,4)=0D0
76873 P(NJ,5)=0D0
76874
76875C...Sum up unused cells within required distance of initiator.
76876 DO 170 IC=N+1,NC
76877 IF(K(IC,5).EQ.0) GOTO 170
76878 IF(ABS(P(IC,1)-ETA).GT.PARU(54)) GOTO 170
76879 DPHIA=ABS(P(IC,2)-PHI)
76880 IF(DPHIA.GT.PARU(54).AND.DPHIA.LT.PARU(2)-PARU(54)) GOTO 170
76881 PHIC=P(IC,2)
76882 IF(DPHIA.GT.PARU(1)) PHIC=PHIC+SIGN(PARU(2),PHI)
76883 IF((P(IC,1)-ETA)**2+(PHIC-PHI)**2.GT.PARU(54)**2) GOTO 170
76884 K(IC,5)=-K(IC,5)
76885 K(NJ,4)=K(NJ,4)+K(IC,4)
76886 P(NJ,3)=P(NJ,3)+P(IC,5)*P(IC,1)
76887 P(NJ,4)=P(NJ,4)+P(IC,5)*PHIC
76888 P(NJ,5)=P(NJ,5)+P(IC,5)
76889 170 CONTINUE
76890
76891C...Reject cluster below minimum ET, else accept.
76892 IF(P(NJ,5).LT.PARU(53)) THEN
76893 NJ=NJ-1
76894 DO 180 IC=N+1,NC
76895 IF(K(IC,5).LT.0) K(IC,5)=-K(IC,5)
76896 180 CONTINUE
76897 ELSEIF(MSTU(54).LE.2) THEN
76898 P(NJ,3)=P(NJ,3)/P(NJ,5)
76899 P(NJ,4)=P(NJ,4)/P(NJ,5)
76900 IF(ABS(P(NJ,4)).GT.PARU(1)) P(NJ,4)=P(NJ,4)-SIGN(PARU(2),
76901 & P(NJ,4))
76902 DO 190 IC=N+1,NC
76903 IF(K(IC,5).LT.0) K(IC,5)=0
76904 190 CONTINUE
76905 ELSE
76906 DO 200 J=1,4
76907 P(NJ,J)=0D0
76908 200 CONTINUE
76909 DO 210 IC=N+1,NC
76910 IF(K(IC,5).GE.0) GOTO 210
76911 P(NJ,1)=P(NJ,1)+P(IC,5)*COS(P(IC,2))
76912 P(NJ,2)=P(NJ,2)+P(IC,5)*SIN(P(IC,2))
76913 P(NJ,3)=P(NJ,3)+P(IC,5)*SINH(P(IC,1))
76914 P(NJ,4)=P(NJ,4)+P(IC,5)*COSH(P(IC,1))
76915 K(IC,5)=0
76916 210 CONTINUE
76917 ENDIF
76918 GOTO 150
76919
76920C...Arrange clusters in falling ET sequence.
76921 220 DO 250 I=1,NJ-NC
76922 ETMAX=0D0
76923 DO 230 IJ=NC+1,NJ
76924 IF(K(IJ,5).EQ.0) GOTO 230
76925 IF(P(IJ,5).LT.ETMAX) GOTO 230
76926 IJMAX=IJ
76927 ETMAX=P(IJ,5)
76928 230 CONTINUE
76929 K(IJMAX,5)=0
76930 K(N+I,1)=31
76931 K(N+I,2)=98
76932 K(N+I,3)=I
76933 K(N+I,4)=K(IJMAX,4)
76934 K(N+I,5)=0
76935 DO 240 J=1,5
76936 P(N+I,J)=P(IJMAX,J)
76937 V(N+I,J)=0D0
76938 240 CONTINUE
76939 250 CONTINUE
76940 NJET=NJ-NC
76941
76942C...Convert to massless or massive four-vectors.
76943 IF(MSTU(54).EQ.2) THEN
76944 DO 260 I=N+1,N+NJET
76945 ETA=P(I,3)
76946 P(I,1)=P(I,5)*COS(P(I,4))
76947 P(I,2)=P(I,5)*SIN(P(I,4))
76948 P(I,3)=P(I,5)*SINH(ETA)
76949 P(I,4)=P(I,5)*COSH(ETA)
76950 P(I,5)=0D0
76951 260 CONTINUE
76952 ELSEIF(MSTU(54).GE.3) THEN
76953 DO 270 I=N+1,N+NJET
76954 P(I,5)=SQRT(MAX(0D0,P(I,4)**2-P(I,1)**2-P(I,2)**2-P(I,3)**2))
76955 270 CONTINUE
76956 ENDIF
76957
76958C...Information about storage.
76959 MSTU(61)=N+1
76960 MSTU(62)=NP
76961 MSTU(63)=NC-N
76962 IF(MSTU(43).LE.1) MSTU(3)=MAX(0,NJET)
76963 IF(MSTU(43).GE.2) N=N+MAX(0,NJET)
76964
76965 RETURN
76966 END
76967
76968C*********************************************************************
76969
76970C...PYJMAS
76971C...Determines, approximately, the two jet masses that minimize
76972C...the sum m_H^2 + m_L^2, a la Clavelli and Wyler.
76973
76974 SUBROUTINE PYJMAS(PMH,PML)
76975
76976C...Double precision and integer declarations.
76977 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
76978 IMPLICIT INTEGER(I-N)
76979 INTEGER PYK,PYCHGE,PYCOMP
76980C...Parameter statement to help give large particle numbers.
76981 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
76982 &KEXCIT=4000000,KDIMEN=5000000)
76983C...Commonblocks.
76984 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
76985 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
76986 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
76987 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
76988C...Local arrays.
76989 DIMENSION SM(3,3),SAX(3),PS(3,5)
76990
76991C...Reset.
76992 NP=0
76993 DO 120 J1=1,3
76994 DO 100 J2=J1,3
76995 SM(J1,J2)=0D0
76996 100 CONTINUE
76997 DO 110 J2=1,4
76998 PS(J1,J2)=0D0
76999 110 CONTINUE
77000 120 CONTINUE
77001 PSS=0D0
77002 PIMASS=PMAS(PYCOMP(211),1)
77003
77004C...Take copy of particles that are to be considered in mass analysis.
77005 DO 170 I=1,N
77006 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 170
77007 IF(MSTU(41).GE.2) THEN
77008 KC=PYCOMP(K(I,2))
77009 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77010 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77011 & K(I,2).EQ.KSUSY1+39) GOTO 170
77012 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
77013 & GOTO 170
77014 ENDIF
77015 IF(N+NP+1.GE.MSTU(4)-MSTU(32)-5) THEN
77016 CALL PYERRM(11,'(PYJMAS:) no more memory left in PYJETS')
77017 PMH=-2D0
77018 PML=-2D0
77019 RETURN
77020 ENDIF
77021 NP=NP+1
77022 DO 130 J=1,5
77023 P(N+NP,J)=P(I,J)
77024 130 CONTINUE
77025 IF(MSTU(42).EQ.0) P(N+NP,5)=0D0
77026 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) P(N+NP,5)=PIMASS
77027 P(N+NP,4)=SQRT(P(N+NP,5)**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
77028
77029C...Fill information in sphericity tensor and total momentum vector.
77030 DO 150 J1=1,3
77031 DO 140 J2=J1,3
77032 SM(J1,J2)=SM(J1,J2)+P(I,J1)*P(I,J2)
77033 140 CONTINUE
77034 150 CONTINUE
77035 PSS=PSS+(P(I,1)**2+P(I,2)**2+P(I,3)**2)
77036 DO 160 J=1,4
77037 PS(3,J)=PS(3,J)+P(N+NP,J)
77038 160 CONTINUE
77039 170 CONTINUE
77040
77041C...Very low multiplicities (0 or 1) not considered.
77042 IF(NP.LE.1) THEN
77043 CALL PYERRM(8,'(PYJMAS:) too few particles for analysis')
77044 PMH=-1D0
77045 PML=-1D0
77046 RETURN
77047 ENDIF
77048 PARU(61)=SQRT(MAX(0D0,PS(3,4)**2-PS(3,1)**2-PS(3,2)**2-
77049 &PS(3,3)**2))
77050
77051C...Find largest eigenvalue to matrix (third degree equation).
77052 DO 190 J1=1,3
77053 DO 180 J2=J1,3
77054 SM(J1,J2)=SM(J1,J2)/PSS
77055 180 CONTINUE
77056 190 CONTINUE
77057 SQ=(SM(1,1)*SM(2,2)+SM(1,1)*SM(3,3)+SM(2,2)*SM(3,3)-
77058 &SM(1,2)**2-SM(1,3)**2-SM(2,3)**2)/3D0-1D0/9D0
77059 SR=-0.5D0*(SQ+1D0/9D0+SM(1,1)*SM(2,3)**2+SM(2,2)*SM(1,3)**2+
77060 &SM(3,3)*SM(1,2)**2-SM(1,1)*SM(2,2)*SM(3,3))+
77061 &SM(1,2)*SM(1,3)*SM(2,3)+1D0/27D0
77062 SP=COS(ACOS(MAX(MIN(SR/SQRT(-SQ**3),1D0),-1D0))/3D0)
77063 SMA=1D0/3D0+SQRT(-SQ)*MAX(2D0*SP,SQRT(3D0*(1D0-SP**2))-SP)
77064
77065C...Find largest eigenvector by solving equation system.
77066 DO 210 J1=1,3
77067 SM(J1,J1)=SM(J1,J1)-SMA
77068 DO 200 J2=J1+1,3
77069 SM(J2,J1)=SM(J1,J2)
77070 200 CONTINUE
77071 210 CONTINUE
77072 SMAX=0D0
77073 DO 230 J1=1,3
77074 DO 220 J2=1,3
77075 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 220
77076 JA=J1
77077 JB=J2
77078 SMAX=ABS(SM(J1,J2))
77079 220 CONTINUE
77080 230 CONTINUE
77081 SMAX=0D0
77082 DO 250 J3=JA+1,JA+2
77083 J1=J3-3*((J3-1)/3)
77084 RL=SM(J1,JB)/SM(JA,JB)
77085 DO 240 J2=1,3
77086 SM(J1,J2)=SM(J1,J2)-RL*SM(JA,J2)
77087 IF(ABS(SM(J1,J2)).LE.SMAX) GOTO 240
77088 JC=J1
77089 SMAX=ABS(SM(J1,J2))
77090 240 CONTINUE
77091 250 CONTINUE
77092 JB1=JB+1-3*(JB/3)
77093 JB2=JB+2-3*((JB+1)/3)
77094 SAX(JB1)=-SM(JC,JB2)
77095 SAX(JB2)=SM(JC,JB1)
77096 SAX(JB)=-(SM(JA,JB1)*SAX(JB1)+SM(JA,JB2)*SAX(JB2))/SM(JA,JB)
77097
77098C...Divide particles into two initial clusters by hemisphere.
77099 DO 270 I=N+1,N+NP
77100 PSAX=P(I,1)*SAX(1)+P(I,2)*SAX(2)+P(I,3)*SAX(3)
77101 IS=1
77102 IF(PSAX.LT.0D0) IS=2
77103 K(I,3)=IS
77104 DO 260 J=1,4
77105 PS(IS,J)=PS(IS,J)+P(I,J)
77106 260 CONTINUE
77107 270 CONTINUE
77108 PMS=MAX(1D-10,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2)+
77109 &MAX(1D-10,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2)
77110
77111C...Reassign one particle at a time; find maximum decrease of m^2 sum.
77112 280 PMD=0D0
77113 IM=0
77114 DO 290 J=1,4
77115 PS(3,J)=PS(1,J)-PS(2,J)
77116 290 CONTINUE
77117 DO 300 I=N+1,N+NP
77118 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)
77119 IF(K(I,3).EQ.1) PMDI=2D0*(P(I,5)**2-PPS)
77120 IF(K(I,3).EQ.2) PMDI=2D0*(P(I,5)**2+PPS)
77121 IF(PMDI.LT.PMD) THEN
77122 PMD=PMDI
77123 IM=I
77124 ENDIF
77125 300 CONTINUE
77126
77127C...Loop back if significant reduction in sum of m^2.
77128 IF(PMD.LT.-PARU(48)*PMS) THEN
77129 PMS=PMS+PMD
77130 IS=K(IM,3)
77131 DO 310 J=1,4
77132 PS(IS,J)=PS(IS,J)-P(IM,J)
77133 PS(3-IS,J)=PS(3-IS,J)+P(IM,J)
77134 310 CONTINUE
77135 K(IM,3)=3-IS
77136 GOTO 280
77137 ENDIF
77138
77139C...Final masses and output.
77140 MSTU(61)=N+1
77141 MSTU(62)=NP
77142 PS(1,5)=SQRT(MAX(0D0,PS(1,4)**2-PS(1,1)**2-PS(1,2)**2-PS(1,3)**2))
77143 PS(2,5)=SQRT(MAX(0D0,PS(2,4)**2-PS(2,1)**2-PS(2,2)**2-PS(2,3)**2))
77144 PMH=MAX(PS(1,5),PS(2,5))
77145 PML=MIN(PS(1,5),PS(2,5))
77146
77147 RETURN
77148 END
77149
77150C*********************************************************************
77151
77152C...PYFOWO
77153C...Calculates the first few Fox-Wolfram moments.
77154
77155 SUBROUTINE PYFOWO(H10,H20,H30,H40)
77156
77157C...Double precision and integer declarations.
77158 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77159 IMPLICIT INTEGER(I-N)
77160 INTEGER PYK,PYCHGE,PYCOMP
77161C...Parameter statement to help give large particle numbers.
77162 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
77163 &KEXCIT=4000000,KDIMEN=5000000)
77164C...Commonblocks.
77165 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77166 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77167 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77168 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
77169
77170C...Copy momenta for particles and calculate H0.
77171 NP=0
77172 H0=0D0
77173 HD=0D0
77174 DO 110 I=1,N
77175 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 110
77176 IF(MSTU(41).GE.2) THEN
77177 KC=PYCOMP(K(I,2))
77178 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77179 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77180 & K(I,2).EQ.KSUSY1+39) GOTO 110
77181 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.PYCHGE(K(I,2)).EQ.0)
77182 & GOTO 110
77183 ENDIF
77184 IF(N+NP.GE.MSTU(4)-MSTU(32)-5) THEN
77185 CALL PYERRM(11,'(PYFOWO:) no more memory left in PYJETS')
77186 H10=-1D0
77187 H20=-1D0
77188 H30=-1D0
77189 H40=-1D0
77190 RETURN
77191 ENDIF
77192 NP=NP+1
77193 DO 100 J=1,3
77194 P(N+NP,J)=P(I,J)
77195 100 CONTINUE
77196 P(N+NP,4)=SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2)
77197 H0=H0+P(N+NP,4)
77198 HD=HD+P(N+NP,4)**2
77199 110 CONTINUE
77200 H0=H0**2
77201
77202C...Very low multiplicities (0 or 1) not considered.
77203 IF(NP.LE.1) THEN
77204 CALL PYERRM(8,'(PYFOWO:) too few particles for analysis')
77205 H10=-1D0
77206 H20=-1D0
77207 H30=-1D0
77208 H40=-1D0
77209 RETURN
77210 ENDIF
77211
77212C...Calculate H1 - H4.
77213 H10=0D0
77214 H20=0D0
77215 H30=0D0
77216 H40=0D0
77217 DO 130 I1=N+1,N+NP
77218 DO 120 I2=I1+1,N+NP
77219 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
77220 & (P(I1,4)*P(I2,4))
77221 H10=H10+P(I1,4)*P(I2,4)*CTHE
77222 H20=H20+P(I1,4)*P(I2,4)*(1.5D0*CTHE**2-0.5D0)
77223 H30=H30+P(I1,4)*P(I2,4)*(2.5D0*CTHE**3-1.5D0*CTHE)
77224 H40=H40+P(I1,4)*P(I2,4)*(4.375D0*CTHE**4-3.75D0*CTHE**2+
77225 & 0.375D0)
77226 120 CONTINUE
77227 130 CONTINUE
77228
77229C...Calculate H1/H0 - H4/H0. Output.
77230 MSTU(61)=N+1
77231 MSTU(62)=NP
77232 H10=(HD+2D0*H10)/H0
77233 H20=(HD+2D0*H20)/H0
77234 H30=(HD+2D0*H30)/H0
77235 H40=(HD+2D0*H40)/H0
77236
77237 RETURN
77238 END
77239
77240C*********************************************************************
77241
77242C...PYTABU
77243C...Evaluates various properties of an event, with statistics
77244C...accumulated during the course of the run and
77245C...printed at the end.
77246
77247 SUBROUTINE PYTABU(MTABU)
77248
77249C...Double precision and integer declarations.
77250 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
77251 IMPLICIT INTEGER(I-N)
77252 INTEGER PYK,PYCHGE,PYCOMP
77253C...Parameter statement to help give large particle numbers.
77254 PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
77255 &KEXCIT=4000000,KDIMEN=5000000)
77256C...Commonblocks.
77257 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
77258 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
77259 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
77260 COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
77261 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/
77262C...Local arrays, character variables, saved variables and data.
77263 DIMENSION KFIS(100,2),NPIS(100,0:10),KFFS(400),NPFS(400,4),
77264 &FEVFM(10,4),FM1FM(3,10,4),FM2FM(3,10,4),FMOMA(4),FMOMS(4),
77265 &FEVEE(50),FE1EC(50),FE2EC(50),FE1EA(25),FE2EA(25),
77266 &KFDM(8),KFDC(200,0:8),NPDC(200)
77267 SAVE NEVIS,NKFIS,KFIS,NPIS,NEVFS,NPRFS,NFIFS,NCHFS,NKFFS,
77268 &KFFS,NPFS,NEVFM,NMUFM,FM1FM,FM2FM,NEVEE,FE1EC,FE2EC,FE1EA,
77269 &FE2EA,NEVDC,NKFDC,NREDC,KFDC,NPDC
77270 CHARACTER CHAU*16,CHIS(2)*12,CHDC(8)*12
77271 DATA NEVIS/0/,NKFIS/0/,NEVFS/0/,NPRFS/0/,NFIFS/0/,NCHFS/0/,
77272 &NKFFS/0/,NEVFM/0/,NMUFM/0/,FM1FM/120*0D0/,FM2FM/120*0D0/,
77273 &NEVEE/0/,FE1EC/50*0D0/,FE2EC/50*0D0/,FE1EA/25*0D0/,FE2EA/25*0D0/,
77274 &NEVDC/0/,NKFDC/0/,NREDC/0/
77275
77276C...Reset statistics on initial parton state.
77277 IF(MTABU.EQ.10) THEN
77278 NEVIS=0
77279 NKFIS=0
77280
77281C...Identify and order flavour content of initial state.
77282 ELSEIF(MTABU.EQ.11) THEN
77283 NEVIS=NEVIS+1
77284 KFM1=2*IABS(MSTU(161))
77285 IF(MSTU(161).GT.0) KFM1=KFM1-1
77286 KFM2=2*IABS(MSTU(162))
77287 IF(MSTU(162).GT.0) KFM2=KFM2-1
77288 KFMN=MIN(KFM1,KFM2)
77289 KFMX=MAX(KFM1,KFM2)
77290 DO 100 I=1,NKFIS
77291 IF(KFMN.EQ.KFIS(I,1).AND.KFMX.EQ.KFIS(I,2)) THEN
77292 IKFIS=-I
77293 GOTO 110
77294 ELSEIF(KFMN.LT.KFIS(I,1).OR.(KFMN.EQ.KFIS(I,1).AND.
77295 & KFMX.LT.KFIS(I,2))) THEN
77296 IKFIS=I
77297 GOTO 110
77298 ENDIF
77299 100 CONTINUE
77300 IKFIS=NKFIS+1
77301 110 IF(IKFIS.LT.0) THEN
77302 IKFIS=-IKFIS
77303 ELSE
77304 IF(NKFIS.GE.100) RETURN
77305 DO 130 I=NKFIS,IKFIS,-1
77306 KFIS(I+1,1)=KFIS(I,1)
77307 KFIS(I+1,2)=KFIS(I,2)
77308 DO 120 J=0,10
77309 NPIS(I+1,J)=NPIS(I,J)
77310 120 CONTINUE
77311 130 CONTINUE
77312 NKFIS=NKFIS+1
77313 KFIS(IKFIS,1)=KFMN
77314 KFIS(IKFIS,2)=KFMX
77315 DO 140 J=0,10
77316 NPIS(IKFIS,J)=0
77317 140 CONTINUE
77318 ENDIF
77319 NPIS(IKFIS,0)=NPIS(IKFIS,0)+1
77320
77321C...Count number of partons in initial state.
77322 NP=0
77323 DO 160 I=1,N
77324 IF(K(I,1).LE.0.OR.K(I,1).GT.12) THEN
77325 ELSEIF(IABS(K(I,2)).GT.80.AND.IABS(K(I,2)).LE.100) THEN
77326 ELSEIF(IABS(K(I,2)).GT.100.AND.MOD(IABS(K(I,2))/10,10).NE.0)
77327 & THEN
77328 ELSE
77329 IM=I
77330 150 IM=K(IM,3)
77331 IF(IM.LE.0.OR.IM.GT.N) THEN
77332 NP=NP+1
77333 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
77334 NP=NP+1
77335 ELSEIF(IABS(K(IM,2)).GT.80.AND.IABS(K(IM,2)).LE.100) THEN
77336 ELSEIF(IABS(K(IM,2)).GT.100.AND.MOD(IABS(K(IM,2))/10,10)
77337 & .NE.0) THEN
77338 ELSE
77339 GOTO 150
77340 ENDIF
77341 ENDIF
77342 160 CONTINUE
77343 NPCO=MAX(NP,1)
77344 IF(NP.GE.6) NPCO=6
77345 IF(NP.GE.8) NPCO=7
77346 IF(NP.GE.11) NPCO=8
77347 IF(NP.GE.16) NPCO=9
77348 IF(NP.GE.26) NPCO=10
77349 NPIS(IKFIS,NPCO)=NPIS(IKFIS,NPCO)+1
77350 MSTU(62)=NP
77351
77352C...Write statistics on initial parton state.
77353 ELSEIF(MTABU.EQ.12) THEN
77354 FAC=1D0/MAX(1,NEVIS)
77355 WRITE(MSTU(11),5000) NEVIS
77356 DO 170 I=1,NKFIS
77357 KFMN=KFIS(I,1)
77358 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
77359 KFM1=(KFMN+1)/2
77360 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
77361 CALL PYNAME(KFM1,CHAU)
77362 CHIS(1)=CHAU(1:12)
77363 IF(CHAU(13:13).NE.' ') CHIS(1)(12:12)='?'
77364 KFMX=KFIS(I,2)
77365 IF(KFIS(I,1).EQ.0) KFMX=0
77366 KFM2=(KFMX+1)/2
77367 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
77368 CALL PYNAME(KFM2,CHAU)
77369 CHIS(2)=CHAU(1:12)
77370 IF(CHAU(13:13).NE.' ') CHIS(2)(12:12)='?'
77371 WRITE(MSTU(11),5100) CHIS(1),CHIS(2),FAC*NPIS(I,0),
77372 & (NPIS(I,J)/DBLE(NPIS(I,0)),J=1,10)
77373 170 CONTINUE
77374
77375C...Copy statistics on initial parton state into /PYJETS/.
77376 ELSEIF(MTABU.EQ.13) THEN
77377 FAC=1D0/MAX(1,NEVIS)
77378 DO 190 I=1,NKFIS
77379 KFMN=KFIS(I,1)
77380 IF(KFMN.EQ.0) KFMN=KFIS(I,2)
77381 KFM1=(KFMN+1)/2
77382 IF(2*KFM1.EQ.KFMN) KFM1=-KFM1
77383 KFMX=KFIS(I,2)
77384 IF(KFIS(I,1).EQ.0) KFMX=0
77385 KFM2=(KFMX+1)/2
77386 IF(2*KFM2.EQ.KFMX) KFM2=-KFM2
77387 K(I,1)=32
77388 K(I,2)=99
77389 K(I,3)=KFM1
77390 K(I,4)=KFM2
77391 K(I,5)=NPIS(I,0)
77392 DO 180 J=1,5
77393 P(I,J)=FAC*NPIS(I,J)
77394 V(I,J)=FAC*NPIS(I,J+5)
77395 180 CONTINUE
77396 190 CONTINUE
77397 N=NKFIS
77398 DO 200 J=1,5
77399 K(N+1,J)=0
77400 P(N+1,J)=0D0
77401 V(N+1,J)=0D0
77402 200 CONTINUE
77403 K(N+1,1)=32
77404 K(N+1,2)=99
77405 K(N+1,5)=NEVIS
77406 MSTU(3)=1
77407
77408C...Reset statistics on number of particles/partons.
77409 ELSEIF(MTABU.EQ.20) THEN
77410 NEVFS=0
77411 NPRFS=0
77412 NFIFS=0
77413 NCHFS=0
77414 NKFFS=0
77415
77416C...Identify whether particle/parton is primary or not.
77417 ELSEIF(MTABU.EQ.21) THEN
77418 NEVFS=NEVFS+1
77419 MSTU(62)=0
77420 DO 260 I=1,N
77421 IF(K(I,1).LE.0.OR.K(I,1).GT.20.OR.K(I,1).EQ.13) GOTO 260
77422 MSTU(62)=MSTU(62)+1
77423 KC=PYCOMP(K(I,2))
77424 MPRI=0
77425 IF(K(I,3).LE.0.OR.K(I,3).GT.N) THEN
77426 MPRI=1
77427 ELSEIF(K(K(I,3),1).LE.0.OR.K(K(I,3),1).GT.20) THEN
77428 MPRI=1
77429 ELSEIF(K(K(I,3),2).GE.91.AND.K(K(I,3),2).LE.93) THEN
77430 MPRI=1
77431 ELSEIF(KC.EQ.0) THEN
77432 ELSEIF(K(K(I,3),1).EQ.13) THEN
77433 IM=K(K(I,3),3)
77434 IF(IM.LE.0.OR.IM.GT.N) THEN
77435 MPRI=1
77436 ELSEIF(K(IM,1).LE.0.OR.K(IM,1).GT.20) THEN
77437 MPRI=1
77438 ENDIF
77439 ELSEIF(KCHG(KC,2).EQ.0) THEN
77440 KCM=PYCOMP(K(K(I,3),2))
77441 IF(KCM.NE.0) THEN
77442 IF(KCHG(KCM,2).NE.0) MPRI=1
77443 ENDIF
77444 ENDIF
77445 IF(KC.NE.0.AND.MPRI.EQ.1) THEN
77446 IF(KCHG(KC,2).EQ.0) NPRFS=NPRFS+1
77447 ENDIF
77448 IF(K(I,1).LE.10) THEN
77449 NFIFS=NFIFS+1
77450 IF(PYCHGE(K(I,2)).NE.0) NCHFS=NCHFS+1
77451 ENDIF
77452
77453C...Fill statistics on number of particles/partons in event.
77454 KFA=IABS(K(I,2))
77455 KFS=3-ISIGN(1,K(I,2))-MPRI
77456 DO 210 IP=1,NKFFS
77457 IF(KFA.EQ.KFFS(IP)) THEN
77458 IKFFS=-IP
77459 GOTO 220
77460 ELSEIF(KFA.LT.KFFS(IP)) THEN
77461 IKFFS=IP
77462 GOTO 220
77463 ENDIF
77464 210 CONTINUE
77465 IKFFS=NKFFS+1
77466 220 IF(IKFFS.LT.0) THEN
77467 IKFFS=-IKFFS
77468 ELSE
77469 IF(NKFFS.GE.400) RETURN
77470 DO 240 IP=NKFFS,IKFFS,-1
77471 KFFS(IP+1)=KFFS(IP)
77472 DO 230 J=1,4
77473 NPFS(IP+1,J)=NPFS(IP,J)
77474 230 CONTINUE
77475 240 CONTINUE
77476 NKFFS=NKFFS+1
77477 KFFS(IKFFS)=KFA
77478 DO 250 J=1,4
77479 NPFS(IKFFS,J)=0
77480 250 CONTINUE
77481 ENDIF
77482 NPFS(IKFFS,KFS)=NPFS(IKFFS,KFS)+1
77483 260 CONTINUE
77484
77485C...Write statistics on particle/parton composition of events.
77486 ELSEIF(MTABU.EQ.22) THEN
77487 FAC=1D0/MAX(1,NEVFS)
77488 WRITE(MSTU(11),5200) NEVFS,FAC*NPRFS,FAC*NFIFS,FAC*NCHFS
77489 DO 270 I=1,NKFFS
77490 CALL PYNAME(KFFS(I),CHAU)
77491 KC=PYCOMP(KFFS(I))
77492 MDCYF=0
77493 IF(KC.NE.0) MDCYF=MDCY(KC,1)
77494 WRITE(MSTU(11),5300) KFFS(I),CHAU,MDCYF,(FAC*NPFS(I,J),J=1,4),
77495 & FAC*(NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4))
77496 270 CONTINUE
77497
77498C...Copy particle/parton composition information into /PYJETS/.
77499 ELSEIF(MTABU.EQ.23) THEN
77500 FAC=1D0/MAX(1,NEVFS)
77501 DO 290 I=1,NKFFS
77502 K(I,1)=32
77503 K(I,2)=99
77504 K(I,3)=KFFS(I)
77505 K(I,4)=0
77506 K(I,5)=NPFS(I,1)+NPFS(I,2)+NPFS(I,3)+NPFS(I,4)
77507 DO 280 J=1,4
77508 P(I,J)=FAC*NPFS(I,J)
77509 V(I,J)=0D0
77510 280 CONTINUE
77511 P(I,5)=FAC*K(I,5)
77512 V(I,5)=0D0
77513 290 CONTINUE
77514 N=NKFFS
77515 DO 300 J=1,5
77516 K(N+1,J)=0
77517 P(N+1,J)=0D0
77518 V(N+1,J)=0D0
77519 300 CONTINUE
77520 K(N+1,1)=32
77521 K(N+1,2)=99
77522 K(N+1,5)=NEVFS
77523 P(N+1,1)=FAC*NPRFS
77524 P(N+1,2)=FAC*NFIFS
77525 P(N+1,3)=FAC*NCHFS
77526 MSTU(3)=1
77527
77528C...Reset factorial moments statistics.
77529 ELSEIF(MTABU.EQ.30) THEN
77530 NEVFM=0
77531 NMUFM=0
77532 DO 330 IM=1,3
77533 DO 320 IB=1,10
77534 DO 310 IP=1,4
77535 FM1FM(IM,IB,IP)=0D0
77536 FM2FM(IM,IB,IP)=0D0
77537 310 CONTINUE
77538 320 CONTINUE
77539 330 CONTINUE
77540
77541C...Find particles to include, with (pion,pseudo)rapidity and azimuth.
77542 ELSEIF(MTABU.EQ.31) THEN
77543 NEVFM=NEVFM+1
77544 NLOW=N+MSTU(3)
77545 NUPP=NLOW
77546 DO 410 I=1,N
77547 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 410
77548 IF(MSTU(41).GE.2) THEN
77549 KC=PYCOMP(K(I,2))
77550 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77551 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77552 & K(I,2).EQ.KSUSY1+39) GOTO 410
77553 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
77554 & PYCHGE(K(I,2)).EQ.0) GOTO 410
77555 ENDIF
77556 PMR=0D0
77557 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
77558 IF(MSTU(42).GE.2) PMR=P(I,5)
77559 PR=MAX(1D-20,PMR**2+P(I,1)**2+P(I,2)**2)
77560 YETA=SIGN(LOG(MIN((SQRT(PR+P(I,3)**2)+ABS(P(I,3)))/SQRT(PR),
77561 & 1D20)),P(I,3))
77562 IF(ABS(YETA).GT.PARU(57)) GOTO 410
77563 PHI=PYANGL(P(I,1),P(I,2))
77564 IYETA=512D0*(YETA+PARU(57))/(2D0*PARU(57))
77565 IYETA=MAX(0,MIN(511,IYETA))
77566 IPHI=512D0*(PHI+PARU(1))/PARU(2)
77567 IPHI=MAX(0,MIN(511,IPHI))
77568 IYEP=0
77569 DO 340 IB=0,9
77570 IYEP=IYEP+4**IB*(2*MOD(IYETA/2**IB,2)+MOD(IPHI/2**IB,2))
77571 340 CONTINUE
77572
77573C...Order particles in (pseudo)rapidity and/or azimuth.
77574 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
77575 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
77576 RETURN
77577 ENDIF
77578 NUPP=NUPP+1
77579 IF(NUPP.EQ.NLOW+1) THEN
77580 K(NUPP,1)=IYETA
77581 K(NUPP,2)=IPHI
77582 K(NUPP,3)=IYEP
77583 ELSE
77584 DO 350 I1=NUPP-1,NLOW+1,-1
77585 IF(IYETA.GE.K(I1,1)) GOTO 360
77586 K(I1+1,1)=K(I1,1)
77587 350 CONTINUE
77588 360 K(I1+1,1)=IYETA
77589 DO 370 I1=NUPP-1,NLOW+1,-1
77590 IF(IPHI.GE.K(I1,2)) GOTO 380
77591 K(I1+1,2)=K(I1,2)
77592 370 CONTINUE
77593 380 K(I1+1,2)=IPHI
77594 DO 390 I1=NUPP-1,NLOW+1,-1
77595 IF(IYEP.GE.K(I1,3)) GOTO 400
77596 K(I1+1,3)=K(I1,3)
77597 390 CONTINUE
77598 400 K(I1+1,3)=IYEP
77599 ENDIF
77600 410 CONTINUE
77601 K(NUPP+1,1)=2**10
77602 K(NUPP+1,2)=2**10
77603 K(NUPP+1,3)=4**10
77604
77605C...Calculate sum of factorial moments in event.
77606 DO 480 IM=1,3
77607 DO 430 IB=1,10
77608 DO 420 IP=1,4
77609 FEVFM(IB,IP)=0D0
77610 420 CONTINUE
77611 430 CONTINUE
77612 DO 450 IB=1,10
77613 IF(IM.LE.2) IBIN=2**(10-IB)
77614 IF(IM.EQ.3) IBIN=4**(10-IB)
77615 IAGR=K(NLOW+1,IM)/IBIN
77616 NAGR=1
77617 DO 440 I=NLOW+2,NUPP+1
77618 ICUT=K(I,IM)/IBIN
77619 IF(ICUT.EQ.IAGR) THEN
77620 NAGR=NAGR+1
77621 ELSE
77622 IF(NAGR.EQ.1) THEN
77623 ELSEIF(NAGR.EQ.2) THEN
77624 FEVFM(IB,1)=FEVFM(IB,1)+2D0
77625 ELSEIF(NAGR.EQ.3) THEN
77626 FEVFM(IB,1)=FEVFM(IB,1)+6D0
77627 FEVFM(IB,2)=FEVFM(IB,2)+6D0
77628 ELSEIF(NAGR.EQ.4) THEN
77629 FEVFM(IB,1)=FEVFM(IB,1)+12D0
77630 FEVFM(IB,2)=FEVFM(IB,2)+24D0
77631 FEVFM(IB,3)=FEVFM(IB,3)+24D0
77632 ELSE
77633 FEVFM(IB,1)=FEVFM(IB,1)+NAGR*(NAGR-1D0)
77634 FEVFM(IB,2)=FEVFM(IB,2)+NAGR*(NAGR-1D0)*(NAGR-2D0)
77635 FEVFM(IB,3)=FEVFM(IB,3)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
77636 & (NAGR-3D0)
77637 FEVFM(IB,4)=FEVFM(IB,4)+NAGR*(NAGR-1D0)*(NAGR-2D0)*
77638 & (NAGR-3D0)*(NAGR-4D0)
77639 ENDIF
77640 IAGR=ICUT
77641 NAGR=1
77642 ENDIF
77643 440 CONTINUE
77644 450 CONTINUE
77645
77646C...Add results to total statistics.
77647 DO 470 IB=10,1,-1
77648 DO 460 IP=1,4
77649 IF(FEVFM(1,IP).LT.0.5D0) THEN
77650 FEVFM(IB,IP)=0D0
77651 ELSEIF(IM.LE.2) THEN
77652 FEVFM(IB,IP)=2D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
77653 ELSE
77654 FEVFM(IB,IP)=4D0**((IB-1)*IP)*FEVFM(IB,IP)/FEVFM(1,IP)
77655 ENDIF
77656 FM1FM(IM,IB,IP)=FM1FM(IM,IB,IP)+FEVFM(IB,IP)
77657 FM2FM(IM,IB,IP)=FM2FM(IM,IB,IP)+FEVFM(IB,IP)**2
77658 460 CONTINUE
77659 470 CONTINUE
77660 480 CONTINUE
77661 NMUFM=NMUFM+(NUPP-NLOW)
77662 MSTU(62)=NUPP-NLOW
77663
77664C...Write accumulated statistics on factorial moments.
77665 ELSEIF(MTABU.EQ.32) THEN
77666 FAC=1D0/MAX(1,NEVFM)
77667 IF(MSTU(42).LE.0) WRITE(MSTU(11),5400) NEVFM,'eta'
77668 IF(MSTU(42).EQ.1) WRITE(MSTU(11),5400) NEVFM,'ypi'
77669 IF(MSTU(42).GE.2) WRITE(MSTU(11),5400) NEVFM,'y '
77670 DO 510 IM=1,3
77671 WRITE(MSTU(11),5500)
77672 DO 500 IB=1,10
77673 BYETA=2D0*PARU(57)
77674 IF(IM.NE.2) BYETA=BYETA/2**(IB-1)
77675 BPHI=PARU(2)
77676 IF(IM.NE.1) BPHI=BPHI/2**(IB-1)
77677 IF(IM.LE.2) BNAVE=FAC*NMUFM/DBLE(2**(IB-1))
77678 IF(IM.EQ.3) BNAVE=FAC*NMUFM/DBLE(4**(IB-1))
77679 DO 490 IP=1,4
77680 FMOMA(IP)=FAC*FM1FM(IM,IB,IP)
77681 FMOMS(IP)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
77682 & FMOMA(IP)**2)))
77683 490 CONTINUE
77684 WRITE(MSTU(11),5600) BYETA,BPHI,BNAVE,(FMOMA(IP),FMOMS(IP),
77685 & IP=1,4)
77686 500 CONTINUE
77687 510 CONTINUE
77688
77689C...Copy statistics on factorial moments into /PYJETS/.
77690 ELSEIF(MTABU.EQ.33) THEN
77691 FAC=1D0/MAX(1,NEVFM)
77692 DO 540 IM=1,3
77693 DO 530 IB=1,10
77694 I=10*(IM-1)+IB
77695 K(I,1)=32
77696 K(I,2)=99
77697 K(I,3)=1
77698 IF(IM.NE.2) K(I,3)=2**(IB-1)
77699 K(I,4)=1
77700 IF(IM.NE.1) K(I,4)=2**(IB-1)
77701 K(I,5)=0
77702 P(I,1)=2D0*PARU(57)/K(I,3)
77703 V(I,1)=PARU(2)/K(I,4)
77704 DO 520 IP=1,4
77705 P(I,IP+1)=FAC*FM1FM(IM,IB,IP)
77706 V(I,IP+1)=SQRT(MAX(0D0,FAC*(FAC*FM2FM(IM,IB,IP)-
77707 & P(I,IP+1)**2)))
77708 520 CONTINUE
77709 530 CONTINUE
77710 540 CONTINUE
77711 N=30
77712 DO 550 J=1,5
77713 K(N+1,J)=0
77714 P(N+1,J)=0D0
77715 V(N+1,J)=0D0
77716 550 CONTINUE
77717 K(N+1,1)=32
77718 K(N+1,2)=99
77719 K(N+1,5)=NEVFM
77720 MSTU(3)=1
77721
77722C...Reset statistics on Energy-Energy Correlation.
77723 ELSEIF(MTABU.EQ.40) THEN
77724 NEVEE=0
77725 DO 560 J=1,25
77726 FE1EC(J)=0D0
77727 FE2EC(J)=0D0
77728 FE1EC(51-J)=0D0
77729 FE2EC(51-J)=0D0
77730 FE1EA(J)=0D0
77731 FE2EA(J)=0D0
77732 560 CONTINUE
77733
77734C...Find particles to include, with proper assumed mass.
77735 ELSEIF(MTABU.EQ.41) THEN
77736 NEVEE=NEVEE+1
77737 NLOW=N+MSTU(3)
77738 NUPP=NLOW
77739 ECM=0D0
77740 DO 570 I=1,N
77741 IF(K(I,1).LE.0.OR.K(I,1).GT.10) GOTO 570
77742 IF(MSTU(41).GE.2) THEN
77743 KC=PYCOMP(K(I,2))
77744 IF(KC.EQ.0.OR.KC.EQ.12.OR.KC.EQ.14.OR.KC.EQ.16.OR.
77745 & KC.EQ.18.OR.K(I,2).EQ.KSUSY1+22.OR.K(I,2).EQ.39.OR.
77746 & K(I,2).EQ.KSUSY1+39) GOTO 570
77747 IF(MSTU(41).GE.3.AND.KCHG(KC,2).EQ.0.AND.
77748 & PYCHGE(K(I,2)).EQ.0) GOTO 570
77749 ENDIF
77750 PMR=0D0
77751 IF(MSTU(42).EQ.1.AND.K(I,2).NE.22) PMR=PYMASS(211)
77752 IF(MSTU(42).GE.2) PMR=P(I,5)
77753 IF(NUPP.GT.MSTU(4)-5-MSTU(32)) THEN
77754 CALL PYERRM(11,'(PYTABU:) no more memory left in PYJETS')
77755 RETURN
77756 ENDIF
77757 NUPP=NUPP+1
77758 P(NUPP,1)=P(I,1)
77759 P(NUPP,2)=P(I,2)
77760 P(NUPP,3)=P(I,3)
77761 P(NUPP,4)=SQRT(PMR**2+P(I,1)**2+P(I,2)**2+P(I,3)**2)
77762 P(NUPP,5)=MAX(1D-10,SQRT(P(I,1)**2+P(I,2)**2+P(I,3)**2))
77763 ECM=ECM+P(NUPP,4)
77764 570 CONTINUE
77765 IF(NUPP.EQ.NLOW) RETURN
77766
77767C...Analyze Energy-Energy Correlation in event.
77768 FAC=(2D0/ECM**2)*50D0/PARU(1)
77769 DO 580 J=1,50
77770 FEVEE(J)=0D0
77771 580 CONTINUE
77772 DO 600 I1=NLOW+2,NUPP
77773 DO 590 I2=NLOW+1,I1-1
77774 CTHE=(P(I1,1)*P(I2,1)+P(I1,2)*P(I2,2)+P(I1,3)*P(I2,3))/
77775 & (P(I1,5)*P(I2,5))
77776 THE=ACOS(MAX(-1D0,MIN(1D0,CTHE)))
77777 ITHE=MAX(1,MIN(50,1+INT(50D0*THE/PARU(1))))
77778 FEVEE(ITHE)=FEVEE(ITHE)+FAC*P(I1,4)*P(I2,4)
77779 590 CONTINUE
77780 600 CONTINUE
77781 DO 610 J=1,25
77782 FE1EC(J)=FE1EC(J)+FEVEE(J)
77783 FE2EC(J)=FE2EC(J)+FEVEE(J)**2
77784 FE1EC(51-J)=FE1EC(51-J)+FEVEE(51-J)
77785 FE2EC(51-J)=FE2EC(51-J)+FEVEE(51-J)**2
77786 FE1EA(J)=FE1EA(J)+(FEVEE(51-J)-FEVEE(J))
77787 FE2EA(J)=FE2EA(J)+(FEVEE(51-J)-FEVEE(J))**2
77788 610 CONTINUE
77789 MSTU(62)=NUPP-NLOW
77790
77791C...Write statistics on Energy-Energy Correlation.
77792 ELSEIF(MTABU.EQ.42) THEN
77793 FAC=1D0/MAX(1,NEVEE)
77794 WRITE(MSTU(11),5700) NEVEE
77795 DO 620 J=1,25
77796 FEEC1=FAC*FE1EC(J)
77797 FEES1=SQRT(MAX(0D0,FAC*(FAC*FE2EC(J)-FEEC1**2)))
77798 FEEC2=FAC*FE1EC(51-J)
77799 FEES2=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-J)-FEEC2**2)))
77800 FEECA=FAC*FE1EA(J)
77801 FEESA=SQRT(MAX(0D0,FAC*(FAC*FE2EA(J)-FEECA**2)))
77802 WRITE(MSTU(11),5800) 3.6D0*(J-1),3.6D0*J,FEEC1,FEES1,
77803 & FEEC2,FEES2,FEECA,FEESA
77804 620 CONTINUE
77805
77806C...Copy statistics on Energy-Energy Correlation into /PYJETS/.
77807 ELSEIF(MTABU.EQ.43) THEN
77808 FAC=1D0/MAX(1,NEVEE)
77809 DO 630 I=1,25
77810 K(I,1)=32
77811 K(I,2)=99
77812 K(I,3)=0
77813 K(I,4)=0
77814 K(I,5)=0
77815 P(I,1)=FAC*FE1EC(I)
77816 V(I,1)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(I)-P(I,1)**2)))
77817 P(I,2)=FAC*FE1EC(51-I)
77818 V(I,2)=SQRT(MAX(0D0,FAC*(FAC*FE2EC(51-I)-P(I,2)**2)))
77819 P(I,3)=FAC*FE1EA(I)
77820 V(I,3)=SQRT(MAX(0D0,FAC*(FAC*FE2EA(I)-P(I,3)**2)))
77821 P(I,4)=PARU(1)*(I-1)/50D0
77822 P(I,5)=PARU(1)*I/50D0
77823 V(I,4)=3.6D0*(I-1)
77824 V(I,5)=3.6D0*I
77825 630 CONTINUE
77826 N=25
77827 DO 640 J=1,5
77828 K(N+1,J)=0
77829 P(N+1,J)=0D0
77830 V(N+1,J)=0D0
77831 640 CONTINUE
77832 K(N+1,1)=32
77833 K(N+1,2)=99
77834 K(N+1,5)=NEVEE
77835 MSTU(3)=1
77836
77837C...Reset statistics on decay channels.
77838 ELSEIF(MTABU.EQ.50) THEN
77839 NEVDC=0
77840 NKFDC=0
77841 NREDC=0
77842
77843C...Identify and order flavour content of final state.
77844 ELSEIF(MTABU.EQ.51) THEN
77845 NEVDC=NEVDC+1
77846 NDS=0
77847 DO 670 I=1,N
77848 IF(K(I,1).LE.0.OR.K(I,1).GE.6) GOTO 670
77849 NDS=NDS+1
77850 IF(NDS.GT.8) THEN
77851 NREDC=NREDC+1
77852 RETURN
77853 ENDIF
77854 KFM=2*IABS(K(I,2))
77855 IF(K(I,2).LT.0) KFM=KFM-1
77856 DO 650 IDS=NDS-1,1,-1
77857 IIN=IDS+1
77858 IF(KFM.LT.KFDM(IDS)) GOTO 660
77859 KFDM(IDS+1)=KFDM(IDS)
77860 650 CONTINUE
77861 IIN=1
77862 660 KFDM(IIN)=KFM
77863 670 CONTINUE
77864
77865C...Find whether old or new final state.
77866 DO 690 IDC=1,NKFDC
77867 IF(NDS.LT.KFDC(IDC,0)) THEN
77868 IKFDC=IDC
77869 GOTO 700
77870 ELSEIF(NDS.EQ.KFDC(IDC,0)) THEN
77871 DO 680 I=1,NDS
77872 IF(KFDM(I).LT.KFDC(IDC,I)) THEN
77873 IKFDC=IDC
77874 GOTO 700
77875 ELSEIF(KFDM(I).GT.KFDC(IDC,I)) THEN
77876 GOTO 690
77877 ENDIF
77878 680 CONTINUE
77879 IKFDC=-IDC
77880 GOTO 700
77881 ENDIF
77882 690 CONTINUE
77883 IKFDC=NKFDC+1
77884 700 IF(IKFDC.LT.0) THEN
77885 IKFDC=-IKFDC
77886 ELSEIF(NKFDC.GE.200) THEN
77887 NREDC=NREDC+1
77888 RETURN
77889 ELSE
77890 DO 720 IDC=NKFDC,IKFDC,-1
77891 NPDC(IDC+1)=NPDC(IDC)
77892 DO 710 I=0,8
77893 KFDC(IDC+1,I)=KFDC(IDC,I)
77894 710 CONTINUE
77895 720 CONTINUE
77896 NKFDC=NKFDC+1
77897 KFDC(IKFDC,0)=NDS
77898 DO 730 I=1,NDS
77899 KFDC(IKFDC,I)=KFDM(I)
77900 730 CONTINUE
77901 NPDC(IKFDC)=0
77902 ENDIF
77903 NPDC(IKFDC)=NPDC(IKFDC)+1
77904
77905C...Write statistics on decay channels.
77906 ELSEIF(MTABU.EQ.52) THEN
77907 FAC=1D0/MAX(1,NEVDC)
77908 WRITE(MSTU(11),5900) NEVDC
77909 DO 750 IDC=1,NKFDC
77910 DO 740 I=1,KFDC(IDC,0)
77911 KFM=KFDC(IDC,I)
77912 KF=(KFM+1)/2
77913 IF(2*KF.NE.KFM) KF=-KF
77914 CALL PYNAME(KF,CHAU)
77915 CHDC(I)=CHAU(1:12)
77916 IF(CHAU(13:13).NE.' ') CHDC(I)(12:12)='?'
77917 740 CONTINUE
77918 WRITE(MSTU(11),6000) FAC*NPDC(IDC),(CHDC(I),I=1,KFDC(IDC,0))
77919 750 CONTINUE
77920 IF(NREDC.NE.0) WRITE(MSTU(11),6100) FAC*NREDC
77921
77922C...Copy statistics on decay channels into /PYJETS/.
77923 ELSEIF(MTABU.EQ.53) THEN
77924 FAC=1D0/MAX(1,NEVDC)
77925 DO 780 IDC=1,NKFDC
77926 K(IDC,1)=32
77927 K(IDC,2)=99
77928 K(IDC,3)=0
77929 K(IDC,4)=0
77930 K(IDC,5)=KFDC(IDC,0)
77931 DO 760 J=1,5
77932 P(IDC,J)=0D0
77933 V(IDC,J)=0D0
77934 760 CONTINUE
77935 DO 770 I=1,KFDC(IDC,0)
77936 KFM=KFDC(IDC,I)
77937 KF=(KFM+1)/2
77938 IF(2*KF.NE.KFM) KF=-KF
77939 IF(I.LE.5) P(IDC,I)=KF
77940 IF(I.GE.6) V(IDC,I-5)=KF
77941 770 CONTINUE
77942 V(IDC,5)=FAC*NPDC(IDC)
77943 780 CONTINUE
77944 N=NKFDC
77945 DO 790 J=1,5
77946 K(N+1,J)=0
77947 P(N+1,J)=0D0
77948 V(N+1,J)=0D0
77949 790 CONTINUE
77950 K(N+1,1)=32
77951 K(N+1,2)=99
77952 K(N+1,5)=NEVDC
77953 V(N+1,5)=FAC*NREDC
77954 MSTU(3)=1
77955 ENDIF
77956
77957C...Format statements for output on unit MSTU(11) (default 6).
77958 5000 FORMAT(///20X,'Event statistics - initial state'/
77959 &20X,'based on an analysis of ',I6,' events'//
77960 &3X,'Main flavours after',8X,'Fraction',4X,'Subfractions ',
77961 &'according to fragmenting system multiplicity'/
77962 &4X,'hard interaction',24X,'1',7X,'2',7X,'3',7X,'4',7X,'5',
77963 &6X,'6-7',5X,'8-10',3X,'11-15',3X,'16-25',4X,'>25'/)
77964 5100 FORMAT(3X,A12,1X,A12,F10.5,1X,10F8.4)
77965 5200 FORMAT(///20X,'Event statistics - final state'/
77966 &20X,'based on an analysis of ',I7,' events'//
77967 &5X,'Mean primary multiplicity =',F10.4/
77968 &5X,'Mean final multiplicity =',F10.4/
77969 &5X,'Mean charged multiplicity =',F10.4//
77970 &5X,'Number of particles produced per event (directly and via ',
77971 &'decays/branchings)'/
77972 &8X,'KF Particle/jet MDCY',10X,'Particles',13X,'Antiparticles',
77973 &8X,'Total'/35X,'prim seco prim seco'/)
77974 5300 FORMAT(1X,I9,4X,A16,I2,5(1X,F11.6))
77975 5400 FORMAT(///20X,'Factorial moments analysis of multiplicity'/
77976 &20X,'based on an analysis of ',I6,' events'//
77977 &3X,'delta-',A3,' delta-phi <n>/bin',10X,'<F2>',18X,'<F3>',
77978 &18X,'<F4>',18X,'<F5>'/35X,4(' value error '))
77979 5500 FORMAT(10X)
77980 5600 FORMAT(2X,2F10.4,F12.4,4(F12.4,F10.4))
77981 5700 FORMAT(///20X,'Energy-Energy Correlation and Asymmetry'/
77982 &20X,'based on an analysis of ',I6,' events'//
77983 &2X,'theta range',8X,'EEC(theta)',8X,'EEC(180-theta)',7X,
77984 &'EECA(theta)'/2X,'in degrees ',3(' value error')/)
77985 5800 FORMAT(2X,F4.1,' - ',F4.1,3(F11.4,F9.4))
77986 5900 FORMAT(///20X,'Decay channel analysis - final state'/
77987 &20X,'based on an analysis of ',I6,' events'//
77988 &2X,'Probability',10X,'Complete final state'/)
77989 6000 FORMAT(2X,F9.5,5X,8(A12,1X))
77990 6100 FORMAT(2X,F9.5,5X,'into other channels (more than 8 particles ',
77991 &'or table overflow)')
77992
77993 RETURN
77994 END
77995
77996C*********************************************************************
77997
77998C...PYEEVT
77999C...Handles the generation of an e+e- annihilation jet event.
78000
78001 SUBROUTINE PYEEVT(KFL,ECM)
78002
78003C...Double precision and integer declarations.
78004 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78005 IMPLICIT INTEGER(I-N)
78006 INTEGER PYK,PYCHGE,PYCOMP
78007C...Commonblocks.
78008 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
78009 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78010 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
78011 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
78012
78013C...Check input parameters.
78014 IF(MSTU(12).NE.12345) CALL PYLIST(0)
78015 IF(KFL.LT.0.OR.KFL.GT.8) THEN
78016 CALL PYERRM(16,'(PYEEVT:) called with unknown flavour code')
78017 IF(MSTU(21).GE.1) RETURN
78018 ENDIF
78019 IF(KFL.LE.5) ECMMIN=PARJ(127)+2.02D0*PARF(100+MAX(1,KFL))
78020 IF(KFL.GE.6) ECMMIN=PARJ(127)+2.02D0*PMAS(KFL,1)
78021 IF(ECM.LT.ECMMIN) THEN
78022 CALL PYERRM(16,'(PYEEVT:) called with too small CM energy')
78023 IF(MSTU(21).GE.1) RETURN
78024 ENDIF
78025
78026C...Check consistency of MSTJ options set.
78027 IF(MSTJ(109).EQ.2.AND.MSTJ(110).NE.1) THEN
78028 CALL PYERRM(6,
78029 & '(PYEEVT:) MSTJ(109) value requires MSTJ(110) = 1')
78030 MSTJ(110)=1
78031 ENDIF
78032 IF(MSTJ(109).EQ.2.AND.MSTJ(111).NE.0) THEN
78033 CALL PYERRM(6,
78034 & '(PYEEVT:) MSTJ(109) value requires MSTJ(111) = 0')
78035 MSTJ(111)=0
78036 ENDIF
78037
78038C...Initialize alpha_strong and total cross-section.
78039 MSTU(111)=MSTJ(108)
78040 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
78041 &MSTU(111)=1
78042 PARU(112)=PARJ(121)
78043 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
78044 IF(MSTJ(116).GT.0.AND.(MSTJ(116).GE.2.OR.ABS(ECM-PARJ(151)).GE.
78045 &PARJ(139).OR.10*MSTJ(102)+KFL.NE.MSTJ(119))) CALL PYXTEE(KFL,ECM,
78046 &XTOT)
78047 IF(MSTJ(116).GE.3) MSTJ(116)=1
78048 PARJ(171)=0D0
78049
78050C...Add initial e+e- to event record (documentation only).
78051 NTRY=0
78052 100 NTRY=NTRY+1
78053 IF(NTRY.GT.100) THEN
78054 CALL PYERRM(14,'(PYEEVT:) caught in an infinite loop')
78055 RETURN
78056 ENDIF
78057 MSTU(24)=0
78058 NC=0
78059 IF(MSTJ(115).GE.2) THEN
78060 NC=NC+2
78061 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
78062 K(NC-1,1)=21
78063 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
78064 K(NC,1)=21
78065 ENDIF
78066
78067C...Radiative photon (in initial state).
78068 MK=0
78069 ECMC=ECM
78070 IF(MSTJ(107).GE.1.AND.MSTJ(116).GE.1) CALL PYRADK(ECM,MK,PAK,
78071 &THEK,PHIK,ALPK)
78072 IF(MK.EQ.1) ECMC=SQRT(ECM*(ECM-2D0*PAK))
78073 IF(MSTJ(115).GE.1.AND.MK.EQ.1) THEN
78074 NC=NC+1
78075 CALL PY1ENT(NC,22,PAK,THEK,PHIK)
78076 K(NC,3)=MIN(MSTJ(115)/2,1)
78077 ENDIF
78078
78079C...Virtual exchange boson (gamma or Z0).
78080 IF(MSTJ(115).GE.3) THEN
78081 NC=NC+1
78082 KF=22
78083 IF(MSTJ(102).EQ.2) KF=23
78084 MSTU10=MSTU(10)
78085 MSTU(10)=1
78086 P(NC,5)=ECMC
78087 CALL PY1ENT(NC,KF,ECMC,0D0,0D0)
78088 K(NC,1)=21
78089 K(NC,3)=1
78090 MSTU(10)=MSTU10
78091 ENDIF
78092
78093C...Choice of flavour and jet configuration.
78094 CALL PYXKFL(KFL,ECM,ECMC,KFLC)
78095 IF(KFLC.EQ.0) GOTO 100
78096 CALL PYXJET(ECMC,NJET,CUT)
78097 KFLN=21
78098 IF(NJET.EQ.4) CALL PYX4JT(NJET,CUT,KFLC,ECMC,KFLN,X1,X2,X4,
78099 &X12,X14)
78100 IF(NJET.EQ.3) CALL PYX3JT(NJET,CUT,KFLC,ECMC,X1,X3)
78101 IF(NJET.EQ.2) MSTJ(120)=1
78102
78103C...Fill jet configuration and origin.
78104 IF(NJET.EQ.2.AND.MSTJ(101).NE.5) CALL PY2ENT(NC+1,KFLC,-KFLC,ECMC)
78105 IF(NJET.EQ.2.AND.MSTJ(101).EQ.5) CALL PY2ENT(-(NC+1),KFLC,-KFLC,
78106 &ECMC)
78107 IF(NJET.EQ.3) CALL PY3ENT(NC+1,KFLC,21,-KFLC,ECMC,X1,X3)
78108 IF(NJET.EQ.4.AND.KFLN.EQ.21) CALL PY4ENT(NC+1,KFLC,KFLN,KFLN,
78109 &-KFLC,ECMC,X1,X2,X4,X12,X14)
78110 IF(NJET.EQ.4.AND.KFLN.NE.21) CALL PY4ENT(NC+1,KFLC,-KFLN,KFLN,
78111 &-KFLC,ECMC,X1,X2,X4,X12,X14)
78112 IF(MSTU(24).NE.0) GOTO 100
78113 DO 110 IP=NC+1,N
78114 K(IP,3)=K(IP,3)+MIN(MSTJ(115)/2,1)+(MSTJ(115)/3)*(NC-1)
78115 110 CONTINUE
78116
78117C...Angular orientation according to matrix element.
78118 IF(MSTJ(106).EQ.1) THEN
78119 CALL PYXDIF(NC,NJET,KFLC,ECMC,CHI,THE,PHI)
78120 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
78121 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
78122 ENDIF
78123
78124C...Rotation and boost from radiative photon.
78125 IF(MK.EQ.1) THEN
78126 DBEK=-PAK/(ECM-PAK)
78127 NMIN=NC+1-MSTJ(115)/3
78128 CALL PYROBO(NMIN,N,0D0,-PHIK,0D0,0D0,0D0)
78129 CALL PYROBO(NMIN,N,ALPK,0D0,DBEK*SIN(THEK),0D0,DBEK*COS(THEK))
78130 CALL PYROBO(NMIN,N,0D0,PHIK,0D0,0D0,0D0)
78131 ENDIF
78132
78133C...Generate parton shower. Rearrange along strings and check.
78134 IF(MSTJ(101).EQ.5) THEN
78135 CALL PYSHOW(N-1,N,ECMC)
78136 MSTJ14=MSTJ(14)
78137 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
78138 IF(MSTJ(105).GE.0) MSTU(28)=0
78139 CALL PYPREP(0)
78140 MSTJ(14)=MSTJ14
78141 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
78142 ENDIF
78143
78144C...Fragmentation/decay generation. Information for PYTABU.
78145 IF(MSTJ(105).EQ.1) CALL PYEXEC
78146 MSTU(161)=KFLC
78147 MSTU(162)=-KFLC
78148
78149 RETURN
78150 END
78151
78152C*********************************************************************
78153
78154C...PYXTEE
78155C...Calculates total cross-section, including initial state
78156C...radiation effects.
78157
78158 SUBROUTINE PYXTEE(KFL,ECM,XTOT)
78159
78160C...Double precision and integer declarations.
78161 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78162 IMPLICIT INTEGER(I-N)
78163 INTEGER PYK,PYCHGE,PYCOMP
78164C...Commonblocks.
78165 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78166 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
78167 SAVE /PYDAT1/,/PYDAT2/
78168
78169C...Status, (optimized) Q^2 scale, alpha_strong.
78170 PARJ(151)=ECM
78171 MSTJ(119)=10*MSTJ(102)+KFL
78172 IF(MSTJ(111).EQ.0) THEN
78173 Q2R=ECM**2
78174 ELSEIF(MSTU(111).EQ.0) THEN
78175 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
78176 & ((33D0-2D0*MSTU(112))*PARU(111)))))
78177 Q2R=PARJ(168)*ECM**2
78178 ELSE
78179 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
78180 & (2D0*PARU(112)/ECM)**2))
78181 Q2R=PARJ(168)*ECM**2
78182 ENDIF
78183 ALSPI=PYALPS(Q2R)/PARU(1)
78184
78185C...QCD corrections factor in R.
78186 IF(MSTJ(101).EQ.0.OR.MSTJ(109).EQ.1) THEN
78187 RQCD=1D0
78188 ELSEIF(IABS(MSTJ(101)).EQ.1.AND.MSTJ(109).EQ.0) THEN
78189 RQCD=1D0+ALSPI
78190 ELSEIF(MSTJ(109).EQ.0) THEN
78191 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
78192 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+(33D0-2D0*MSTU(112))/12D0*
78193 & LOG(PARJ(168))*ALSPI**2)
78194 ELSEIF(IABS(MSTJ(101)).EQ.1) THEN
78195 RQCD=1D0+(3D0/4D0)*ALSPI
78196 ELSE
78197 RQCD=1D0+(3D0/4D0)*ALSPI-(3D0/32D0+0.519D0*MSTU(118))*ALSPI**2
78198 ENDIF
78199
78200C...Calculate Z0 width if default value not acceptable.
78201 IF(MSTJ(102).GE.3) THEN
78202 RVA=3D0*(3D0+(4D0*PARU(102)-1D0)**2)+6D0*RQCD*(2D0+
78203 & (1D0-8D0*PARU(102)/3D0)**2+(4D0*PARU(102)/3D0-1D0)**2)
78204 DO 100 KFLC=5,6
78205 VQ=1D0
78206 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-
78207 & (2D0*PYMASS(KFLC)/ ECM)**2))
78208 IF(KFLC.EQ.5) VF=4D0*PARU(102)/3D0-1D0
78209 IF(KFLC.EQ.6) VF=1D0-8D0*PARU(102)/3D0
78210 RVA=RVA+3D0*RQCD*(0.5D0*VQ*(3D0-VQ**2)*VF**2+VQ**3)
78211 100 CONTINUE
78212 PARJ(124)=PARU(101)*PARJ(123)*RVA/(48D0*PARU(102)*
78213 & (1D0-PARU(102)))
78214 ENDIF
78215
78216C...Calculate propagator and related constants for QFD case.
78217 POLL=1D0-PARJ(131)*PARJ(132)
78218 IF(MSTJ(102).GE.2) THEN
78219 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
78220 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
78221 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
78222 VE=4D0*PARU(102)-1D0
78223 SF1I=SFF*(VE*POLL+PARJ(132)-PARJ(131))
78224 SF1W=SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
78225 HF1I=SFI*SF1I
78226 HF1W=SFW*SF1W
78227 ENDIF
78228
78229C...Loop over different flavours: charge, velocity.
78230 RTOT=0D0
78231 RQQ=0D0
78232 RQV=0D0
78233 RVA=0D0
78234 DO 110 KFLC=1,MAX(MSTJ(104),KFL)
78235 IF(KFL.GT.0.AND.KFLC.NE.KFL) GOTO 110
78236 MSTJ(93)=1
78237 PMQ=PYMASS(KFLC)
78238 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 110
78239 QF=KCHG(KFLC,1)/3D0
78240 VQ=1D0
78241 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(1D0-(2D0*PMQ/ECM)**2)
78242
78243C...Calculate R and sum of charges for QED or QFD case.
78244 RQQ=RQQ+3D0*QF**2*POLL
78245 IF(MSTJ(102).LE.1) THEN
78246 RTOT=RTOT+3D0*0.5D0*VQ*(3D0-VQ**2)*QF**2*POLL
78247 ELSE
78248 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
78249 RQV=RQV-6D0*QF*VF*SF1I
78250 RVA=RVA+3D0*(VF**2+1D0)*SF1W
78251 RTOT=RTOT+3D0*(0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-
78252 & 2D0*QF*VF*HF1I+VF**2*HF1W)+VQ**3*HF1W)
78253 ENDIF
78254 110 CONTINUE
78255 RSUM=RQQ
78256 IF(MSTJ(102).GE.2) RSUM=RQQ+SFI*RQV+SFW*RVA
78257
78258C...Calculate cross-section, including QCD corrections.
78259 PARJ(141)=RQQ
78260 PARJ(142)=RTOT
78261 PARJ(143)=RTOT*RQCD
78262 PARJ(144)=PARJ(143)
78263 PARJ(145)=PARJ(141)*86.8D0/ECM**2
78264 PARJ(146)=PARJ(142)*86.8D0/ECM**2
78265 PARJ(147)=PARJ(143)*86.8D0/ECM**2
78266 PARJ(148)=PARJ(147)
78267 PARJ(157)=RSUM*RQCD
78268 PARJ(158)=0D0
78269 PARJ(159)=0D0
78270 XTOT=PARJ(147)
78271 IF(MSTJ(107).LE.0) RETURN
78272
78273C...Virtual cross-section.
78274 XKL=PARJ(135)
78275 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
78276 ALE=2D0*LOG(ECM/PYMASS(11))-1D0
78277 SIGV=ALE/3D0+2D0*LOG(ECM**2/(PYMASS(13)*PYMASS(15)))/3D0-4D0/3D0+
78278 &1.526D0*LOG(ECM**2/0.932D0)
78279
78280C...Soft and hard radiative cross-section in QED case.
78281 IF(MSTJ(102).LE.1) THEN
78282 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+2D0*SIGV
78283 SIGS=ALE*(2D0*LOG(XKL)-LOG(1D0-XKL)-XKL)
78284 SIGH=ALE*(2D0*LOG(XKU/XKL)-LOG((1D0-XKU)/(1D0-XKL))-(XKU-XKL))
78285
78286C...Soft and hard radiative cross-section in QFD case.
78287 ELSE
78288 SZM=1D0-(PARJ(123)/ECM)**2
78289 SZW=PARJ(123)*PARJ(124)/ECM**2
78290 PARJ(161)=-RQQ/RSUM
78291 PARJ(162)=-(RQQ+RQV+RVA)/RSUM
78292 PARJ(163)=(RQV*(1D0-0.5D0*SZM-SFI)+RVA*(1.5D0-SZM-SFW))/RSUM
78293 PARJ(164)=(RQV*SZW**2*(1D0-2D0*SFW)+RVA*(2D0*SFI+SZW**2-
78294 & 4D0+3D0*SZM-SZM**2))/(SZW*RSUM)
78295 SIGV=1.5D0*ALE-0.5D0+PARU(1)**2/3D0+((2D0*RQQ+SFI*RQV)/
78296 & RSUM)*SIGV+(SZW*SFW*RQV/RSUM)*PARU(1)*20D0/9D0
78297 SIGS=ALE*(2D0*LOG(XKL)+PARJ(161)*LOG(1D0-XKL)+PARJ(162)*XKL+
78298 & PARJ(163)*LOG(((XKL-SZM)**2+SZW**2)/(SZM**2+SZW**2))+
78299 & PARJ(164)*(ATAN((XKL-SZM)/SZW)-ATAN(-SZM/SZW)))
78300 SIGH=ALE*(2D0*LOG(XKU/XKL)+PARJ(161)*LOG((1D0-XKU)/
78301 & (1D0-XKL))+PARJ(162)*(XKU-XKL)+PARJ(163)*
78302 & LOG(((XKU-SZM)**2+SZW**2)/((XKL-SZM)**2+SZW**2))+
78303 & PARJ(164)*(ATAN((XKU-SZM)/SZW)-ATAN((XKL-SZM)/SZW)))
78304 ENDIF
78305
78306C...Total cross-section and fraction of hard photon events.
78307 PARJ(160)=SIGH/(PARU(1)/PARU(101)+SIGV+SIGS+SIGH)
78308 PARJ(157)=RSUM*(1D0+(PARU(101)/PARU(1))*(SIGV+SIGS+SIGH))*RQCD
78309 PARJ(144)=PARJ(157)
78310 PARJ(148)=PARJ(144)*86.8D0/ECM**2
78311 XTOT=PARJ(148)
78312
78313 RETURN
78314 END
78315
78316C*********************************************************************
78317
78318C...PYRADK
78319C...Generates initial state photon radiation.
78320
78321 SUBROUTINE PYRADK(ECM,MK,PAK,THEK,PHIK,ALPK)
78322
78323C...Double precision and integer declarations.
78324 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78325 IMPLICIT INTEGER(I-N)
78326 INTEGER PYK,PYCHGE,PYCOMP
78327C...Commonblocks.
78328 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78329 SAVE /PYDAT1/
78330
78331C...Function: cumulative hard photon spectrum in QFD case.
78332 FXK(XX)=2D0*LOG(XX)+PARJ(161)*LOG(1D0-XX)+PARJ(162)*XX+
78333 &PARJ(163)*LOG((XX-SZM)**2+SZW**2)+PARJ(164)*ATAN((XX-SZM)/SZW)
78334
78335C...Determine whether radiative photon or not.
78336 MK=0
78337 PAK=0D0
78338 IF(PARJ(160).LT.PYR(0)) RETURN
78339 MK=1
78340
78341C...Photon energy range. Find photon momentum in QED case.
78342 XKL=PARJ(135)
78343 XKU=MIN(PARJ(136),1D0-(2D0*PARJ(127)/ECM)**2)
78344 IF(MSTJ(102).LE.1) THEN
78345 100 XK=1D0/(1D0+(1D0/XKL-1D0)*((1D0/XKU-1D0)/(1D0/XKL-1D0))**PYR(0))
78346 IF(1D0+(1D0-XK)**2.LT.2D0*PYR(0)) GOTO 100
78347
78348C...Ditto in QFD case, by numerical inversion of integrated spectrum.
78349 ELSE
78350 SZM=1D0-(PARJ(123)/ECM)**2
78351 SZW=PARJ(123)*PARJ(124)/ECM**2
78352 FXKL=FXK(XKL)
78353 FXKU=FXK(XKU)
78354 FXKD=1D-4*(FXKU-FXKL)
78355 FXKR=FXKL+PYR(0)*(FXKU-FXKL)
78356 NXK=0
78357 110 NXK=NXK+1
78358 XK=0.5D0*(XKL+XKU)
78359 FXKV=FXK(XK)
78360 IF(FXKV.GT.FXKR) THEN
78361 XKU=XK
78362 FXKU=FXKV
78363 ELSE
78364 XKL=XK
78365 FXKL=FXKV
78366 ENDIF
78367 IF(NXK.LT.15.AND.FXKU-FXKL.GT.FXKD) GOTO 110
78368 XK=XKL+(XKU-XKL)*(FXKR-FXKL)/(FXKU-FXKL)
78369 ENDIF
78370 PAK=0.5D0*ECM*XK
78371
78372C...Photon polar and azimuthal angle.
78373 PME=2D0*(PYMASS(11)/ECM)**2
78374 120 CTHM=PME*(2D0/PME)**PYR(0)
78375 IF(1D0-(XK**2*CTHM*(1D0-0.5D0*CTHM)+2D0*(1D0-XK)*PME/MAX(PME,
78376 &CTHM*(1D0-0.5D0*CTHM)))/(1D0+(1D0-XK)**2).LT.PYR(0)) GOTO 120
78377 CTHE=1D0-CTHM
78378 IF(PYR(0).GT.0.5D0) CTHE=-CTHE
78379 STHE=SQRT(MAX(0D0,(CTHM-PME)*(2D0-CTHM)))
78380 THEK=PYANGL(CTHE,STHE)
78381 PHIK=PARU(2)*PYR(0)
78382
78383C...Rotation angle for hadronic system.
78384 SGN=1D0
78385 IF(0.5D0*(2D0-XK*(1D0-CTHE))**2/((2D0-XK)**2+(XK*CTHE)**2).GT.
78386 &PYR(0)) SGN=-1D0
78387 ALPK=ASIN(SGN*STHE*(XK-SGN*(2D0*SQRT(1D0-XK)-2D0+XK)*CTHE)/
78388 &(2D0-XK*(1D0-SGN*CTHE)))
78389
78390 RETURN
78391 END
78392
78393C*********************************************************************
78394
78395C...PYXKFL
78396C...Selects flavour for produced qqbar pair.
78397
78398 SUBROUTINE PYXKFL(KFL,ECM,ECMC,KFLC)
78399
78400C...Double precision and integer declarations.
78401 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78402 IMPLICIT INTEGER(I-N)
78403 INTEGER PYK,PYCHGE,PYCOMP
78404C...Commonblocks.
78405 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78406 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
78407 SAVE /PYDAT1/,/PYDAT2/
78408
78409C...Calculate maximum weight in QED or QFD case.
78410 IF(MSTJ(102).LE.1) THEN
78411 RFMAX=4D0/9D0
78412 ELSE
78413 POLL=1D0-PARJ(131)*PARJ(132)
78414 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
78415 SFW=ECMC**4/((ECMC**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
78416 SFI=SFW*(1D0-(PARJ(123)/ECMC)**2)
78417 VE=4D0*PARU(102)-1D0
78418 HF1I=SFI*SFF*(VE*POLL+PARJ(132)-PARJ(131))
78419 HF1W=SFW*SFF**2*((VE**2+1D0)*POLL+2D0*VE*(PARJ(132)-PARJ(131)))
78420 RFMAX=MAX(4D0/9D0*POLL-4D0/3D0*(1D0-8D0*PARU(102)/3D0)*HF1I+
78421 & ((1D0-8D0*PARU(102)/3D0)**2+1D0)*HF1W,1D0/9D0*POLL+2D0/3D0*
78422 & (-1D0+4D0*PARU(102)/3D0)*HF1I+((-1D0+4D0*PARU(102)/3D0)**2+
78423 & 1D0)*HF1W)
78424 ENDIF
78425
78426C...Choose flavour. Gives charge and velocity.
78427 NTRY=0
78428 100 NTRY=NTRY+1
78429 IF(NTRY.GT.100) THEN
78430 CALL PYERRM(14,'(PYXKFL:) caught in an infinite loop')
78431 KFLC=0
78432 RETURN
78433 ENDIF
78434 KFLC=KFL
78435 IF(KFL.LE.0) KFLC=1+INT(MSTJ(104)*PYR(0))
78436 MSTJ(93)=1
78437 PMQ=PYMASS(KFLC)
78438 IF(ECM.LT.2D0*PMQ+PARJ(127)) GOTO 100
78439 QF=KCHG(KFLC,1)/3D0
78440 VQ=1D0
78441 IF(MOD(MSTJ(103),2).EQ.1) VQ=SQRT(MAX(0D0,1D0-(2D0*PMQ/ECMC)**2))
78442
78443C...Calculate weight in QED or QFD case.
78444 IF(MSTJ(102).LE.1) THEN
78445 RF=QF**2
78446 RFV=0.5D0*VQ*(3D0-VQ**2)*QF**2
78447 ELSE
78448 VF=SIGN(1D0,QF)-4D0*QF*PARU(102)
78449 RF=QF**2*POLL-2D0*QF*VF*HF1I+(VF**2+1D0)*HF1W
78450 RFV=0.5D0*VQ*(3D0-VQ**2)*(QF**2*POLL-2D0*QF*VF*HF1I+VF**2*HF1W)+
78451 & VQ**3*HF1W
78452 IF(RFV.GT.0D0) PARJ(171)=MIN(1D0,VQ**3*HF1W/RFV)
78453 ENDIF
78454
78455C...Weighting or new event (radiative photon). Cross-section update.
78456 IF(KFL.LE.0.AND.RF.LT.PYR(0)*RFMAX) GOTO 100
78457 PARJ(158)=PARJ(158)+1D0
78458 IF(ECMC.LT.2D0*PMQ+PARJ(127).OR.RFV.LT.PYR(0)*RF) KFLC=0
78459 IF(MSTJ(107).LE.0.AND.KFLC.EQ.0) GOTO 100
78460 IF(KFLC.NE.0) PARJ(159)=PARJ(159)+1D0
78461 PARJ(144)=PARJ(157)*PARJ(159)/PARJ(158)
78462 PARJ(148)=PARJ(144)*86.8D0/ECM**2
78463
78464 RETURN
78465 END
78466
78467C*********************************************************************
78468
78469C...PYXJET
78470C...Selects number of jets in matrix element approach.
78471
78472 SUBROUTINE PYXJET(ECM,NJET,CUT)
78473
78474C...Double precision and integer declarations.
78475 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78476 IMPLICIT INTEGER(I-N)
78477 INTEGER PYK,PYCHGE,PYCOMP
78478C...Commonblocks.
78479 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78480 SAVE /PYDAT1/
78481C...Local array and data.
78482 DIMENSION ZHUT(5)
78483 DATA ZHUT/3.0922D0, 6.2291D0, 7.4782D0, 7.8440D0, 8.2560D0/
78484
78485C...Trivial result for two-jets only, including parton shower.
78486 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
78487 CUT=0D0
78488
78489C...QCD and Abelian vector gluon theory: Q^2 for jet rate and R.
78490 ELSEIF(MSTJ(109).EQ.0.OR.MSTJ(109).EQ.2) THEN
78491 CF=4D0/3D0
78492 IF(MSTJ(109).EQ.2) CF=1D0
78493 IF(MSTJ(111).EQ.0) THEN
78494 Q2=ECM**2
78495 Q2R=ECM**2
78496 ELSEIF(MSTU(111).EQ.0) THEN
78497 PARJ(169)=MIN(1D0,PARJ(129))
78498 Q2=PARJ(169)*ECM**2
78499 PARJ(168)=MIN(1D0,MAX(PARJ(128),EXP(-12D0*PARU(1)/
78500 & ((33D0-2D0*MSTU(112))*PARU(111)))))
78501 Q2R=PARJ(168)*ECM**2
78502 ELSE
78503 PARJ(169)=MIN(1D0,MAX(PARJ(129),(2D0*PARU(112)/ECM)**2))
78504 Q2=PARJ(169)*ECM**2
78505 PARJ(168)=MIN(1D0,MAX(PARJ(128),PARU(112)/ECM,
78506 & (2D0*PARU(112)/ECM)**2))
78507 Q2R=PARJ(168)*ECM**2
78508 ENDIF
78509
78510C...alpha_strong for R and R itself.
78511 ALSPI=(3D0/4D0)*CF*PYALPS(Q2R)/PARU(1)
78512 IF(IABS(MSTJ(101)).EQ.1) THEN
78513 RQCD=1D0+ALSPI
78514 ELSEIF(MSTJ(109).EQ.0) THEN
78515 RQCD=1D0+ALSPI+(1.986D0-0.115D0*MSTU(118))*ALSPI**2
78516 IF(MSTJ(111).EQ.1) RQCD=MAX(1D0,RQCD+
78517 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(168))*ALSPI**2)
78518 ELSE
78519 RQCD=1D0+ALSPI-(3D0/32D0+0.519D0*MSTU(118))*(4D0*ALSPI/3D0)**2
78520 ENDIF
78521
78522C...alpha_strong for jet rate. Initial value for y cut.
78523 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
78524 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2)
78525 IF(IABS(MSTJ(101)).LE.1.OR.(MSTJ(109).EQ.0.AND.MSTJ(111).EQ.0))
78526 & CUT=MAX(CUT,EXP(-SQRT(0.75D0/ALSPI))/2D0)
78527 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
78528
78529C...Parametrization of first order three-jet cross-section.
78530 100 IF(MSTJ(101).EQ.0.OR.CUT.GE.0.25D0) THEN
78531 PARJ(152)=0D0
78532 ELSE
78533 PARJ(152)=(2D0*ALSPI/3D0)*((3D0-6D0*CUT+2D0*LOG(CUT))*
78534 & LOG(CUT/(1D0-2D0*CUT))+(2.5D0+1.5D0*CUT-6.571D0)*
78535 & (1D0-3D0*CUT)+5.833D0*(1D0-3D0*CUT)**2-3.894D0*
78536 & (1D0-3D0*CUT)**3+1.342D0*(1D0-3D0*CUT)**4)/RQCD
78537 IF(MSTJ(109).EQ.2.AND.(MSTJ(101).EQ.2.OR.MSTJ(101).LE.-2))
78538 & PARJ(152)=0D0
78539 ENDIF
78540
78541C...Parametrization of second order three-jet cross-section.
78542 IF(IABS(MSTJ(101)).LE.1.OR.MSTJ(101).EQ.3.OR.MSTJ(109).EQ.2.OR.
78543 & CUT.GE.0.25D0) THEN
78544 PARJ(153)=0D0
78545 ELSEIF(MSTJ(110).LE.1) THEN
78546 CT=LOG(1D0/CUT-2D0)
78547 PARJ(153)=ALSPI**2*CT**2*(2.419D0+0.5989D0*CT+0.6782D0*CT**2-
78548 & 0.2661D0*CT**3+0.01159D0*CT**4)/RQCD
78549
78550C...Interpolation in second/first order ratio for Zhu parametrization.
78551 ELSEIF(MSTJ(110).EQ.2) THEN
78552 IZA=0
78553 DO 110 IY=1,5
78554 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
78555 110 CONTINUE
78556 IF(IZA.NE.0) THEN
78557 ZHURAT=ZHUT(IZA)
78558 ELSE
78559 IZ=100D0*CUT
78560 ZHURAT=ZHUT(IZ)+(100D0*CUT-IZ)*(ZHUT(IZ+1)-ZHUT(IZ))
78561 ENDIF
78562 PARJ(153)=ALSPI*PARJ(152)*ZHURAT
78563 ENDIF
78564
78565C...Shift in second order three-jet cross-section with optimized Q^2.
78566 IF(MSTJ(111).EQ.1.AND.IABS(MSTJ(101)).GE.2.AND.MSTJ(101).NE.3
78567 & .AND.CUT.LT.0.25D0) PARJ(153)=PARJ(153)+
78568 & (33D0-2D0*MSTU(112))/12D0*LOG(PARJ(169))*ALSPI*PARJ(152)
78569
78570C...Parametrization of second order four-jet cross-section.
78571 IF(IABS(MSTJ(101)).LE.1.OR.CUT.GE.0.125D0) THEN
78572 PARJ(154)=0D0
78573 ELSE
78574 CT=LOG(1D0/CUT-5D0)
78575 IF(CUT.LE.0.018D0) THEN
78576 XQQGG=6.349D0-4.330D0*CT+0.8304D0*CT**2
78577 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(3.035D0-2.091D0*CT+
78578 & 0.4059D0*CT**2)
78579 XQQQQ=1.25D0*(-0.1080D0+0.01486D0*CT+0.009364D0*CT**2)
78580 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
78581 ELSE
78582 XQQGG=-0.09773D0+0.2959D0*CT-0.2764D0*CT**2+0.08832D0*CT**3
78583 IF(MSTJ(109).EQ.2) XQQGG=(4D0/3D0)**2*(-0.04079D0+
78584 & 0.1340D0*CT-0.1326D0*CT**2+0.04365D0*CT**3)
78585 XQQQQ=1.25D0*(0.003661D0-0.004888D0*CT-0.001081D0*CT**2+
78586 & 0.002093D0*CT**3)
78587 IF(MSTJ(109).EQ.2) XQQQQ=8D0*XQQQQ
78588 ENDIF
78589 PARJ(154)=ALSPI**2*CT**2*(XQQGG+XQQQQ)/RQCD
78590 PARJ(155)=XQQQQ/(XQQGG+XQQQQ)
78591 ENDIF
78592
78593C...If negative three-jet rate, change y' optimization parameter.
78594 IF(MSTJ(111).EQ.1.AND.PARJ(152)+PARJ(153).LT.0D0.AND.
78595 & PARJ(169).LT.0.99D0) THEN
78596 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
78597 Q2=PARJ(169)*ECM**2
78598 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
78599 GOTO 100
78600 ENDIF
78601
78602C...If too high cross-section, use harder cuts, or fail.
78603 IF(PARJ(152)+PARJ(153)+PARJ(154).GE.1) THEN
78604 IF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0.AND.MSTJ(111).EQ.1.AND.
78605 & PARJ(169).LT.0.99D0) THEN
78606 PARJ(169)=MIN(1D0,1.2D0*PARJ(169))
78607 Q2=PARJ(169)*ECM**2
78608 ALSPI=(3D0/4D0)*CF*PYALPS(Q2)/PARU(1)
78609 GOTO 100
78610 ELSEIF(MSTJ(110).EQ.2.AND.CUT.GT.0.0499D0) THEN
78611 CALL PYERRM(26,
78612 & '(PYXJET:) no allowed y cut value for Zhu parametrization')
78613 ENDIF
78614 CUT=0.26D0*(4D0*CUT)**(PARJ(152)+PARJ(153)+
78615 & PARJ(154))**(-1D0/3D0)
78616 IF(MSTJ(110).EQ.2) CUT=MAX(0.01D0,MIN(0.05D0,CUT))
78617 GOTO 100
78618 ENDIF
78619
78620C...Scalar gluon (first order only).
78621 ELSE
78622 ALSPI=PYALPS(ECM**2)/PARU(1)
78623 CUT=MAX(0.001D0,PARJ(125),(PARJ(126)/ECM)**2,EXP(-3D0/ALSPI))
78624 PARJ(152)=0D0
78625 IF(CUT.LT.0.25D0) PARJ(152)=(ALSPI/3D0)*((1D0-2D0*CUT)*
78626 & LOG((1D0-2D0*CUT)/CUT)+0.5D0*(9D0*CUT**2-1D0))
78627 PARJ(153)=0D0
78628 PARJ(154)=0D0
78629 ENDIF
78630
78631C...Select number of jets.
78632 PARJ(150)=CUT
78633 IF(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.5) THEN
78634 NJET=2
78635 ELSEIF(MSTJ(101).LE.0) THEN
78636 NJET=MIN(4,2-MSTJ(101))
78637 ELSE
78638 RNJ=PYR(0)
78639 NJET=2
78640 IF(PARJ(152)+PARJ(153)+PARJ(154).GT.RNJ) NJET=3
78641 IF(PARJ(154).GT.RNJ) NJET=4
78642 ENDIF
78643
78644 RETURN
78645 END
78646
78647C*********************************************************************
78648
78649C...PYX3JT
78650C...Selects the kinematical variables of three-jet events.
78651
78652 SUBROUTINE PYX3JT(NJET,CUT,KFL,ECM,X1,X2)
78653
78654C...Double precision and integer declarations.
78655 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78656 IMPLICIT INTEGER(I-N)
78657 INTEGER PYK,PYCHGE,PYCOMP
78658C...Commonblocks.
78659 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78660 SAVE /PYDAT1/
78661C...Local array.
78662 DIMENSION ZHUP(5,12)
78663
78664C...Coefficients of Zhu second order parametrization.
78665 DATA ((ZHUP(IC1,IC2),IC2=1,12),IC1=1,5)/
78666 &18.29D0, 89.56D0, 4.541D0, -52.09D0, -109.8D0, 24.90D0,
78667 &11.63D0, 3.683D0, 17.50D0,0.002440D0, -1.362D0,-0.3537D0,
78668 &11.42D0, 6.299D0, -22.55D0, -8.915D0, 59.25D0, -5.855D0,
78669 &-32.85D0, -1.054D0, -16.90D0,0.006489D0,-0.8156D0,0.01095D0,
78670 &7.847D0, -3.964D0, -35.83D0, 1.178D0, 29.39D0, 0.2806D0,
78671 &47.82D0, -12.36D0, -56.72D0, 0.04054D0,-0.4365D0, 0.6062D0,
78672 &5.441D0, -56.89D0, -50.27D0, 15.13D0, 114.3D0, -18.19D0,
78673 &97.05D0, -1.890D0, -139.9D0, 0.08153D0,-0.4984D0, 0.9439D0,
78674 &-17.65D0, 51.44D0, -58.32D0, 70.95D0, -255.7D0, -78.99D0,
78675 &476.9D0, 29.65D0, -239.3D0, 0.4745D0, -1.174D0, 6.081D0/
78676
78677C...Dilogarithm of x for x<0.5 (x>0.5 obtained by analytic trick).
78678 DILOG(X)=X+X**2/4D0+X**3/9D0+X**4/16D0+X**5/25D0+X**6/36D0+
78679 &X**7/49D0
78680
78681C...Event type. Mass effect factors and other common constants.
78682 MSTJ(120)=2
78683 MSTJ(121)=0
78684 PMQ=PYMASS(KFL)
78685 QME=(2D0*PMQ/ECM)**2
78686 IF(MSTJ(109).NE.1) THEN
78687 CUTL=LOG(CUT)
78688 CUTD=LOG(1D0/CUT-2D0)
78689 IF(MSTJ(109).EQ.0) THEN
78690 CF=4D0/3D0
78691 CN=3D0
78692 TR=2D0
78693 WTMX=MIN(20D0,37D0-6D0*CUTD)
78694 IF(MSTJ(110).EQ.2) WTMX=2D0*(7.5D0+80D0*CUT)
78695 ELSE
78696 CF=1D0
78697 CN=0D0
78698 TR=12D0
78699 WTMX=0D0
78700 ENDIF
78701
78702C...Alpha_strong and effects of optimized Q^2 scale. Maximum weight.
78703 ALS2PI=PARU(118)/PARU(2)
78704 WTOPT=0D0
78705 IF(MSTJ(111).EQ.1) WTOPT=(33D0-2D0*MSTU(112))/6D0*
78706 & LOG(PARJ(169))*ALS2PI
78707 WTMAX=MAX(0D0,1D0+WTOPT+ALS2PI*WTMX)
78708
78709C...Choose three-jet events in allowed region.
78710 100 NJET=3
78711 110 Y13L=CUTL+CUTD*PYR(0)
78712 Y23L=CUTL+CUTD*PYR(0)
78713 Y13=EXP(Y13L)
78714 Y23=EXP(Y23L)
78715 Y12=1D0-Y13-Y23
78716 IF(Y12.LE.CUT) GOTO 110
78717 IF(Y13**2+Y23**2+2D0*Y12.LE.2D0*PYR(0)) GOTO 110
78718
78719C...Second order corrections.
78720 IF(MSTJ(101).EQ.2.AND.MSTJ(110).LE.1) THEN
78721 Y12L=LOG(Y12)
78722 Y13M=LOG(1D0-Y13)
78723 Y23M=LOG(1D0-Y23)
78724 Y12M=LOG(1D0-Y12)
78725 IF(Y13.LE.0.5D0) Y13I=DILOG(Y13)
78726 IF(Y13.GE.0.5D0) Y13I=1.644934D0-Y13L*Y13M-DILOG(1D0-Y13)
78727 IF(Y23.LE.0.5D0) Y23I=DILOG(Y23)
78728 IF(Y23.GE.0.5D0) Y23I=1.644934D0-Y23L*Y23M-DILOG(1D0-Y23)
78729 IF(Y12.LE.0.5D0) Y12I=DILOG(Y12)
78730 IF(Y12.GE.0.5D0) Y12I=1.644934D0-Y12L*Y12M-DILOG(1D0-Y12)
78731 WT1=(Y13**2+Y23**2+2D0*Y12)/(Y13*Y23)
78732 WT2=CF*(-2D0*(CUTL-Y12L)**2-3D0*CUTL-1D0+3.289868D0+
78733 & 2D0*(2D0*CUTL-Y12L)*CUT/Y12)+
78734 & CN*((CUTL-Y12L)**2-(CUTL-Y13L)**2-(CUTL-Y23L)**2-
78735 & 11D0*CUTL/6D0+67D0/18D0+1.644934D0-(2D0*CUTL-Y12L)*CUT/Y12+
78736 & (2D0*CUTL-Y13L)*CUT/Y13+(2D0*CUTL-Y23L)*CUT/Y23)+
78737 & TR*(2D0*CUTL/3D0-10D0/9D0)+
78738 & CF*(Y12/(Y12+Y13)+Y12/(Y12+Y23)+(Y12+Y23)/Y13+(Y12+Y13)/Y23+
78739 & Y13L*(4D0*Y12**2+2D0*Y12*Y13+4D0*Y12*Y23+Y13*Y23)/
78740 & (Y12+Y23)**2+Y23L*(4D0*Y12**2+2D0*Y12*Y23+4D0*Y12*Y13+
78741 & Y13*Y23)/(Y12+Y13)**2)/WT1+
78742 & CN*(Y13L*Y13/(Y12+Y23)+Y23L*Y23/(Y12+Y13))/WT1+(CN-2D0*CF)*
78743 & ((Y12**2+(Y12+Y13)**2)*(Y12L*Y23L-Y12L*Y12M-Y23L*
78744 & Y23M+1.644934D0-Y12I-Y23I)/(Y13*Y23)+(Y12**2+(Y12+Y23)**2)*
78745 & (Y12L*Y13L-Y12L*Y12M-Y13L*Y13M+1.644934D0-Y12I-Y13I)/
78746 & (Y13*Y23)+(Y13**2+Y23**2)/(Y13*Y23*(Y13+Y23))-
78747 & 2D0*Y12L*Y12**2/(Y13+Y23)**2-4D0*Y12L*Y12/(Y13+Y23))/WT1-
78748 & CN*(Y13L*Y23L-Y13L*Y13M-Y23L*Y23M+1.644934D0-Y13I-Y23I)
78749 IF(1D0+WTOPT+ALS2PI*WT2.LE.0D0) MSTJ(121)=1
78750 IF(1D0+WTOPT+ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
78751 PARJ(156)=(WTOPT+ALS2PI*WT2)/(1D0+WTOPT+ALS2PI*WT2)
78752
78753 ELSEIF(MSTJ(101).EQ.2.AND.MSTJ(110).EQ.2) THEN
78754C...Second order corrections; Zhu parametrization of ERT.
78755 ZX=(Y23-Y13)**2
78756 ZY=1D0-Y12
78757 IZA=0
78758 DO 120 IY=1,5
78759 IF(ABS(CUT-0.01D0*IY).LT.0.0001D0) IZA=IY
78760 120 CONTINUE
78761 IF(IZA.NE.0) THEN
78762 IZ=IZA
78763 WT2=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
78764 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
78765 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
78766 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
78767 ELSE
78768 IZ=100D0*CUT
78769 WTL=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
78770 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
78771 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
78772 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
78773 IZ=IZ+1
78774 WTU=ZHUP(IZ,1)+ZHUP(IZ,2)*ZX+ZHUP(IZ,3)*ZX**2+(ZHUP(IZ,4)+
78775 & ZHUP(IZ,5)*ZX)*ZY+(ZHUP(IZ,6)+ZHUP(IZ,7)*ZX)*ZY**2+
78776 & (ZHUP(IZ,8)+ZHUP(IZ,9)*ZX)*ZY**3+ZHUP(IZ,10)/(ZX-ZY**2)+
78777 & ZHUP(IZ,11)/(1D0-ZY)+ZHUP(IZ,12)/ZY
78778 WT2=WTL+(WTU-WTL)*(100D0*CUT+1D0-IZ)
78779 ENDIF
78780 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.0D0) MSTJ(121)=1
78781 IF(1D0+WTOPT+2D0*ALS2PI*WT2.LE.WTMAX*PYR(0)) GOTO 110
78782 PARJ(156)=(WTOPT+2D0*ALS2PI*WT2)/(1D0+WTOPT+2D0*ALS2PI*WT2)
78783 ENDIF
78784
78785C...Impose mass cuts (gives two jets). For fixed jet number new try.
78786 X1=1D0-Y23
78787 X2=1D0-Y13
78788 X3=1D0-Y12
78789 IF(4D0*Y23*Y13*Y12/X3**2.LE.QME) NJET=2
78790 IF(MOD(MSTJ(103),4).GE.2.AND.IABS(MSTJ(101)).LE.1.AND.QME*X3+
78791 & 0.5D0*QME**2+(0.5D0*QME+0.25D0*QME**2)*((1D0-X2)/(1D0-X1)+
78792 & (1D0-X1)/(1D0-X2)).GT.(X1**2+X2**2)*PYR(0)) NJET=2
78793 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 100
78794
78795C...Scalar gluon model (first order only, no mass effects).
78796 ELSE
78797 130 NJET=3
78798 140 X3=SQRT(4D0*CUT**2+PYR(0)*((1D0-CUT)**2-4D0*CUT**2))
78799 IF(LOG((X3-CUT)/CUT).LE.PYR(0)*LOG((1D0-2D0*CUT)/CUT)) GOTO 140
78800 YD=SIGN(2D0*CUT*((X3-CUT)/CUT)**PYR(0)-X3,PYR(0)-0.5D0)
78801 X1=1D0-0.5D0*(X3+YD)
78802 X2=1D0-0.5D0*(X3-YD)
78803 IF(4D0*(1D0-X1)*(1D0-X2)*(1D0-X3)/X3**2.LE.QME) NJET=2
78804 IF(MSTJ(102).GE.2) THEN
78805 IF(X3**2-2D0*(1D0+X3)*(1D0-X1)*(1D0-X2)*PARJ(171).LT.
78806 & X3**2*PYR(0)) NJET=2
78807 ENDIF
78808 IF(MSTJ(101).EQ.-1.AND.NJET.EQ.2) GOTO 130
78809 ENDIF
78810
78811 RETURN
78812 END
78813
78814C*********************************************************************
78815
78816C...PYX4JT
78817C...Selects the kinematical variables of four-jet events.
78818
78819 SUBROUTINE PYX4JT(NJET,CUT,KFL,ECM,KFLN,X1,X2,X4,X12,X14)
78820
78821C...Double precision and integer declarations.
78822 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
78823 IMPLICIT INTEGER(I-N)
78824 INTEGER PYK,PYCHGE,PYCOMP
78825C...Commonblocks.
78826 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
78827 SAVE /PYDAT1/
78828C...Local arrays.
78829 DIMENSION WTA(4),WTB(4),WTC(4),WTD(4),WTE(4)
78830
78831C...Common constants. Colour factors for QCD and Abelian gluon theory.
78832 PMQ=PYMASS(KFL)
78833 QME=(2D0*PMQ/ECM)**2
78834 CT=LOG(1D0/CUT-5D0)
78835 IF(MSTJ(109).EQ.0) THEN
78836 CF=4D0/3D0
78837 CN=3D0
78838 TR=2.5D0
78839 ELSE
78840 CF=1D0
78841 CN=0D0
78842 TR=15D0
78843 ENDIF
78844
78845C...Choice of process (qqbargg or qqbarqqbar).
78846 100 NJET=4
78847 IT=1
78848 IF(PARJ(155).GT.PYR(0)) IT=2
78849 IF(MSTJ(101).LE.-3) IT=-MSTJ(101)-2
78850 IF(IT.EQ.1) WTMX=0.7D0/CUT**2
78851 IF(IT.EQ.1.AND.MSTJ(109).EQ.2) WTMX=0.6D0/CUT**2
78852 IF(IT.EQ.2) WTMX=0.1125D0*CF*TR/CUT**2
78853 ID=1
78854
78855C...Sample the five kinematical variables (for qqgg preweighted in y34).
78856 110 Y134=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
78857 Y234=3D0*CUT+(1D0-6D0*CUT)*PYR(0)
78858 IF(IT.EQ.1) Y34=(1D0-5D0*CUT)*EXP(-CT*PYR(0))
78859 IF(IT.EQ.2) Y34=CUT+(1D0-6D0*CUT)*PYR(0)
78860 IF(Y34.LE.Y134+Y234-1D0.OR.Y34.GE.Y134*Y234) GOTO 110
78861 VT=PYR(0)
78862 CP=COS(PARU(1)*PYR(0))
78863 Y14=(Y134-Y34)*VT
78864 Y13=Y134-Y14-Y34
78865 VB=Y34*(1D0-Y134-Y234+Y34)/((Y134-Y34)*(Y234-Y34))
78866 Y24=0.5D0*(Y234-Y34)*(1D0-4D0*SQRT(MAX(0D0,VT*(1D0-VT)*
78867 &VB*(1D0-VB)))*CP-(1D0-2D0*VT)*(1D0-2D0*VB))
78868 Y23=Y234-Y34-Y24
78869 Y12=1D0-Y134-Y23-Y24
78870 IF(MIN(Y12,Y13,Y14,Y23,Y24).LE.CUT) GOTO 110
78871 Y123=Y12+Y13+Y23
78872 Y124=Y12+Y14+Y24
78873
78874C...Calculate matrix elements for qqgg or qqqq process.
78875 IC=0
78876 WTTOT=0D0
78877 120 IC=IC+1
78878 IF(IT.EQ.1) THEN
78879 WTA(IC)=(Y12*Y34**2-Y13*Y24*Y34+Y14*Y23*Y34+3D0*Y12*Y23*Y34+
78880 & 3D0*Y12*Y14*Y34+4D0*Y12**2*Y34-Y13*Y23*Y24+2D0*Y12*Y23*Y24-
78881 & Y13*Y14*Y24-2D0*Y12*Y13*Y24+2D0*Y12**2*Y24+Y14*Y23**2+2D0*Y12*
78882 & Y23**2+Y14**2*Y23+4D0*Y12*Y14*Y23+4D0*Y12**2*Y23+2D0*Y12*Y14**2+
78883 & 2D0*Y12*Y13*Y14+4D0*Y12**2*Y14+2D0*Y12**2*Y13+2D0*Y12**3)/
78884 & (2D0*Y13*Y134*Y234*Y24)+(Y24*Y34+Y12*Y34+Y13*Y24-
78885 & Y14*Y23+Y12*Y13)/(Y13*Y134**2)+2D0*Y23*(1D0-Y13)/
78886 & (Y13*Y134*Y24)+Y34/(2D0*Y13*Y24)
78887 WTB(IC)=(Y12*Y24*Y34+Y12*Y14*Y34-Y13*Y24**2+Y13*Y14*Y24+2D0*Y12*
78888 & Y14*Y24)/(Y13*Y134*Y23*Y14)+Y12*(1D0+Y34)*Y124/(Y134*Y234*Y14*
78889 & Y24)-(2D0*Y13*Y24+Y14**2+Y13*Y23+2D0*Y12*Y13)/(Y13*Y134*Y14)+
78890 & Y12*Y123*Y124/(2D0*Y13*Y14*Y23*Y24)
78891 WTC(IC)=-(5D0*Y12*Y34**2+2D0*Y12*Y24*Y34+2D0*Y12*Y23*Y34+
78892 & 2D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+4D0*Y12**2*Y34-Y13*Y24**2+
78893 & Y14*Y23*Y24+Y13*Y23*Y24+Y13*Y14*Y24-Y12*Y14*Y24-Y13**2*Y24-
78894 & 3D0*Y12*Y13*Y24-Y14*Y23**2-Y14**2*Y23+Y13*Y14*Y23-
78895 & 3D0*Y12*Y14*Y23-Y12*Y13*Y23)/(4D0*Y134*Y234*Y34**2)+
78896 & (3D0*Y12*Y34**2-3D0*Y13*Y24*Y34+3D0*Y12*Y24*Y34+
78897 & 3D0*Y14*Y23*Y34-Y13*Y24**2-Y12*Y23*Y34+6D0*Y12*Y14*Y34+
78898 & 2D0*Y12*Y13*Y34-2D0*Y12**2*Y34+Y14*Y23*Y24-3D0*Y13*Y23*Y24-
78899 & 2D0*Y13*Y14*Y24+4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+
78900 & 3D0*Y14*Y23**2+2D0*Y14**2*Y23+2D0*Y14**2*Y12+
78901 & 2D0*Y12**2*Y14+6D0*Y12*Y14*Y23-2D0*Y12*Y13**2-
78902 & 2D0*Y12**2*Y13)/(4D0*Y13*Y134*Y234*Y34)
78903 WTC(IC)=WTC(IC)+(2D0*Y12*Y34**2-2D0*Y13*Y24*Y34+Y12*Y24*Y34+
78904 & 4D0*Y13*Y23*Y34+4D0*Y12*Y14*Y34+2D0*Y12*Y13*Y34+2D0*Y12**2*Y34-
78905 & Y13*Y24**2+3D0*Y14*Y23*Y24+4D0*Y13*Y23*Y24-2D0*Y13*Y14*Y24+
78906 & 4D0*Y12*Y14*Y24+2D0*Y12*Y13*Y24+2D0*Y14*Y23**2+4D0*Y13*Y23**2+
78907 & 2D0*Y13*Y14*Y23+2D0*Y12*Y14*Y23+4D0*Y12*Y13*Y23+2D0*Y12*Y14**2+
78908 & 4D0*Y12**2*Y13+4D0*Y12*Y13*Y14+2D0*Y12**2*Y14)/
78909 & (4D0*Y13*Y134*Y24*Y34)-(Y12*Y34**2-2D0*Y14*Y24*Y34-
78910 & 2D0*Y13*Y24*Y34-Y14*Y23*Y34+Y13*Y23*Y34+Y12*Y14*Y34+
78911 & 2D0*Y12*Y13*Y34-2D0*Y14**2*Y24-4D0*Y13*Y14*Y24-
78912 & 4D0*Y13**2*Y24-Y14**2*Y23-Y13**2*Y23+Y12*Y13*Y14-
78913 & Y12*Y13**2)/(2D0*Y13*Y34*Y134**2)+(Y12*Y34**2-
78914 & 4D0*Y14*Y24*Y34-2D0*Y13*Y24*Y34-2D0*Y14*Y23*Y34-
78915 & 4D0*Y13*Y23*Y34-4D0*Y12*Y14*Y34-4D0*Y12*Y13*Y34-
78916 & 2D0*Y13*Y14*Y24+2D0*Y13**2*Y24+2D0*Y14**2*Y23-
78917 & 2D0*Y13*Y14*Y23-Y12*Y14**2-6D0*Y12*Y13*Y14-
78918 & Y12*Y13**2)/(4D0*Y34**2*Y134**2)
78919 WTTOT=WTTOT+Y34*CF*(CF*WTA(IC)+(CF-0.5D0*CN)*WTB(IC)+
78920 & CN*WTC(IC))/8D0
78921 ELSE
78922 WTD(IC)=(Y13*Y23*Y34+Y12*Y23*Y34-Y12**2*Y34+Y13*Y23*Y24+2D0*Y12*
78923 & Y23*Y24-Y14*Y23**2+Y12*Y13*Y24+Y12*Y14*Y23+Y12*Y13*Y14)/(Y13**2*
78924 & Y123**2)-(Y12*Y34**2-Y13*Y24*Y34+Y12*Y24*Y34-Y14*Y23*Y34-Y12*
78925 & Y23*Y34-Y13*Y24**2+Y14*Y23*Y24-Y13*Y23*Y24-Y13**2*Y24+Y14*
78926 & Y23**2)/(Y13**2*Y123*Y134)+(Y13*Y14*Y12+Y34*Y14*Y12-Y34**2*Y12+
78927 & Y13*Y14*Y24+2D0*Y34*Y14*Y24-Y23*Y14**2+Y34*Y13*Y24+Y34*Y23*Y14+
78928 & Y34*Y13*Y23)/(Y13**2*Y134**2)-(Y34*Y12**2-Y13*Y24*Y12+Y34*Y24*
78929 & Y12-Y23*Y14*Y12-Y34*Y14*Y12-Y13*Y24**2+Y23*Y14*Y24-Y13*Y14*Y24-
78930 & Y13**2*Y24+Y23*Y14**2)/(Y13**2*Y134*Y123)
78931 WTE(IC)=(Y12*Y34*(Y23-Y24+Y14+Y13)+Y13*Y24**2-Y14*Y23*Y24+Y13*
78932 & Y23*Y24+Y13*Y14*Y24+Y13**2*Y24-Y14*Y23*(Y14+Y23+Y13))/(Y13*Y23*
78933 & Y123*Y134)-Y12*(Y12*Y34-Y23*Y24-Y13*Y24-Y14*Y23-Y14*Y13)/(Y13*
78934 & Y23*Y123**2)-(Y14+Y13)*(Y24+Y23)*Y34/(Y13*Y23*Y134*Y234)+
78935 & (Y12*Y34*(Y14-Y24+Y23+Y13)+Y13*Y24**2-Y23*Y14*Y24+Y13*Y14*Y24+
78936 & Y13*Y23*Y24+Y13**2*Y24-Y23*Y14*(Y14+Y23+Y13))/(Y13*Y14*Y134*
78937 & Y123)-Y34*(Y34*Y12-Y14*Y24-Y13*Y24-Y23*Y14-Y23*Y13)/(Y13*Y14*
78938 & Y134**2)-(Y23+Y13)*(Y24+Y14)*Y12/(Y13*Y14*Y123*Y124)
78939 WTTOT=WTTOT+CF*(TR*WTD(IC)+(CF-0.5D0*CN)*WTE(IC))/16D0
78940 ENDIF
78941
78942C...Permutations of momenta in matrix element. Weighting.
78943 130 IF(IC.EQ.1.OR.IC.EQ.3.OR.ID.EQ.2.OR.ID.EQ.3) THEN
78944 YSAV=Y13
78945 Y13=Y14
78946 Y14=YSAV
78947 YSAV=Y23
78948 Y23=Y24
78949 Y24=YSAV
78950 YSAV=Y123
78951 Y123=Y124
78952 Y124=YSAV
78953 ENDIF
78954 IF(IC.EQ.2.OR.IC.EQ.4.OR.ID.EQ.3.OR.ID.EQ.4) THEN
78955 YSAV=Y13
78956 Y13=Y23
78957 Y23=YSAV
78958 YSAV=Y14
78959 Y14=Y24
78960 Y24=YSAV
78961 YSAV=Y134
78962 Y134=Y234
78963 Y234=YSAV
78964 ENDIF
78965 IF(IC.LE.3) GOTO 120
78966 IF(ID.EQ.1.AND.WTTOT.LT.PYR(0)*WTMX) GOTO 110
78967 IC=5
78968
78969C...qqgg events: string configuration and event type.
78970 IF(IT.EQ.1) THEN
78971 IF(MSTJ(109).EQ.0.AND.ID.EQ.1) THEN
78972 PARJ(156)=Y34*(2D0*(WTA(1)+WTA(2)+WTA(3)+WTA(4))+4D0*(WTC(1)+
78973 & WTC(2)+WTC(3)+WTC(4)))/(9D0*WTTOT)
78974 IF(WTA(2)+WTA(4)+2D0*(WTC(2)+WTC(4)).GT.PYR(0)*(WTA(1)+WTA(2)+
78975 & WTA(3)+WTA(4)+2D0*(WTC(1)+WTC(2)+WTC(3)+WTC(4)))) ID=2
78976 IF(ID.EQ.2) GOTO 130
78977 ELSEIF(MSTJ(109).EQ.2.AND.ID.EQ.1) THEN
78978 PARJ(156)=Y34*(WTA(1)+WTA(2)+WTA(3)+WTA(4))/(8D0*WTTOT)
78979 IF(WTA(2)+WTA(4).GT.PYR(0)*(WTA(1)+WTA(2)+WTA(3)+WTA(4))) ID=2
78980 IF(ID.EQ.2) GOTO 130
78981 ENDIF
78982 MSTJ(120)=3
78983 IF(MSTJ(109).EQ.0.AND.0.5D0*Y34*(WTC(1)+WTC(2)+WTC(3)+
78984 & WTC(4)).GT.PYR(0)*WTTOT) MSTJ(120)=4
78985 KFLN=21
78986
78987C...Mass cuts. Kinematical variables out.
78988 IF(Y12.LE.CUT+QME) NJET=2
78989 IF(NJET.EQ.2) GOTO 150
78990 Q12=0.5D0*(1D0-SQRT(1D0-QME/Y12))
78991 X1=1D0-(1D0-Q12)*Y234-Q12*Y134
78992 X4=1D0-(1D0-Q12)*Y134-Q12*Y234
78993 X2=1D0-Y124
78994 X12=(1D0-Q12)*Y13+Q12*Y23
78995 X14=Y12-0.5D0*QME
78996 IF(Y134*Y234/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
78997
78998C...qqbarqqbar events: string configuration, choose new flavour.
78999 ELSE
79000 IF(ID.EQ.1) THEN
79001 WTR=PYR(0)*(WTD(1)+WTD(2)+WTD(3)+WTD(4))
79002 IF(WTR.LT.WTD(2)+WTD(3)+WTD(4)) ID=2
79003 IF(WTR.LT.WTD(3)+WTD(4)) ID=3
79004 IF(WTR.LT.WTD(4)) ID=4
79005 IF(ID.GE.2) GOTO 130
79006 ENDIF
79007 MSTJ(120)=5
79008 PARJ(156)=CF*TR*(WTD(1)+WTD(2)+WTD(3)+WTD(4))/(16D0*WTTOT)
79009 140 KFLN=1+INT(5D0*PYR(0))
79010 IF(KFLN.NE.KFL.AND.0.2D0*PARJ(156).LE.PYR(0)) GOTO 140
79011 IF(KFLN.EQ.KFL.AND.1D0-0.8D0*PARJ(156).LE.PYR(0)) GOTO 140
79012 IF(KFLN.GT.MSTJ(104)) NJET=2
79013 PMQN=PYMASS(KFLN)
79014 QMEN=(2D0*PMQN/ECM)**2
79015
79016C...Mass cuts. Kinematical variables out.
79017 IF(Y24.LE.CUT+QME.OR.Y13.LE.1.1D0*QMEN) NJET=2
79018 IF(NJET.EQ.2) GOTO 150
79019 Q24=0.5D0*(1D0-SQRT(1D0-QME/Y24))
79020 Q13=0.5D0*(1D0-SQRT(1D0-QMEN/Y13))
79021 X1=1D0-(1D0-Q24)*Y123-Q24*Y134
79022 X4=1D0-(1D0-Q24)*Y134-Q24*Y123
79023 X2=1D0-(1D0-Q13)*Y234-Q13*Y124
79024 X12=(1D0-Q24)*((1D0-Q13)*Y14+Q13*Y34)+Q24*((1D0-Q13)*Y12+
79025 & Q13*Y23)
79026 X14=Y24-0.5D0*QME
79027 X34=(1D0-Q24)*((1D0-Q13)*Y23+Q13*Y12)+Q24*((1D0-Q13)*Y34+
79028 & Q13*Y14)
79029 IF(PMQ**2+PMQN**2+MIN(X12,X34)*ECM**2.LE.
79030 & (PARJ(127)+PMQ+PMQN)**2) NJET=2
79031 IF(Y123*Y134/((1D0-X1)*(1D0-X4)).LE.PYR(0)) NJET=2
79032 ENDIF
79033 150 IF(MSTJ(101).LE.-2.AND.NJET.EQ.2) GOTO 100
79034
79035 RETURN
79036 END
79037
79038C*********************************************************************
79039
79040C...PYXDIF
79041C...Gives the angular orientation of events.
79042
79043 SUBROUTINE PYXDIF(NC,NJET,KFL,ECM,CHI,THE,PHI)
79044
79045C...Double precision and integer declarations.
79046 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79047 IMPLICIT INTEGER(I-N)
79048 INTEGER PYK,PYCHGE,PYCOMP
79049C...Commonblocks.
79050 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
79051 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79052 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
79053 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
79054
79055C...Charge. Factors depending on polarization for QED case.
79056 QF=KCHG(KFL,1)/3D0
79057 POLL=1D0-PARJ(131)*PARJ(132)
79058 POLD=PARJ(132)-PARJ(131)
79059 IF(MSTJ(102).LE.1.OR.MSTJ(109).EQ.1) THEN
79060 HF1=POLL
79061 HF2=0D0
79062 HF3=PARJ(133)**2
79063 HF4=0D0
79064
79065C...Factors depending on flavour, energy and polarization for QFD case.
79066 ELSE
79067 SFF=1D0/(16D0*PARU(102)*(1D0-PARU(102)))
79068 SFW=ECM**4/((ECM**2-PARJ(123)**2)**2+(PARJ(123)*PARJ(124))**2)
79069 SFI=SFW*(1D0-(PARJ(123)/ECM)**2)
79070 AE=-1D0
79071 VE=4D0*PARU(102)-1D0
79072 AF=SIGN(1D0,QF)
79073 VF=AF-4D0*QF*PARU(102)
79074 HF1=QF**2*POLL-2D0*QF*VF*SFI*SFF*(VE*POLL-AE*POLD)+
79075 & (VF**2+AF**2)*SFW*SFF**2*((VE**2+AE**2)*POLL-2D0*VE*AE*POLD)
79076 HF2=-2D0*QF*AF*SFI*SFF*(AE*POLL-VE*POLD)+2D0*VF*AF*SFW*SFF**2*
79077 & (2D0*VE*AE*POLL-(VE**2+AE**2)*POLD)
79078 HF3=PARJ(133)**2*(QF**2-2D0*QF*VF*SFI*SFF*VE+(VF**2+AF**2)*
79079 & SFW*SFF**2*(VE**2-AE**2))
79080 HF4=-PARJ(133)**2*2D0*QF*VF*SFW*(PARJ(123)*PARJ(124)/ECM**2)*
79081 & SFF*AE
79082 ENDIF
79083
79084C...Mass factor. Differential cross-sections for two-jet events.
79085 SQ2=SQRT(2D0)
79086 QME=0D0
79087 IF(MSTJ(103).GE.4.AND.IABS(MSTJ(101)).LE.1.AND.MSTJ(102).LE.1.AND.
79088 &MSTJ(109).NE.1) QME=(2D0*PYMASS(KFL)/ECM)**2
79089 IF(NJET.EQ.2) THEN
79090 SIGU=4D0*SQRT(1D0-QME)
79091 SIGL=2D0*QME*SQRT(1D0-QME)
79092 SIGT=0D0
79093 SIGI=0D0
79094 SIGA=0D0
79095 SIGP=4D0
79096
79097C...Kinematical variables. Reduce four-jet event to three-jet one.
79098 ELSE
79099 IF(NJET.EQ.3) THEN
79100 X1=2D0*P(NC+1,4)/ECM
79101 X2=2D0*P(NC+3,4)/ECM
79102 ELSE
79103 ECMR=P(NC+1,4)+P(NC+4,4)+SQRT((P(NC+2,1)+P(NC+3,1))**2+
79104 & (P(NC+2,2)+P(NC+3,2))**2+(P(NC+2,3)+P(NC+3,3))**2)
79105 X1=2D0*P(NC+1,4)/ECMR
79106 X2=2D0*P(NC+4,4)/ECMR
79107 ENDIF
79108
79109C...Differential cross-sections for three-jet (or reduced four-jet).
79110 XQ=(1D0-X1)/(1D0-X2)
79111 CT12=(X1*X2-2D0*X1-2D0*X2+2D0+QME)/SQRT((X1**2-QME)*(X2**2-QME))
79112 ST12=SQRT(1D0-CT12**2)
79113 IF(MSTJ(109).NE.1) THEN
79114 SIGU=2D0*X1**2+X2**2*(1D0+CT12**2)-QME*(3D0+CT12**2-X1-X2)-
79115 & QME*X1/XQ+0.5D0*QME*((X2**2-QME)*ST12**2-2D0*X2)*XQ
79116 SIGL=(X2*ST12)**2-QME*(3D0-CT12**2-2.5D0*(X1+X2)+X1*X2+QME)+
79117 & 0.5D0*QME*(X1**2-X1-QME)/XQ+0.5D0*QME*((X2**2-QME)*CT12**2-
79118 & X2)*XQ
79119 SIGT=0.5D0*(X2**2-QME-0.5D0*QME*(X2**2-QME)/XQ)*ST12**2
79120 SIGI=((1D0-0.5D0*QME*XQ)*(X2**2-QME)*ST12*CT12+
79121 & QME*(1D0-X1-X2+0.5D0*X1*X2+0.5D0*QME)*ST12/CT12)/SQ2
79122 SIGA=X2**2*ST12/SQ2
79123 SIGP=2D0*(X1**2-X2**2*CT12)
79124
79125C...Differential cross-sect for scalar gluons (no mass effects).
79126 ELSE
79127 X3=2D0-X1-X2
79128 XT=X2*ST12
79129 CT13=SQRT(MAX(0D0,1D0-(XT/X3)**2))
79130 SIGU=(1D0-PARJ(171))*(X3**2-0.5D0*XT**2)+
79131 & PARJ(171)*(X3**2-0.5D0*XT**2-4D0*(1D0-X1)*(1D0-X2)**2/X1)
79132 SIGL=(1D0-PARJ(171))*0.5D0*XT**2+
79133 & PARJ(171)*0.5D0*(1D0-X1)**2*XT**2
79134 SIGT=(1D0-PARJ(171))*0.25D0*XT**2+
79135 & PARJ(171)*0.25D0*XT**2*(1D0-2D0*X1)
79136 SIGI=-(0.5D0/SQ2)*((1D0-PARJ(171))*XT*X3*CT13+
79137 & PARJ(171)*XT*((1D0-2D0*X1)*X3*CT13-X1*(X1-X2)))
79138 SIGA=(0.25D0/SQ2)*XT*(2D0*(1D0-X1)-X1*X3)
79139 SIGP=X3**2-2D0*(1D0-X1)*(1D0-X2)/X1
79140 ENDIF
79141 ENDIF
79142
79143C...Upper bounds for differential cross-section.
79144 HF1A=ABS(HF1)
79145 HF2A=ABS(HF2)
79146 HF3A=ABS(HF3)
79147 HF4A=ABS(HF4)
79148 SIGMAX=(2D0*HF1A+HF3A+HF4A)*ABS(SIGU)+2D0*(HF1A+HF3A+HF4A)*
79149 &ABS(SIGL)+2D0*(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGT)+2D0*SQ2*
79150 &(HF1A+2D0*HF3A+2D0*HF4A)*ABS(SIGI)+4D0*SQ2*HF2A*ABS(SIGA)+
79151 &2D0*HF2A*ABS(SIGP)
79152
79153C...Generate angular orientation according to differential cross-sect.
79154 100 CHI=PARU(2)*PYR(0)
79155 CTHE=2D0*PYR(0)-1D0
79156 PHI=PARU(2)*PYR(0)
79157 CCHI=COS(CHI)
79158 SCHI=SIN(CHI)
79159 C2CHI=COS(2D0*CHI)
79160 S2CHI=SIN(2D0*CHI)
79161 THE=ACOS(CTHE)
79162 STHE=SIN(THE)
79163 C2PHI=COS(2D0*(PHI-PARJ(134)))
79164 S2PHI=SIN(2D0*(PHI-PARJ(134)))
79165 SIG=((1D0+CTHE**2)*HF1+STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGU+
79166 &2D0*(STHE**2*HF1-STHE**2*(C2PHI*HF3-S2PHI*HF4))*SIGL+
79167 &2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*C2CHI*C2PHI-2D0*CTHE*S2CHI*
79168 &S2PHI)*HF3-((1D0+CTHE**2)*C2CHI*S2PHI+2D0*CTHE*S2CHI*C2PHI)*HF4)*
79169 &SIGT-2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*(CTHE*CCHI*C2PHI-
79170 &SCHI*S2PHI)*HF3+2D0*STHE*(CTHE*CCHI*S2PHI+SCHI*C2PHI)*HF4)*SIGI+
79171 &4D0*SQ2*STHE*CCHI*HF2*SIGA+2D0*CTHE*HF2*SIGP
79172 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 100
79173
79174 RETURN
79175 END
79176
79177C*********************************************************************
79178
79179C...PYONIA
79180C...Generates Upsilon and toponium decays into three gluons
79181C...or two gluons and a photon.
79182
79183 SUBROUTINE PYONIA(KFL,ECM)
79184
79185C...Double precision and integer declarations.
79186 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79187 IMPLICIT INTEGER(I-N)
79188 INTEGER PYK,PYCHGE,PYCOMP
79189C...Commonblocks.
79190 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
79191 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79192 COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
79193 SAVE /PYJETS/,/PYDAT1/,/PYDAT2/
79194
79195C...Printout. Check input parameters.
79196 IF(MSTU(12).NE.12345) CALL PYLIST(0)
79197 IF(KFL.LT.0.OR.KFL.GT.8) THEN
79198 CALL PYERRM(16,'(PYONIA:) called with unknown flavour code')
79199 IF(MSTU(21).GE.1) RETURN
79200 ENDIF
79201 IF(ECM.LT.PARJ(127)+2.02D0*PARF(101)) THEN
79202 CALL PYERRM(16,'(PYONIA:) called with too small CM energy')
79203 IF(MSTU(21).GE.1) RETURN
79204 ENDIF
79205
79206C...Initial e+e- and onium state (optional).
79207 NC=0
79208 IF(MSTJ(115).GE.2) THEN
79209 NC=NC+2
79210 CALL PY1ENT(NC-1,11,0.5D0*ECM,0D0,0D0)
79211 K(NC-1,1)=21
79212 CALL PY1ENT(NC,-11,0.5D0*ECM,PARU(1),0D0)
79213 K(NC,1)=21
79214 ENDIF
79215 KFLC=IABS(KFL)
79216 IF(MSTJ(115).GE.3.AND.KFLC.GE.5) THEN
79217 NC=NC+1
79218 KF=110*KFLC+3
79219 MSTU10=MSTU(10)
79220 MSTU(10)=1
79221 P(NC,5)=ECM
79222 CALL PY1ENT(NC,KF,ECM,0D0,0D0)
79223 K(NC,1)=21
79224 K(NC,3)=1
79225 MSTU(10)=MSTU10
79226 ENDIF
79227
79228C...Choose x1 and x2 according to matrix element.
79229 NTRY=0
79230 100 X1=PYR(0)
79231 X2=PYR(0)
79232 X3=2D0-X1-X2
79233 IF(X3.GE.1D0.OR.((1D0-X1)/(X2*X3))**2+((1D0-X2)/(X1*X3))**2+
79234 &((1D0-X3)/(X1*X2))**2.LE.2D0*PYR(0)) GOTO 100
79235 NTRY=NTRY+1
79236 NJET=3
79237 IF(MSTJ(101).LE.4) CALL PY3ENT(NC+1,21,21,21,ECM,X1,X3)
79238 IF(MSTJ(101).GE.5) CALL PY3ENT(-(NC+1),21,21,21,ECM,X1,X3)
79239
79240C...Photon-gluon-gluon events. Small system modifications. Jet origin.
79241 MSTU(111)=MSTJ(108)
79242 IF(MSTJ(108).EQ.2.AND.(MSTJ(101).EQ.0.OR.MSTJ(101).EQ.1))
79243 &MSTU(111)=1
79244 PARU(112)=PARJ(121)
79245 IF(MSTU(111).EQ.2) PARU(112)=PARJ(122)
79246 QF=0D0
79247 IF(KFLC.NE.0) QF=KCHG(KFLC,1)/3D0
79248 RGAM=7.2D0*QF**2*PARU(101)/PYALPS(ECM**2)
79249 MK=0
79250 ECMC=ECM
79251 IF(PYR(0).GT.RGAM/(1D0+RGAM)) THEN
79252 IF(1D0-MAX(X1,X2,X3).LE.MAX((PARJ(126)/ECM)**2,PARJ(125)))
79253 & NJET=2
79254 IF(NJET.EQ.2.AND.MSTJ(101).LE.4) CALL PY2ENT(NC+1,21,21,ECM)
79255 IF(NJET.EQ.2.AND.MSTJ(101).GE.5) CALL PY2ENT(-(NC+1),21,21,ECM)
79256 ELSE
79257 MK=1
79258 ECMC=SQRT(1D0-X1)*ECM
79259 IF(ECMC.LT.2D0*PARJ(127)) GOTO 100
79260 K(NC+1,1)=1
79261 K(NC+1,2)=22
79262 K(NC+1,4)=0
79263 K(NC+1,5)=0
79264 IF(MSTJ(101).GE.5) K(NC+2,4)=MSTU(5)*(NC+3)
79265 IF(MSTJ(101).GE.5) K(NC+2,5)=MSTU(5)*(NC+3)
79266 IF(MSTJ(101).GE.5) K(NC+3,4)=MSTU(5)*(NC+2)
79267 IF(MSTJ(101).GE.5) K(NC+3,5)=MSTU(5)*(NC+2)
79268 NJET=2
79269 IF(ECMC.LT.4D0*PARJ(127)) THEN
79270 MSTU10=MSTU(10)
79271 MSTU(10)=1
79272 P(NC+2,5)=ECMC
79273 CALL PY1ENT(NC+2,83,0.5D0*(X2+X3)*ECM,PARU(1),0D0)
79274 MSTU(10)=MSTU10
79275 NJET=0
79276 ENDIF
79277 ENDIF
79278 DO 110 IP=NC+1,N
79279 K(IP,3)=K(IP,3)+(MSTJ(115)/2)+(KFLC/5)*(MSTJ(115)/3)*(NC-1)
79280 110 CONTINUE
79281
79282C...Differential cross-sections. Upper limit for cross-section.
79283 IF(MSTJ(106).EQ.1) THEN
79284 SQ2=SQRT(2D0)
79285 HF1=1D0-PARJ(131)*PARJ(132)
79286 HF3=PARJ(133)**2
79287 CT13=(X1*X3-2D0*X1-2D0*X3+2D0)/(X1*X3)
79288 ST13=SQRT(1D0-CT13**2)
79289 SIGL=0.5D0*X3**2*((1D0-X2)**2+(1D0-X3)**2)*ST13**2
79290 SIGU=(X1*(1D0-X1))**2+(X2*(1D0-X2))**2+(X3*(1D0-X3))**2-SIGL
79291 SIGT=0.5D0*SIGL
79292 SIGI=(SIGL*CT13/ST13+0.5D0*X1*X3*(1D0-X2)**2*ST13)/SQ2
79293 SIGMAX=(2D0*HF1+HF3)*ABS(SIGU)+2D0*(HF1+HF3)*ABS(SIGL)+2D0*(HF1+
79294 & 2D0*HF3)*ABS(SIGT)+2D0*SQ2*(HF1+2D0*HF3)*ABS(SIGI)
79295
79296C...Angular orientation of event.
79297 120 CHI=PARU(2)*PYR(0)
79298 CTHE=2D0*PYR(0)-1D0
79299 PHI=PARU(2)*PYR(0)
79300 CCHI=COS(CHI)
79301 SCHI=SIN(CHI)
79302 C2CHI=COS(2D0*CHI)
79303 S2CHI=SIN(2D0*CHI)
79304 THE=ACOS(CTHE)
79305 STHE=SIN(THE)
79306 C2PHI=COS(2D0*(PHI-PARJ(134)))
79307 S2PHI=SIN(2D0*(PHI-PARJ(134)))
79308 SIG=((1D0+CTHE**2)*HF1+STHE**2*C2PHI*HF3)*SIGU+2D0*(STHE**2*HF1-
79309 & STHE**2*C2PHI*HF3)*SIGL+2D0*(STHE**2*C2CHI*HF1+((1D0+CTHE**2)*
79310 & C2CHI*C2PHI-2D0*CTHE*S2CHI*S2PHI)*HF3)*SIGT-
79311 & 2D0*SQ2*(2D0*STHE*CTHE*CCHI*HF1-2D0*STHE*
79312 & (CTHE*CCHI*C2PHI-SCHI*S2PHI)*HF3)*SIGI
79313 IF(SIG.LT.SIGMAX*PYR(0)) GOTO 120
79314 CALL PYROBO(NC+1,N,0D0,CHI,0D0,0D0,0D0)
79315 CALL PYROBO(NC+1,N,THE,PHI,0D0,0D0,0D0)
79316 ENDIF
79317
79318C...Generate parton shower. Rearrange along strings and check.
79319 IF(MSTJ(101).GE.5.AND.NJET.GE.2) THEN
79320 CALL PYSHOW(NC+MK+1,-NJET,ECMC)
79321 MSTJ14=MSTJ(14)
79322 IF(MSTJ(105).EQ.-1) MSTJ(14)=-1
79323 IF(MSTJ(105).GE.0) MSTU(28)=0
79324 CALL PYPREP(0)
79325 MSTJ(14)=MSTJ14
79326 IF(MSTJ(105).GE.0.AND.MSTU(28).NE.0) GOTO 100
79327 ENDIF
79328
79329C...Generate fragmentation. Information for PYTABU:
79330 IF(MSTJ(105).EQ.1) CALL PYEXEC
79331 MSTU(161)=110*KFLC+3
79332 MSTU(162)=0
79333
79334 RETURN
79335 END
79336
79337C*********************************************************************
79338
79339C...PYBOOK
79340C...Books a histogram.
79341
79342 SUBROUTINE PYBOOK(ID,TITLE,NX,XL,XU)
79343
79344C...Double precision declaration.
79345 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79346 IMPLICIT INTEGER(I-N)
79347C...Commonblock.
79348 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79349 SAVE /PYBINS/
79350C...Local character variables.
79351 CHARACTER TITLE*(*), TITFX*60
79352
79353C...Check that input is sensible. Find initial address in memory.
79354 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
79355 &'(PYBOOK:) not allowed histogram number')
79356 IF(NX.LE.0.OR.NX.GT.100) CALL PYERRM(28,
79357 &'(PYBOOK:) not allowed number of bins')
79358 IF(XL.GE.XU) CALL PYERRM(28,
79359 &'(PYBOOK:) x limits in wrong order')
79360 INDX(ID)=IHIST(4)
79361 IHIST(4)=IHIST(4)+28+NX
79362 IF(IHIST(4).GT.IHIST(2)) CALL PYERRM(28,
79363 &'(PYBOOK:) out of histogram space')
79364 IS=INDX(ID)
79365
79366C...Store histogram size and reset contents.
79367 BIN(IS+1)=NX
79368 BIN(IS+2)=XL
79369 BIN(IS+3)=XU
79370 BIN(IS+4)=(XU-XL)/NX
79371 CALL PYNULL(ID)
79372
79373C...Store title by conversion to integer to double precision.
79374 TITFX=TITLE//' '
79375 DO 100 IT=1,20
79376 BIN(IS+8+NX+IT)=256**2*ICHAR(TITFX(3*IT-2:3*IT-2))+
79377 & 256*ICHAR(TITFX(3*IT-1:3*IT-1))+ICHAR(TITFX(3*IT:3*IT))
79378 100 CONTINUE
79379
79380 RETURN
79381 END
79382
79383C*********************************************************************
79384
79385C...PYFILL
79386C...Fills entry in histogram.
79387
79388 SUBROUTINE PYFILL(ID,X,W)
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/
79396
79397C...Find initial address in memory. Increase number of entries.
79398 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
79399 &'(PYFILL:) not allowed histogram number')
79400 IS=INDX(ID)
79401 IF(IS.EQ.0) CALL PYERRM(28,
79402 &'(PYFILL:) filling unbooked histogram')
79403 BIN(IS+5)=BIN(IS+5)+1D0
79404
79405C...Find bin in x, including under/overflow, and fill.
79406 IF(X.LT.BIN(IS+2)) THEN
79407 BIN(IS+6)=BIN(IS+6)+W
79408 ELSEIF(X.GE.BIN(IS+3)) THEN
79409 BIN(IS+8)=BIN(IS+8)+W
79410 ELSE
79411 BIN(IS+7)=BIN(IS+7)+W
79412 IX=(X-BIN(IS+2))/BIN(IS+4)
79413 IX=MAX(0,MIN(NINT(BIN(IS+1))-1,IX))
79414 BIN(IS+9+IX)=BIN(IS+9+IX)+W
79415 ENDIF
79416
79417 RETURN
79418 END
79419
79420C*********************************************************************
79421
79422C...PYFACT
79423C...Multiplies histogram contents by factor.
79424
79425 SUBROUTINE PYFACT(ID,F)
79426
79427C...Double precision declaration.
79428 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79429 IMPLICIT INTEGER(I-N)
79430C...Commonblock.
79431 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79432 SAVE /PYBINS/
79433
79434C...Find initial address in memory. Multiply all contents bins.
79435 IF(ID.LE.0.OR.ID.GT.IHIST(1)) CALL PYERRM(28,
79436 &'(PYFACT:) not allowed histogram number')
79437 IS=INDX(ID)
79438 IF(IS.EQ.0) CALL PYERRM(28,
79439 &'(PYFACT:) scaling unbooked histogram')
79440 DO 100 IX=IS+6,IS+8+NINT(BIN(IS+1))
79441 BIN(IX)=F*BIN(IX)
79442 100 CONTINUE
79443
79444 RETURN
79445 END
79446
79447C*********************************************************************
79448
79449C...PYOPER
79450C...Performs operations between histograms.
79451
79452 SUBROUTINE PYOPER(ID1,OPER,ID2,ID3,F1,F2)
79453
79454C...Double precision declaration.
79455 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79456 IMPLICIT INTEGER(I-N)
79457C...Commonblock.
79458 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79459 SAVE /PYBINS/
79460C...Character variable.
79461 CHARACTER OPER*(*)
79462
79463C...Find initial addresses in memory, and histogram size.
79464 IF(ID1.LE.0.OR.ID1.GT.IHIST(1)) CALL PYERRM(28,
79465 &'(PYFACT:) not allowed histogram number')
79466 IS1=INDX(ID1)
79467 IS2=INDX(MIN(IHIST(1),MAX(1,ID2)))
79468 IS3=INDX(MIN(IHIST(1),MAX(1,ID3)))
79469 NX=NINT(BIN(IS3+1))
79470 IF(OPER.EQ.'M'.AND.ID3.EQ.0) NX=NINT(BIN(IS2+1))
79471
79472C...Update info on number of histogram entries.
79473 IF(OPER.EQ.'+'.OR.OPER.EQ.'-'.OR.OPER.EQ.'*'.OR.OPER.EQ.'/') THEN
79474 BIN(IS3+5)=BIN(IS1+5)+BIN(IS2+5)
79475 ELSEIF(OPER.EQ.'A'.OR.OPER.EQ.'S'.OR.OPER.EQ.'L') THEN
79476 BIN(IS3+5)=BIN(IS1+5)
79477 ENDIF
79478
79479C...Operations on pair of histograms: addition, subtraction,
79480C...multiplication, division.
79481 IF(OPER.EQ.'+') THEN
79482 DO 100 IX=6,8+NX
79483 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2*BIN(IS2+IX)
79484 100 CONTINUE
79485 ELSEIF(OPER.EQ.'-') THEN
79486 DO 110 IX=6,8+NX
79487 BIN(IS3+IX)=F1*BIN(IS1+IX)-F2*BIN(IS2+IX)
79488 110 CONTINUE
79489 ELSEIF(OPER.EQ.'*') THEN
79490 DO 120 IX=6,8+NX
79491 BIN(IS3+IX)=F1*BIN(IS1+IX)*F2*BIN(IS2+IX)
79492 120 CONTINUE
79493 ELSEIF(OPER.EQ.'/') THEN
79494 DO 130 IX=6,8+NX
79495 FA2=F2*BIN(IS2+IX)
79496 IF(ABS(FA2).LE.1D-20) THEN
79497 BIN(IS3+IX)=0D0
79498 ELSE
79499 BIN(IS3+IX)=F1*BIN(IS1+IX)/FA2
79500 ENDIF
79501 130 CONTINUE
79502
79503C...Operations on single histogram: multiplication+addition,
79504C...square root+addition, logarithm+addition.
79505 ELSEIF(OPER.EQ.'A') THEN
79506 DO 140 IX=6,8+NX
79507 BIN(IS3+IX)=F1*BIN(IS1+IX)+F2
79508 140 CONTINUE
79509 ELSEIF(OPER.EQ.'S') THEN
79510 DO 150 IX=6,8+NX
79511 BIN(IS3+IX)=F1*SQRT(MAX(0D0,BIN(IS1+IX)))+F2
79512 150 CONTINUE
79513 ELSEIF(OPER.EQ.'L') THEN
79514 ZMIN=1D20
79515 DO 160 IX=9,8+NX
79516 IF(BIN(IS1+IX).LT.ZMIN.AND.BIN(IS1+IX).GT.1D-20)
79517 & ZMIN=0.8D0*BIN(IS1+IX)
79518 160 CONTINUE
79519 DO 170 IX=6,8+NX
79520 BIN(IS3+IX)=F1*LOG10(MAX(ZMIN,BIN(IS1+IX)))+F2
79521 170 CONTINUE
79522
79523C...Operation on two or three histograms: average and
79524C...standard deviation.
79525 ELSEIF(OPER.EQ.'M') THEN
79526 DO 180 IX=6,8+NX
79527 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
79528 BIN(IS2+IX)=0D0
79529 ELSE
79530 BIN(IS2+IX)=BIN(IS2+IX)/BIN(IS1+IX)
79531 ENDIF
79532 IF(ID3.NE.0) THEN
79533 IF(ABS(BIN(IS1+IX)).LE.1D-20) THEN
79534 BIN(IS3+IX)=0D0
79535 ELSE
79536 BIN(IS3+IX)=SQRT(MAX(0D0,BIN(IS3+IX)/BIN(IS1+IX)-
79537 & BIN(IS2+IX)**2))
79538 ENDIF
79539 ENDIF
79540 BIN(IS1+IX)=F1*BIN(IS1+IX)
79541 180 CONTINUE
79542 ENDIF
79543
79544 RETURN
79545 END
79546
79547C*********************************************************************
79548
79549C...PYHIST
79550C...Prints and resets all histograms.
79551
79552 SUBROUTINE PYHIST
79553
79554C...Double precision declaration.
79555 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79556 IMPLICIT INTEGER(I-N)
79557C...Commonblock.
79558 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79559 SAVE /PYBINS/
79560
79561C...Loop over histograms, print and reset used ones.
79562 DO 100 ID=1,IHIST(1)
79563 IS=INDX(ID)
79564 IF(IS.NE.0.AND.NINT(BIN(IS+5)).GT.0) THEN
79565 CALL PYPLOT(ID)
79566 CALL PYNULL(ID)
79567 ENDIF
79568 100 CONTINUE
79569
79570 RETURN
79571 END
79572
79573C*********************************************************************
79574
79575C...PYPLOT
79576C...Prints a histogram (but does not reset it).
79577
79578 SUBROUTINE PYPLOT(ID)
79579
79580C...Double precision declaration.
79581 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79582 IMPLICIT INTEGER(I-N)
79583C...Commonblocks.
79584 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79585 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79586 SAVE /PYDAT1/,/PYBINS/
79587C...Local arrays and character variables.
79588 DIMENSION IDATI(6), IROW(100), IFRA(100), DYAC(10)
79589 CHARACTER TITLE*60, OUT*100, CHA(0:11)*1
79590
79591C...Steps in histogram scale. Character sequence.
79592 DATA DYAC/.04,.05,.06,.08,.10,.12,.15,.20,.25,.30/
79593 DATA CHA/'0','1','2','3','4','5','6','7','8','9','X','-'/
79594
79595C...Find initial address in memory; skip if empty histogram.
79596 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
79597 IS=INDX(ID)
79598 IF(IS.EQ.0) RETURN
79599 IF(NINT(BIN(IS+5)).LE.0) THEN
79600 WRITE(MSTU(11),5000) ID
79601 RETURN
79602 ENDIF
79603
79604C...Number of histogram lines and x bins.
79605 LIN=IHIST(3)-18
79606 NX=NINT(BIN(IS+1))
79607
79608C...Extract title by conversion from double precision via integer.
79609 DO 100 IT=1,20
79610 IEQ=NINT(BIN(IS+8+NX+IT))
79611 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//CHAR(MOD(IEQ,256**2)/256)
79612 & //CHAR(MOD(IEQ,256))
79613 100 CONTINUE
79614
79615C...Find time; print title.
79616 CALL PYTIME(IDATI)
79617 IF(IDATI(1).GT.0) THEN
79618 WRITE(MSTU(11),5100) ID, TITLE, (IDATI(J),J=1,5)
79619 ELSE
79620 WRITE(MSTU(11),5200) ID, TITLE
79621 ENDIF
79622
79623C...Find minimum and maximum bin content.
79624 YMIN=BIN(IS+9)
79625 YMAX=BIN(IS+9)
79626 DO 110 IX=IS+10,IS+8+NX
79627 IF(BIN(IX).LT.YMIN) YMIN=BIN(IX)
79628 IF(BIN(IX).GT.YMAX) YMAX=BIN(IX)
79629 110 CONTINUE
79630
79631C...Determine scale and step size for y axis.
79632 IF(YMAX-YMIN.GT.LIN*DYAC(1)*1D-9) THEN
79633 IF(YMIN.GT.0D0.AND.YMIN.LT.0.1D0*YMAX) YMIN=0D0
79634 IF(YMAX.LT.0D0.AND.YMAX.GT.0.1D0*YMIN) YMAX=0D0
79635 IPOT=INT(LOG10(YMAX-YMIN)+10D0)-10
79636 IF(YMAX-YMIN.LT.LIN*DYAC(1)*10D0**IPOT) IPOT=IPOT-1
79637 IF(YMAX-YMIN.GT.LIN*DYAC(10)*10D0**IPOT) IPOT=IPOT+1
79638 DELY=DYAC(1)
79639 DO 120 IDEL=1,9
79640 IF(YMAX-YMIN.GE.LIN*DYAC(IDEL)*10D0**IPOT) DELY=DYAC(IDEL+1)
79641 120 CONTINUE
79642 DY=DELY*10D0**IPOT
79643
79644C...Convert bin contents to integer form; fractional fill in top row.
79645 DO 130 IX=1,NX
79646 CTA=ABS(BIN(IS+8+IX))/DY
79647 IROW(IX)=SIGN(CTA+0.95D0,BIN(IS+8+IX))
79648 IFRA(IX)=10D0*(CTA+1.05D0-DBLE(INT(CTA+0.95D0)))
79649 130 CONTINUE
79650 IRMI=SIGN(ABS(YMIN)/DY+0.95D0,YMIN)
79651 IRMA=SIGN(ABS(YMAX)/DY+0.95D0,YMAX)
79652
79653C...Print histogram row by row.
79654 DO 150 IR=IRMA,IRMI,-1
79655 IF(IR.EQ.0) GOTO 150
79656 OUT=' '
79657 DO 140 IX=1,NX
79658 IF(IR.EQ.IROW(IX)) OUT(IX:IX)=CHA(IFRA(IX))
79659 IF(IR*(IROW(IX)-IR).GT.0) OUT(IX:IX)=CHA(10)
79660 140 CONTINUE
79661 WRITE(MSTU(11),5300) IR*DELY, IPOT, OUT
79662 150 CONTINUE
79663
79664C...Print sign and value of bin contents.
79665 IPOT=INT(LOG10(MAX(YMAX,-YMIN))+10.0001D0)-10
79666 OUT=' '
79667 DO 160 IX=1,NX
79668 IF(BIN(IS+8+IX).LT.-10D0**(IPOT-4)) OUT(IX:IX)=CHA(11)
79669 IROW(IX)=NINT(10D0**(3-IPOT)*ABS(BIN(IS+8+IX)))
79670 160 CONTINUE
79671 WRITE(MSTU(11),5400) OUT
79672 DO 180 IR=4,1,-1
79673 DO 170 IX=1,NX
79674 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
79675 170 CONTINUE
79676 WRITE(MSTU(11),5500) IPOT+IR-4, OUT
79677 180 CONTINUE
79678
79679C...Print sign and value of lower bin edge.
79680 IPOT=INT(LOG10(MAX(-BIN(IS+2),BIN(IS+3)-BIN(IS+4)))+
79681 & 10.0001D0)-10
79682 OUT=' '
79683 DO 190 IX=1,NX
79684 IF(BIN(IS+2)+(IX-1)*BIN(IS+4).LT.-10D0**(IPOT-3))
79685 & OUT(IX:IX)=CHA(11)
79686 IROW(IX)=NINT(10D0**(2-IPOT)*ABS(BIN(IS+2)+(IX-1)*BIN(IS+4)))
79687 190 CONTINUE
79688 WRITE(MSTU(11),5600) OUT
79689 DO 210 IR=3,1,-1
79690 DO 200 IX=1,NX
79691 OUT(IX:IX)=CHA(MOD(IROW(IX),10**IR)/10**(IR-1))
79692 200 CONTINUE
79693 WRITE(MSTU(11),5500) IPOT+IR-3, OUT
79694 210 CONTINUE
79695 ENDIF
79696
79697C...Calculate and print statistics.
79698 CSUM=0D0
79699 CXSUM=0D0
79700 CXXSUM=0D0
79701 DO 220 IX=1,NX
79702 CTA=ABS(BIN(IS+8+IX))
79703 X=BIN(IS+2)+(IX-0.5D0)*BIN(IS+4)
79704 CSUM=CSUM+CTA
79705 CXSUM=CXSUM+CTA*X
79706 CXXSUM=CXXSUM+CTA*X**2
79707 220 CONTINUE
79708 XMEAN=CXSUM/MAX(CSUM,1D-20)
79709 XRMS=SQRT(MAX(0D0,CXXSUM/MAX(CSUM,1D-20)-XMEAN**2))
79710 WRITE(MSTU(11),5700) NINT(BIN(IS+5)),XMEAN,BIN(IS+6),
79711 &BIN(IS+2),BIN(IS+7),XRMS,BIN(IS+8),BIN(IS+3)
79712
79713C...Formats for output.
79714 5000 FORMAT(/5X,'Histogram no',I5,' : no entries')
79715 5100 FORMAT('1'/5X,'Histogram no',I5,6X,A60,5X,I4,'-',I2,'-',I2,1X,
79716 &I2,':',I2/)
79717 5200 FORMAT('1'/5X,'Histogram no',I5,6X,A60/)
79718 5300 FORMAT(2X,F7.2,'*10**',I2,3X,A100)
79719 5400 FORMAT(/8X,'Contents',3X,A100)
79720 5500 FORMAT(9X,'*10**',I2,3X,A100)
79721 5600 FORMAT(/8X,'Low edge',3X,A100)
79722 5700 FORMAT(/5X,'Entries =',I12,1P,6X,'Mean =',D12.4,6X,'Underflow ='
79723 &,D12.4,6X,'Low edge =',D12.4/5X,'All chan =',D12.4,6X,
79724 &'Rms =',D12.4,6X,'Overflow =',D12.4,6X,'High edge =',D12.4)
79725
79726 RETURN
79727 END
79728
79729C*********************************************************************
79730
79731C...PYNULL
79732C...Resets bin contents of a histogram.
79733
79734 SUBROUTINE PYNULL(ID)
79735
79736C...Double precision declaration.
79737 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79738 IMPLICIT INTEGER(I-N)
79739C...Commonblock.
79740 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79741 SAVE /PYBINS/
79742
79743 IF(ID.LE.0.OR.ID.GT.IHIST(1)) RETURN
79744 IS=INDX(ID)
79745 IF(IS.EQ.0) RETURN
79746 DO 100 IX=IS+5,IS+8+NINT(BIN(IS+1))
79747 BIN(IX)=0D0
79748 100 CONTINUE
79749
79750 RETURN
79751 END
79752
79753C*********************************************************************
79754
79755C...PYDUMP
79756C...Dumps histogram contents on file for reading by other program.
79757C...Can also read back own dump.
79758
79759 SUBROUTINE PYDUMP(MDUMP,LFN,NHI,IHI)
79760
79761C...Double precision declaration.
79762 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79763 IMPLICIT INTEGER(I-N)
79764C...Commonblock.
79765 COMMON/PYBINS/IHIST(4),INDX(1000),BIN(20000)
79766 SAVE /PYBINS/
79767C...Local arrays and character variables.
79768 DIMENSION IHI(*),ISS(100),VAL(5)
79769 CHARACTER TITLE*60,FORMAT*13
79770
79771C...Dump all histograms that have been booked,
79772C...including titles and ranges, one after the other.
79773 IF(MDUMP.EQ.1) THEN
79774
79775C...Loop over histograms and find which are wanted and booked.
79776 IF(NHI.LE.0) THEN
79777 NW=IHIST(1)
79778 ELSE
79779 NW=NHI
79780 ENDIF
79781 DO 130 IW=1,NW
79782 IF(NHI.EQ.0) THEN
79783 ID=IW
79784 ELSE
79785 ID=IHI(IW)
79786 ENDIF
79787 IS=INDX(ID)
79788 IF(IS.NE.0) THEN
79789
79790C...Write title, histogram size, filling statistics.
79791 NX=NINT(BIN(IS+1))
79792 DO 100 IT=1,20
79793 IEQ=NINT(BIN(IS+8+NX+IT))
79794 TITLE(3*IT-2:3*IT)=CHAR(IEQ/256**2)//
79795 & CHAR(MOD(IEQ,256**2)/256)//CHAR(MOD(IEQ,256))
79796 100 CONTINUE
79797 WRITE(LFN,5100) ID,TITLE
79798 WRITE(LFN,5200) NX,BIN(IS+2),BIN(IS+3)
79799 WRITE(LFN,5300) NINT(BIN(IS+5)),BIN(IS+6),BIN(IS+7),
79800 & BIN(IS+8)
79801
79802
79803C...Write histogram contents, in groups of five.
79804 DO 120 IXG=1,(NX+4)/5
79805 DO 110 IXV=1,5
79806 IX=5*IXG+IXV-5
79807 IF(IX.LE.NX) THEN
79808 VAL(IXV)=BIN(IS+8+IX)
79809 ELSE
79810 VAL(IXV)=0D0
79811 ENDIF
79812 110 CONTINUE
79813 WRITE(LFN,5400) (VAL(IXV),IXV=1,5)
79814 120 CONTINUE
79815
79816C...Go to next histogram; finish.
79817 ELSEIF(NHI.GT.0) THEN
79818 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
79819 ENDIF
79820 130 CONTINUE
79821
79822C...Read back in histograms dumped MDUMP=1.
79823 ELSEIF(MDUMP.EQ.2) THEN
79824
79825C...Read histogram number, title and range, and book.
79826 140 READ(LFN,5100,END=170) ID,TITLE
79827 READ(LFN,5200) NX,XL,XU
79828 CALL PYBOOK(ID,TITLE,NX,XL,XU)
79829 IS=INDX(ID)
79830
79831C...Read filling statistics.
79832 READ(LFN,5300) NENTRY,BIN(IS+6),BIN(IS+7),BIN(IS+8)
79833 BIN(IS+5)=DBLE(NENTRY)
79834
79835C...Read histogram contents, in groups of five.
79836 DO 160 IXG=1,(NX+4)/5
79837 READ(LFN,5400) (VAL(IXV),IXV=1,5)
79838 DO 150 IXV=1,5
79839 IX=5*IXG+IXV-5
79840 IF(IX.LE.NX) BIN(IS+8+IX)=VAL(IXV)
79841 150 CONTINUE
79842 160 CONTINUE
79843
79844C...Go to next histogram; finish.
79845 GOTO 140
79846 170 CONTINUE
79847
79848C...Write histogram contents in column format,
79849C...convenient e.g. for GNUPLOT input.
79850 ELSEIF(MDUMP.EQ.3) THEN
79851
79852C...Find addresses to wanted histograms.
79853 NSS=0
79854 IF(NHI.LE.0) THEN
79855 NW=IHIST(1)
79856 ELSE
79857 NW=NHI
79858 ENDIF
79859 DO 180 IW=1,NW
79860 IF(NHI.EQ.0) THEN
79861 ID=IW
79862 ELSE
79863 ID=IHI(IW)
79864 ENDIF
79865 IS=INDX(ID)
79866 IF(IS.NE.0.AND.NSS.LT.100) THEN
79867 NSS=NSS+1
79868 ISS(NSS)=IS
79869 ELSEIF(NSS.GE.100) THEN
79870 CALL PYERRM(8,'(PYDUMP:) too many histograms requested')
79871 ELSEIF(NHI.GT.0) THEN
79872 CALL PYERRM(8,'(PYDUMP:) unknown histogram number')
79873 ENDIF
79874 180 CONTINUE
79875
79876C...Check that they have common number of x bins. Fix format.
79877 NX=NINT(BIN(ISS(1)+1))
79878 DO 190 IW=2,NSS
79879 IF(NINT(BIN(ISS(IW)+1)).NE.NX) THEN
79880 CALL PYERRM(8,'(PYDUMP:) different number of bins')
79881 RETURN
79882 ENDIF
79883 190 CONTINUE
79884 FORMAT='(1P,000E12.4)'
79885 WRITE(FORMAT(5:7),'(I3)') NSS+1
79886
79887C...Write histogram contents; first column x values.
79888 DO 200 IX=1,NX
79889 X=BIN(ISS(1)+2)+(IX-0.5D0)*BIN(ISS(1)+4)
79890 WRITE(LFN,FORMAT) X, (BIN(ISS(IW)+8+IX),IW=1,NSS)
79891 200 CONTINUE
79892
79893 ENDIF
79894
79895C...Formats for output.
79896 5100 FORMAT(I5,5X,A60)
79897 5200 FORMAT(I5,1P,2D12.4)
79898 5300 FORMAT(I12,1P,3D12.4)
79899 5400 FORMAT(1P,5D12.4)
79900
79901 RETURN
79902 END
79903
79904C*********************************************************************
79905
79906C...PYSTOP
79907C...Allows users to handle STOP statemens
79908
79909 SUBROUTINE PYSTOP(MCOD)
79910
79911C...Double precision and integer declarations.
79912 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79913 IMPLICIT INTEGER(I-N)
79914 INTEGER PYK,PYCHGE,PYCOMP
79915C...Commonblocks.
79916 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79917 SAVE /PYDAT1/
79918
79919
79920C...Write message, then stop
79921 WRITE(MSTU(11),5000) MCOD
79922 STOP
79923
79924
79925C...Formats for output.
79926 5000 FORMAT(/5X,'PYSTOP called with code: ',I4)
79927 END
79928
79929C*********************************************************************
79930
79931C...PYKCUT
79932C...Dummy routine, which the user can replace in order to make cuts on
79933C...the kinematics on the parton level before the matrix elements are
79934C...evaluated and the event is generated. The cross-section estimates
79935C...will automatically take these cuts into account, so the given
79936C...values are for the allowed phase space region only. MCUT=0 means
79937C...that the event has passed the cuts, MCUT=1 that it has failed.
79938
79939 SUBROUTINE PYKCUT(MCUT)
79940
79941C...Double precision and integer declarations.
79942 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
79943 IMPLICIT INTEGER(I-N)
79944 INTEGER PYK,PYCHGE,PYCOMP
79945C...Commonblocks.
79946 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
79947 COMMON/PYINT1/MINT(400),VINT(400)
79948 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
79949 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
79950
79951C...Set default value (accepting event) for MCUT.
79952 MCUT=0
79953
79954C...Read out subprocess number.
79955 ISUB=MINT(1)
79956 ISTSB=ISET(ISUB)
79957
79958C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
79959 TAU=VINT(21)
79960 YST=VINT(22)
79961 CTH=0D0
79962 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
79963 TAUP=0D0
79964 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
79965
79966C...Calculate x_1, x_2, x_F.
79967 IF(ISTSB.LE.2.OR.ISTSB.GE.5) THEN
79968 X1=SQRT(TAU)*EXP(YST)
79969 X2=SQRT(TAU)*EXP(-YST)
79970 ELSE
79971 X1=SQRT(TAUP)*EXP(YST)
79972 X2=SQRT(TAUP)*EXP(-YST)
79973 ENDIF
79974 XF=X1-X2
79975
79976C...Calculate shat, that, uhat, p_T^2.
79977 SHAT=TAU*VINT(2)
79978 SQM3=VINT(63)
79979 SQM4=VINT(64)
79980 RM3=SQM3/SHAT
79981 RM4=SQM4/SHAT
79982 BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
79983 RPTS=4D0*VINT(71)**2/SHAT
79984 BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
79985 RM34=2D0*RM3*RM4
79986 RSQM=1D0+RM34
79987 RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
79988 THAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4-BE34*CTH)
79989 UHAT=-0.5D0*SHAT*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
79990 PT2=MAX(VINT(71)**2,0.25D0*SHAT*BE34**2*(1D0-CTH**2))
79991
79992C...Decisions by user to be put here.
79993
79994C...Stop program if this routine is ever called.
79995C...You should not copy these lines to your own routine.
79996 WRITE(MSTU(11),5000)
79997 CALL PYSTOP(6)
79998
79999C...Format for error printout.
80000 5000 FORMAT(1X,'Error: you did not link your PYKCUT routine ',
80001 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
80002 &1X,'Execution stopped!')
80003
80004 RETURN
80005 END
80006
80007C*********************************************************************
80008
80009C...PYEVWT
80010C...Dummy routine, which the user can replace in order to multiply the
80011C...standard PYTHIA differential cross-section by a process- and
80012C...kinematics-dependent factor WTXS. For MSTP(142)=1 this corresponds
80013C...to generation of weighted events, with weight 1/WTXS, while for
80014C...MSTP(142)=2 it corresponds to a modification of the underlying
80015C...physics.
80016
80017 SUBROUTINE PYEVWT(WTXS)
80018
80019C...Double precision and integer declarations.
80020 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80021 IMPLICIT INTEGER(I-N)
80022 INTEGER PYK,PYCHGE,PYCOMP
80023C...Commonblocks.
80024 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80025 COMMON/PYINT1/MINT(400),VINT(400)
80026 COMMON/PYINT2/ISET(500),KFPR(500,2),COEF(500,20),ICOL(40,4,2)
80027 SAVE /PYDAT1/,/PYINT1/,/PYINT2/
80028
80029C...Set default weight for WTXS.
80030 WTXS=1D0
80031
80032C...Read out subprocess number.
80033 ISUB=MINT(1)
80034 ISTSB=ISET(ISUB)
80035
80036C...Read out tau, y*, cos(theta), tau' (where defined, else =0).
80037 TAU=VINT(21)
80038 YST=VINT(22)
80039 CTH=0D0
80040 IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) CTH=VINT(23)
80041 TAUP=0D0
80042 IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUP=VINT(26)
80043
80044C...Read out x_1, x_2, x_F, shat, that, uhat, p_T^2.
80045 X1=VINT(41)
80046 X2=VINT(42)
80047 XF=X1-X2
80048 SHAT=VINT(44)
80049 THAT=VINT(45)
80050 UHAT=VINT(46)
80051 PT2=VINT(48)
80052
80053C...Modifications by user to be put here.
80054
80055C...Stop program if this routine is ever called.
80056C...You should not copy these lines to your own routine.
80057 WRITE(MSTU(11),5000)
80058 CALL PYSTOP(4)
80059
80060C...Format for error printout.
80061 5000 FORMAT(1X,'Error: you did not link your PYEVWT routine ',
80062 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
80063 &1X,'Execution stopped!')
80064
80065 RETURN
80066 END
80067
80068C*********************************************************************
80069
80070C...UPINIT
80071C...Dummy routine, to be replaced by a user implementing external
80072C...processes. Is supposed to fill the HEPRUP commonblock with info
80073C...on incoming beams and allowed processes.
80074
80075C...New example: handles a standard Les Houches Events File.
80076
80077 SUBROUTINE UPINIT
80078
80079C...Double precision and integer declarations.
80080 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80081 IMPLICIT INTEGER(I-N)
80082
80083C...PYTHIA commonblock: only used to provide read unit MSTP(161).
80084 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80085 SAVE /PYPARS/
80086
80087C...User process initialization commonblock.
80088 INTEGER MAXPUP
80089 PARAMETER (MAXPUP=100)
80090 INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
80091 DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
80092 COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
80093 &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
80094 &LPRUP(MAXPUP)
80095 SAVE /HEPRUP/
80096
80097C...Lines to read in assumed never longer than 200 characters.
80098 PARAMETER (MAXLEN=200)
80099 CHARACTER*(MAXLEN) STRING
80100
80101C...Format for reading lines.
80102 CHARACTER*6 STRFMT
80103 STRFMT='(A000)'
80104 WRITE(STRFMT(3:5),'(I3)') MAXLEN
80105
80106C...Loop until finds line beginning with "<init>" or "<init ".
80107 100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
80108 IBEG=0
80109 110 IBEG=IBEG+1
80110C...Allow indentation.
80111 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
80112 IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
80113 &STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
80114
80115C...Read first line of initialization info.
80116 READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
80117 &EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
80118
80119C...Read NPRUP subsequent lines with information on each process.
80120 DO 120 IPR=1,NPRUP
80121 READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
80122 & XMAXUP(IPR),LPRUP(IPR)
80123 120 CONTINUE
80124 RETURN
80125
80126C...Error exit: give up if initalization does not work.
80127 130 WRITE(*,*) ' Failed to read LHEF initialization information.'
80128 WRITE(*,*) ' Event generation will be stopped.'
80129 CALL PYSTOP(12)
80130
80131 RETURN
80132 END
80133
80134C...Old example: handles a simple Pythia 6.4 initialization file.
80135
80136c SUBROUTINE UPINIT
80137
80138C...Double precision and integer declarations.
80139c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80140c IMPLICIT INTEGER(I-N)
80141
80142C...Commonblocks.
80143c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80144c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80145c SAVE /PYDAT1/,/PYPARS/
80146
80147C...User process initialization commonblock.
80148c INTEGER MAXPUP
80149c PARAMETER (MAXPUP=100)
80150c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
80151c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
80152c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
80153c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
80154c &LPRUP(MAXPUP)
80155c SAVE /HEPRUP/
80156
80157C...Read info from file.
80158c IF(MSTP(161).GT.0) THEN
80159c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
80160c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
80161c DO 100 IPR=1,NPRUP
80162c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
80163c & XMAXUP(IPR),LPRUP(IPR)
80164c 100 CONTINUE
80165c RETURN
80166C...Error or prematurely reached end of file.
80167c 110 WRITE(MSTU(11),5000)
80168c STOP
80169
80170C...Else not implemented.
80171c ELSE
80172c WRITE(MSTU(11),5100)
80173c STOP
80174c ENDIF
80175
80176C...Format for error printout.
80177c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
80178c &1X,'Execution stopped!')
80179c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
80180c &1X,'Dummy routine in PYTHIA file called instead.'/
80181c &1X,'Execution stopped!')
80182
80183c RETURN
80184c END
80185
80186C*********************************************************************
80187
80188C...UPEVNT
80189C...Dummy routine, to be replaced by a user implementing external
80190C...processes. Depending on cross section model chosen, it either has
80191C...to generate a process of the type IDPRUP requested, or pick a type
80192C...itself and generate this event. The event is to be stored in the
80193C...HEPEUP commonblock, including (often) an event weight.
80194
80195C...New example: handles a standard Les Houches Events File.
80196
80197 SUBROUTINE UPEVNT
80198
80199C...Double precision and integer declarations.
80200 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80201 IMPLICIT INTEGER(I-N)
80202
80203C...PYTHIA commonblock: only used to provide read unit MSTP(162).
80204 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80205 SAVE /PYPARS/
80206
80207C...User process event common block.
80208 INTEGER MAXNUP
80209 PARAMETER (MAXNUP=500)
80210 INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
80211 DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
80212 COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
80213 &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
80214 &VTIMUP(MAXNUP),SPINUP(MAXNUP)
80215 SAVE /HEPEUP/
80216
80217C...Lines to read in assumed never longer than 200 characters.
80218 PARAMETER (MAXLEN=200)
80219 CHARACTER*(MAXLEN) STRING
80220
80221C...Format for reading lines.
80222 CHARACTER*6 STRFMT
80223 STRFMT='(A000)'
80224 WRITE(STRFMT(3:5),'(I3)') MAXLEN
80225
80226C...Loop until finds line beginning with "<event>" or "<event ".
80227 100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
80228 IBEG=0
80229 110 IBEG=IBEG+1
80230C...Allow indentation.
80231 IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
80232 IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
80233 &STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
80234
80235C...Read first line of event info.
80236 READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
80237 &AQEDUP,AQCDUP
80238
80239C...Read NUP subsequent lines with information on each particle.
80240 DO 120 I=1,NUP
80241 READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
80242 & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
80243 & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
80244 120 CONTINUE
80245 RETURN
80246
80247C...Error exit, typically when no more events.
80248 130 WRITE(*,*) ' Failed to read LHEF event information.'
80249 WRITE(*,*) ' Will assume end of file has been reached.'
80250 NUP=0
80251 MSTI(51)=1
80252
80253 RETURN
80254 END
80255
80256C...Old example: handles a simple Pythia 6.4 event file.
80257
80258c SUBROUTINE UPEVNT
80259
80260C...Double precision and integer declarations.
80261c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80262c IMPLICIT INTEGER(I-N)
80263
80264C...Commonblocks.
80265c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80266c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80267c SAVE /PYDAT1/,/PYPARS/
80268
80269C...User process event common block.
80270c INTEGER MAXNUP
80271c PARAMETER (MAXNUP=500)
80272c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
80273c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
80274c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
80275c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
80276c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
80277c SAVE /HEPEUP/
80278
80279C...Read info from file.
80280c IF(MSTP(162).GT.0) THEN
80281c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
80282c & AQEDUP,AQCDUP
80283c DO 100 I=1,NUP
80284c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
80285c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
80286c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
80287c 100 CONTINUE
80288c RETURN
80289C...Special when reached end of file or other error.
80290c 110 NUP=0
80291
80292C...Else not implemented.
80293c ELSE
80294c WRITE(MSTU(11),5000)
80295c STOP
80296c ENDIF
80297
80298C...Format for error printout.
80299c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
80300c &1X,'Dummy routine in PYTHIA file called instead.'/
80301c &1X,'Execution stopped!')
80302
80303c RETURN
80304c END
80305
80306C*********************************************************************
80307
80308C...UPVETO
80309C...Dummy routine, to be replaced by user, to veto event generation
80310C...on the parton level, after parton showers but before multiple
80311C...interactions, beam remnants and hadronization is added.
80312C...If resonances like W, Z, top, Higgs and SUSY particles are handed
80313C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
80314C...be undecayed at this stage; if decayed their decay products will
80315C...have been allowed to shower.
80316
80317C...All partons at the end of the shower phase are stored in the
80318C...HEPEVT commonblock. The interesting information is
80319C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
80320C...IDHEP(I) = the particle ID code according to PDG conventions,
80321C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
80322C...All ISTHEP entries are 1, while the rest is zeroed.
80323
80324C...The user decision is to be conveyed by the IVETO value.
80325C...IVETO = 0 : retain current event and generate in full;
80326C... = 1 : abort generation of current event and move to next.
80327
80328 SUBROUTINE UPVETO(IVETO)
80329
80330C...HEPEVT commonblock.
80331 PARAMETER (NMXHEP=4000)
80332 COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
80333 &JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
80334 DOUBLE PRECISION PHEP,VHEP
80335 SAVE /HEPEVT/
80336
80337C...Next few lines allow you to see what info PYVETO extracted from
80338C...the full event record for the first two events.
80339C...Delete if you don't want it.
80340 DATA NLIST/0/
80341 SAVE NLIST
80342 IF(NLIST.LE.2) THEN
80343 WRITE(*,*) ' Full event record at time of UPVETO call:'
80344 CALL PYLIST(1)
80345 WRITE(*,*) ' Part of event record made available to UPVETO:'
80346 CALL PYLIST(5)
80347 NLIST=NLIST+1
80348 ENDIF
80349
80350C...Make decision here.
80351 IVETO = 0
80352
80353 RETURN
80354 END
80355
8ff9ce7d 80356
80357C... ALICE interface to PDFLIB with possibility to select nuclear structure
80358C... functions.
92e27c01 80359C...
8ff9ce7d 80360C... The MSTP array in the PYPARS common block is used to enable and
80361C... select the nuclear structure functions.
80362C... MSTP(52) : (D=1) choice of proton and nuclear structure-function library
80363C... =1: internal PYTHIA acording to MSTP(51)
80364C... =2: PDFLIB proton s.f., with MSTP(51) = 1000xNGROUP+NSET
80365C... MSTP( 51) = 1000xNPGROUP+NPSET
80366C... MSTP(151) = 1000xNAGROUP+NASET
80367C... MSTP(192) : Mass number of nucleus side 1
80368C... MSTP(193) : Mass number of nucleus side 2
92e27c01 80369C...
80370C...
8ff9ce7d 80371C... MINT(124) : side (1 or 2)
92e27c01 80372
80373
80374 SUBROUTINE PDFSET_ALICE(PARM, VALUE)
80375C...
80376 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80377 IMPLICIT INTEGER(I-N)
8ff9ce7d 80378C...Interface to PDFLIB.
92e27c01 80379 COMMON/LW50512/QCDL4,QCDL5
80380 SAVE /LW50512/
80381 DOUBLE PRECISION QCDL4,QCDL5
80382 COMMON/LW50513/XMIN,XMAX,Q2MIN,Q2MAX
80383 SAVE /LW50513/
80384 DOUBLE PRECISION XMIN,XMAX,Q2MIN,Q2MAX
80385C...
80386 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80387 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80388 DOUBLE PRECISION VALUE(20)
80389 CHARACTER*20 PARM(20)
8ff9ce7d 80390 write(6,*) MSTP(52)
80391 write(6,*) PARM
80392 write(6,*) VALUE
92e27c01 80393
80394 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
80395 PARM(5)='NATYPE'
80396 VALUE(5)=4
80397 PARM(6)='NAGROUP'
80398 VALUE(6)=MSTP(191)/1000
80399 PARM(7)='NASET'
80400 VALUE(7)=MOD(MSTP(191),1000)
80401 CALL PDFSET(PARM,VALUE,
80402 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
80403 > QCDL4,QCDL5,
80404 > XMIN,XMAX,Q2MIN,Q2MAX)
80405 IF (MSTP(194) .EQ. 0) THEN
80406 CALL SETLHAPARM("EKS98")
80407 ELSE
80408 CALL SETLHAPARM("EPS08")
80409 ENDIF
80410 ELSE
8ff9ce7d 80411 write(6,*) "-> pdfset"
92e27c01 80412 CALL PDFSET(PARM,VALUE,
80413 > MSTU(11),MSTP(51),MSTP(53),MSTP(55),
80414 > QCDL4,QCDL5,
80415 > XMIN,XMAX,Q2MIN,Q2MAX)
80416 ENDIF
8ff9ce7d 80417 write(6,*) "done"
92e27c01 80418 END
80419
80420
80421
80422 SUBROUTINE STRUCTM_ALICE
80423 + (XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
80424C...
80425 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80426 IMPLICIT INTEGER(I-N)
80427 COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
80428 COMMON/PYINT1/MINT(400),VINT(400)
8ff9ce7d 80429C write(6,*) "structm_alice->"
92e27c01 80430 IF (MSTP(192) .GT. 0 .AND. MSTP(193) .GT. 0) THEN
80431 A=MSTP(191+MINT(124))
8ff9ce7d 80432C write(6,*) mint(124), "-> structa ", A
92e27c01 80433 CALL STRUCTA(XX,QQ,A,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
80434 ELSE
8ff9ce7d 80435C write(6,*) mint(124), "-> structm "
92e27c01 80436 CALL STRUCTM(XX,QQ,UPV,DNV,USEA,DSEA,STR,CHM,BOT,TOP,GL)
80437 ENDIF
80438 END
8ff9ce7d 80439
92e27c01 80440
80441C*********************************************************************
80442
80443C...SUGRA
80444C...Dummy routine, to be removed when ISAJET (ISASUSY) is to be linked.
80445
80446 SUBROUTINE SUGRA(MZERO,MHLF,AZERO,TANB,SGNMU,MTOP,IMODL)
80447 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80448 IMPLICIT INTEGER(I-N)
80449 REAL MZERO,MHLF,AZERO,TANB,SGNMU,MTOP
80450 INTEGER IMODL
80451C...Commonblocks.
80452 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80453 SAVE /PYDAT1/
80454
80455C...Stop program if this routine is ever called.
80456 WRITE(MSTU(11),5000)
80457 CALL PYSTOP(110)
80458
80459C...Format for error printout.
80460 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
80461 &1X,'Dummy routine SUGRA in PYTHIA file called instead.'/
80462 &1X,'Execution stopped!')
80463
80464 RETURN
80465 END
80466
80467C*********************************************************************
80468
80469C...VISAJE
80470C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
80471
80472 FUNCTION VISAJE()
80473 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80474 IMPLICIT INTEGER(I-N)
80475 CHARACTER*40 VISAJE
80476
80477C...Commonblocks.
80478 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80479 SAVE /PYDAT1/
80480
80481C...Assign default value.
80482 VISAJE='Undefined'
80483
80484C...Stop program if this routine is ever called.
80485 WRITE(MSTU(11),5000)
80486 CALL PYSTOP(110)
80487
80488C...Format for error printout.
80489 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
80490 &1X,'Dummy function VISAJE in PYTHIA file called instead.'/
80491 &1X,'Execution stopped!')
80492
80493 RETURN
80494 END
80495
80496C*********************************************************************
80497
80498C...SSMSSM
80499C...Dummy function, to be removed when ISAJET (ISASUSY) is to be linked.
80500
80501 SUBROUTINE SSMSSM(RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,
80502 &RDUM8,RDUM9,RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,
80503 &RDUM17,RDUM18,RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25,
80504 &IDUM1,IDUM2)
80505 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80506 IMPLICIT INTEGER(I-N)
80507 REAL RDUM1,RDUM2,RDUM3,RDUM4,RDUM5,RDUM6,RDUM7,RDUM8,RDUM9,
80508 &RDUM10,RDUM11,RDUM12,RDUM13,RDUM14,RDUM15,RDUM16,RDUM17,RDUM18,
80509 &RDUM19,RDUM20,RDUM21,RDUM22,RDUM23,RDUM24,RDUM25
80510C...Commonblocks.
80511 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80512 SAVE /PYDAT1/
80513
80514C...Stop program if this routine is ever called.
80515 WRITE(MSTU(11),5000)
80516 CALL PYSTOP(110)
80517
80518C...Format for error printout.
80519 5000 FORMAT(1X,'Error: you did not link ISAJET correctly.'/
80520 &1X,'Dummy routine SSMSSM in PYTHIA file called instead.'/
80521 &1X,'Execution stopped!')
80522 RETURN
80523 END
80524
80525C*********************************************************************
80526
80527C...FHSETFLAGS
80528C...Dummy function, to be removed when FEYNHIGGS is to be linked.
80529
80530 SUBROUTINE FHSETFLAGS(IERR,IMSP,IFR,ITBR,IHMX,IP2A,ILP,ITR,IBR)
80531 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80532 IMPLICIT INTEGER(I-N)
80533Cmssmpart = 4 # full MSSM [recommended]
80534Cfieldren = 0 # MSbar field ren. [strongly recommended]
80535Ctanbren = 0 # MSbar TB-ren. [strongly recommended]
80536Chiggsmix = 2 # 2x2 (h0-HH) mixing in the neutral Higgs sector
80537Cp2approx = 0 # no approximation [recommended]
80538Clooplevel= 2 # include 2-loop corrections
80539Ctl_running_mt= 1 # running top mass in 2-loop corrections [recommended]
80540Ctl_bot_resum = 1 # resummed MB in 2-loop corrections [recommended]
80541
80542C...Commonblocks.
80543 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80544 SAVE /PYDAT1/
80545
80546C...Stop program if this routine is ever called.
80547 WRITE(MSTU(11),5000)
80548 CALL PYSTOP(103)
80549
80550C...Format for error printout.
80551 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
80552 &1X,'Dummy routine FHSETFLAGS in PYTHIA file called instead.'/
80553 &1X,'Execution stopped!')
80554 RETURN
80555 END
80556
80557C*********************************************************************
80558
80559C...FHSETPARA
80560C...Dummy function, to be removed when FEYNHIGGS is to be linked.
80561
80562 SUBROUTINE FHSETPARA(IER,SCF,DMT,DMB,DMW,DMZ,DTANB,DMA,DMH,DM3L,
80563 & DM3E,DM3Q,DM3U,DM3D,DM2L,DM2E,DM2Q,DM2U, DM2D,DM1L,DM1E,DM1Q,
80564 & DM1U,DM1D,DMU,AE33,AU33,AD33,AE22,AU22,AD22,AE11,AU11,AD11,
80565 & DM1,DM2,DM3,RLT,RLB,QTAU,QT,QB)
80566 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80567 IMPLICIT INTEGER(I-N)
80568
80569 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
80570 DOUBLE COMPLEX DMU,
80571 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
80572 & DM1, DM2, DM3
80573
80574C...Commonblocks.
80575 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80576 SAVE /PYDAT1/
80577
80578C...Stop program if this routine is ever called.
80579 WRITE(MSTU(11),5000)
80580 CALL PYSTOP(103)
80581
80582C...Format for error printout.
80583 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
80584 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
80585 &1X,'Execution stopped!')
80586 RETURN
80587 END
80588
80589C*********************************************************************
80590
80591C...FHHIGGSCORR
80592C...Dummy function, to be removed when FEYNHIGGS is to be linked.
80593
80594 SUBROUTINE FHHIGGSCORR(IERR, RMHIGG, SAEFF, UHIGGS)
80595 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80596 IMPLICIT INTEGER(I-N)
80597
80598C...FeynHiggs variables
80599 DOUBLE PRECISION RMHIGG(4)
80600 DOUBLE COMPLEX SAEFF, UHIGGS(3,3)
80601 DOUBLE COMPLEX DMU,
80602 & AE33, AU33, AD33, AE22, AU22, AD22, AE11, AU11, AD11,
80603 & DM1, DM2, DM3
80604
80605C...Commonblocks.
80606 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80607 SAVE /PYDAT1/
80608
80609C...Stop program if this routine is ever called.
80610 WRITE(MSTU(11),5000)
80611 CALL PYSTOP(103)
80612
80613C...Format for error printout.
80614 5000 FORMAT(1X,'Error: you did not link FEYNHIGGS correctly.'/
80615 &1X,'Dummy routine FHSETPARA in PYTHIA file called instead.'/
80616 &1X,'Execution stopped!')
80617 RETURN
80618 END
80619
80620C*********************************************************************
80621
80622C...PYTAUD
80623C...Dummy routine, to be replaced by user, to handle the decay of a
80624C...polarized tau lepton.
80625C...Input:
80626C...ITAU is the position where the decaying tau is stored in /PYJETS/.
80627C...IORIG is the position where the mother of the tau is stored;
80628C... is 0 when the mother is not stored.
80629C...KFORIG is the flavour of the mother of the tau;
80630C... is 0 when the mother is not known.
80631C...Note that IORIG=0 does not necessarily imply KFORIG=0;
80632C... e.g. in B hadron semileptonic decays the W propagator
80633C... is not explicitly stored but the W code is still unambiguous.
80634C...Output:
80635C...NDECAY is the number of decay products in the current tau decay.
80636C...These decay products should be added to the /PYJETS/ common block,
80637C...in positions N+1 through N+NDECAY. For each product I you must
80638C...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
80639C...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
80640
80641 SUBROUTINE PYTAUD(ITAU,IORIG,KFORIG,NDECAY)
80642
80643C...Double precision and integer declarations.
80644 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80645 IMPLICIT INTEGER(I-N)
80646 INTEGER PYK,PYCHGE,PYCOMP
80647C...Commonblocks.
80648 COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
80649 COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
80650 SAVE /PYJETS/,/PYDAT1/
80651
80652C...Stop program if this routine is ever called.
80653C...You should not copy these lines to your own routine.
80654 NDECAY=ITAU+IORIG+KFORIG
80655 WRITE(MSTU(11),5000)
80656 CALL PYSTOP(10)
80657
80658C...Format for error printout.
80659 5000 FORMAT(1X,'Error: you did not link your PYTAUD routine ',
80660 &'correctly.'/1X,'Dummy routine in PYTHIA file called instead.'/
80661 &1X,'Execution stopped!')
80662
80663 RETURN
80664 END
80665
80666C*********************************************************************
80667
80668C...PYTIME
80669C...Finds current date and time.
80670C...Since this task is not standardized in Fortran 77, the routine
80671C...is dummy, to be replaced by the user. Examples are given for
80672C...the Fortran 90 routine and DEC Fortran 77, and what to do if
80673C...you do not have access to suitable routines.
80674
80675 SUBROUTINE PYTIME(IDATI)
80676
80677C...Double precision and integer declarations.
80678 IMPLICIT DOUBLE PRECISION(A-H, O-Z)
80679 IMPLICIT INTEGER(I-N)
80680 INTEGER PYK,PYCHGE,PYCOMP
80681 CHARACTER*8 ATIME
80682C...Local array.
80683 INTEGER IDATI(6),IDTEMP(3),IVAL(8)
80684
80685C...Example 0: if you do not have suitable routines.
80686 DO 100 J=1,6
80687 IDATI(J)=0
80688 100 CONTINUE
80689
80690C...Example 1: Fortran 90 routine.
80691C CALL DATE_AND_TIME(VALUES=IVAL)
80692C IDATI(1)=IVAL(1)
80693C IDATI(2)=IVAL(2)
80694C IDATI(3)=IVAL(3)
80695C IDATI(4)=IVAL(5)
80696C IDATI(5)=IVAL(6)
80697C IDATI(6)=IVAL(7)
80698
80699C...Example 2: DEC Fortran 77. AIX.
80700C CALL IDATE(IMON,IDAY,IYEAR)
80701C IDATI(1)=IYEAR
80702C IDATI(2)=IMON
80703C IDATI(3)=IDAY
80704C CALL ITIME(IHOUR,IMIN,ISEC)
80705C IDATI(4)=IHOUR
80706C IDATI(5)=IMIN
80707C IDATI(6)=ISEC
80708
80709C...Example 3: DEC Fortran, IRIX, IRIX64.
80710C CALL IDATE(IMON,IDAY,IYEAR)
80711C IDATI(1)=IYEAR
80712C IDATI(2)=IMON
80713C IDATI(3)=IDAY
80714C CALL TIME(ATIME)
80715C IHOUR=0
80716C IMIN=0
80717C ISEC=0
80718C READ(ATIME(1:2),'(I2)') IHOUR
80719C READ(ATIME(4:5),'(I2)') IMIN
80720C READ(ATIME(7:8),'(I2)') ISEC
80721C IDATI(4)=IHOUR
80722C IDATI(5)=IMIN
80723C IDATI(6)=ISEC
80724
80725C...Example 4: GNU LINUX libU77, SunOS.
80726C CALL IDATE(IDTEMP)
80727C IDATI(1)=IDTEMP(3)
80728C IDATI(2)=IDTEMP(2)
80729C IDATI(3)=IDTEMP(1)
80730C CALL ITIME(IDTEMP)
80731C IDATI(4)=IDTEMP(1)
80732C IDATI(5)=IDTEMP(2)
80733C IDATI(6)=IDTEMP(3)
80734
80735C...Common code to ensure right century.
80736 IDATI(1)=2000+MOD(IDATI(1),100)
80737
80738 RETURN
80739 END